Updating functions that check if if variables where of some type of class...

Updating functions that check if if variables where of some type of class using ==. Now using inherits() to check.

DESCRIPTION

@@ -25,7 +25,7 @@ Suggests:
     data.table,
     plotly
 VignetteBuilder: knitr
-RoxygenNote: 7.1.1
+RoxygenNote: 7.1.2
 URL: https://onlineforecasting.org
 BugReports: https://lab.compute.dtu.dk/packages/onlineforecast/-/issues
 Config/testthat/edition: 3

R/bspline.R

@@ -72,7 +72,7 @@ bspline <- function(X, Boundary.knots = NA, intercept = FALSE, df = NULL, knots
         Boundary.knots <- bknots
     }
     # If a list, then call on each element
-    if (class(X) == "list") {
+    if (inherits(X, "list")){
         # Call again for each element
         val <- lapply(1:length(X), function(i) {
             bspline(X[[i]], df = df, knots = knots, degree = degree, intercept = intercept, 

R/data.list.R

@@ -209,7 +209,7 @@ subset.data.list <- function(x, subset = NA, nms = NA, kseq = NA, lagforecasts =
 as.data.frame.data.list <- function(x, row.names=NULL, optional=FALSE, ...){
     # Then convert into a data.frame
     val <- do.call("cbind", x)
-    if(class(val) == "matrix"){
+    if(inherits(val, "matrix")){
         val <- as.data.frame(val)
     }
     # Fix names of data.frames (i.e. forecasts, their names are now "kxx", but should be X.kxx)

R/forecastmodel.R

@@ -286,7 +286,7 @@ forecastmodel <- R6::R6Class("forecastmodel", public = list(
                     if( nrow(data[[nm]]) != length(data$t) ){
                         stop(pst("The input variable '",nm,"' doesn't have the same number of observations as time vector 't' in the data. It has ",nrow(data[[nm]]),", but 't' has ",length(data$t)))
                     }
-                }else if(class(data[[nm]]) == "numeric"){
+                }else if(inherits(data[[nm]], "numeric")){
                     # Observation input, check the length
                     if( length(data[[nm]]) != length(data$t) ){
                         stop("The input variable '",nm,"' doesn't have the same number of observations as time vector 't' in the data. It has ",length(data[[nm]]),", but 't' has ",length(data$t))

R/getse.R

@@ -70,14 +70,14 @@ getse <- function(L, inm = NA, depth = 2, useregex = FALSE, fun = NA) {
     if(depth == 1){
         if(useregex){ inm <- grep(inm, names(L)) }
         R <- L[[inm]]
-        if(class(fun) == "function"){ R <- fun(R) }
+        if(inherits(fun, "function")){ R <- fun(R) }
     }
     # Match in the subelements of L?
     if(depth == 2){
         R <- lapply(L, function(x){
             if(useregex){ inm <- grep(inm, names(x)) }
             val <- x[[inm]]
-            if(class(fun) == "function"){ val <- fun(val) }
+            if(inherits(fun, "function")){ val <- fun(val) }
             return(val)
         })
     }

R/lm_fit.R

@@ -130,7 +130,7 @@ lm_fit <- function(prm=NA, model, data, scorefun = NA, returnanalysis = TRUE, pr
     #----------------------------------------------------------------
     # Calculate the result to return
     # If the objective function (scorefun) is given
-    if(class(scorefun) == "function"){
+    if(inherits(scorefun, "function")){
         # Do some checks
         if( !("scoreperiod" %in% names(data)) ){ stop("data$scoreperiod is not set: Must have it set to an index (int or logical) defining which points to be evaluated in the scorefun().") }
         if( all(is.na(data$scoreperiod)) ){ stop("data$scoreperiod is not set correctly: It must be set to an index (int or logical) defining which points to be evaluated in the scorefun().") }
@@ -156,39 +156,4 @@ lm_fit <- function(prm=NA, model, data, scorefun = NA, returnanalysis = TRUE, pr
         return(val)
     }
 
-    ## OLD
-    ## # Is an objective function given?
-    ## if(class(scorefun) == "function" & !returnanalysis){
-    ##     # Do some checks
-    ##     if( !("scoreperiod" %in% names(data)) ){ stop("data$scoreperiod are set: Must have it set to an index (int or logical) defining which points to be evaluated in the scorefun().") }
-    ##     if( all(is.na(data$scoreperiod)) ){ stop("data$scoreperiod is not set correctly: It must be set to an index (int or logical) defining which points to be evaluated in the scorefun().") }
-    ##     scoreperiod <- data$scoreperiod    
-    ##     # Return the scorefun values
-    ##     scoreval <- sapply(1:ncol(Yhat), function(i){
-    ##         scorefun(Resid[scoreperiod,i])
-    ##     })
-    ##     nams(scoreval) <- nams(Yhat)
-    ##     val <- sum(scoreval, na.rm = TRUE)
-    ##     if(printout){print(c(scoreval,sum=val))}
-    ##     return(val)
-    ## } else if(returnanalysis){
-    ##     # The estimated coefficients
-    ##     Lfitval <- lapply(model$Lfits, function(model){ 
-    ##       coef <- model$coefficients
-    ##       names(coef) <- gsub("(.+?)(\\.k.*)", "\\1", names(coef))
-    ##       return(coef)
-    ##     })
-    ##     # Include score function
-    ##     scoreval <- NA
-    ##     if(class(scorefun) == "function"){
-    ##         # Calculate the objective function for each horizon
-    ##         scoreval <- sapply(1:ncol(Yhat), function(i){
-    ##             scorefun(Resid[,i])
-    ##         })
-    ##         nams(scoreval) <- nams(Yhat)
-    ##     }
-    ##     # Return the model validation data
-    ##     return(list(Yhat = Yhat, t = data$t, Resid = Resid, datatr = datatr, Lfitval = Lfitval, scoreval = scoreval, scoreperiod = data$scoreperiod))
-    ## }
-    ## invisible("ok")
 }

R/lp.R

@@ -37,7 +37,7 @@
 
 lp <- function(X, a1, usestate = TRUE) {
     ## 
-    if (class(X) == "list") {
+    if (inherits(X, "list")) {
         ## If only one coefficient, then repeat it
         if (length(a1) == 1) {
             a1 <- rep(a1, length(X))

R/rls_fit.R

@@ -183,7 +183,7 @@ rls_fit <- function(prm=NA, model, data, scorefun = NA, returnanalysis = TRUE,
     #----------------------------------------------------------------
     # Calculate the result to return
     # If the objective function (scorefun) is given
-    if(class(scorefun) == "function"){
+    if(inherits(scorefun, "function")){
         # Do some checks
         if( !("scoreperiod" %in% names(data)) ){ stop("data$scoreperiod is not set: Must have it set to an index (int or logical) defining which points to be evaluated in the scorefun().") }
         if( all(is.na(data$scoreperiod)) ){ stop("data$scoreperiod is not set correctly: It must be set to an index (int or logical) defining which points to be evaluated in the scorefun().") }

R/step_optim.R

@@ -201,7 +201,7 @@ step_optim <- function(modelfull, data, prm=list(NA), direction = c("both","back
     # Init
     istep <- 1
     # Different start up, if a start model is given
-    if( class(modelstart)[1] == "forecastmodel" ){
+    if( inherits(modelstart, "forecastmodel")){
         # The full model will not be changed from here, so no need to clone it
         mfull <- modelfull
         m <- modelstart$clone()
@@ -239,7 +239,7 @@ step_optim <- function(modelfull, data, prm=list(NA), direction = c("both","back
         }
     }
     # Find the inputs to keep, if any
-    if(class(keepinputs) == "logical"){
+    if(inherits(keepinputs, "logical")){
         if(keepinputs){
             keepinputs <- nams(mfull$inputs)
         }else{
@@ -263,7 +263,7 @@ step_optim <- function(modelfull, data, prm=list(NA), direction = c("both","back
             # Optimize
             res <- optimfun(m, data, printout=printout, scorefun=scorefun, ...)
             # Should we forecast only on the complete cases?
-            if(class(fitfun) == "function"){
+            if(inherits(fitfun, "function")){
                 # Forecast to get the complete cases
                 mtmp <- m$clone_deep()
                 # If kseqopt is set, then make sure that it is used when fitting here
@@ -283,7 +283,7 @@ step_optim <- function(modelfull, data, prm=list(NA), direction = c("both","back
         }
         
         message("Current score: ",format(scoreCurrent,digits=7))
-        if(class(fitfun) == "function"){
+        if(inherits(fitfun, "function")){
             message("Current complete cases: ",sum(casesCurrent)," (Diff in score from optim:",L[[istep]]$optimresult$value-scoreCurrent,")")
         }
         # Next step
@@ -379,7 +379,7 @@ step_optim <- function(modelfull, data, prm=list(NA), direction = c("both","back
             names(Lstep) <- names(mStep)
 
             # Complete cases considered: Should we forecast and recalculate the score on complete cases from all models?
-            if(class(fitfun) == "function"){
+            if(inherits(fitfun, "function")){
                 LYhat <- mclapply(1:length(mStep), function(i){
                     mtmp <- mStep[[i]]$clone_deep()
                     # If kseqopt is set, then make sure that it is used when fitting here
@@ -406,7 +406,7 @@ step_optim <- function(modelfull, data, prm=list(NA), direction = c("both","back
                 tmp[ ,1] <- pst(format(100 * (scoreCurrent - tmp) / scoreCurrent, digits=2),"%")
                 nams(tmp) <- "Improvement"
             }
-            if(class(fitfun) == "function"){
+            if(inherits(fitfun, "function")){
                 tmp <- cbind(tmp, apply(casesStep != casesCurrent, 2, sum))
                 nams(tmp)[2] <- "CasesDiff"
             }

src/RcppExports.cpp

@@ -6,6 +6,11 @@
 
 using namespace Rcpp;
 
+#ifdef RCPP_USE_GLOBAL_ROSTREAM
+Rcpp::Rostream<true>&  Rcpp::Rcout = Rcpp::Rcpp_cout_get();
+Rcpp::Rostream<false>& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get();
+#endif
+
 // lp_vector_cpp
 NumericVector lp_vector_cpp(NumericVector x, double a1);
 RcppExport SEXP _onlineforecast_lp_vector_cpp(SEXP xSEXP, SEXP a1SEXP) {