From 8136603c2b2b088ad8d09a07de52e6623fb74b83 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hj=C3=B6rleifur=20G=20Bergsteinsson?=
<hgbe@pop-os.localdomain>
Date: Wed, 4 May 2022 14:26:44 +0200
Subject: [PATCH] Updating functions that check if if variables where of some
type of class using ==. Now using inherits() to check.
---
DESCRIPTION | 2 +-
R/bspline.R | 2 +-
R/data.list.R | 2 +-
R/forecastmodel.R | 2 +-
R/getse.R | 4 ++--
R/lm_fit.R | 37 +------------------------------------
R/lp.R | 2 +-
R/rls_fit.R | 2 +-
R/step_optim.R | 12 ++++++------
src/RcppExports.cpp | 5 +++++
10 files changed, 20 insertions(+), 50 deletions(-)
diff --git a/DESCRIPTION b/DESCRIPTION
index f985e65..61fc175 100644
--- a/DESCRIPTION
+++ b/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
diff --git a/R/bspline.R b/R/bspline.R
index 56ae11f..8f2d795 100644
--- a/R/bspline.R
+++ b/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,
diff --git a/R/data.list.R b/R/data.list.R
index c115573..c703da1 100644
--- a/R/data.list.R
+++ b/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)
diff --git a/R/forecastmodel.R b/R/forecastmodel.R
index 1de0860..3bb7c42 100644
--- a/R/forecastmodel.R
+++ b/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))
diff --git a/R/getse.R b/R/getse.R
index 9cfdaa3..a82a9c0 100644
--- a/R/getse.R
+++ b/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)
})
}
diff --git a/R/lm_fit.R b/R/lm_fit.R
index 4c3db31..67271e7 100644
--- a/R/lm_fit.R
+++ b/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")
}
diff --git a/R/lp.R b/R/lp.R
index b117861..f9408eb 100644
--- a/R/lp.R
+++ b/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))
diff --git a/R/rls_fit.R b/R/rls_fit.R
index 794f327..14993be 100644
--- a/R/rls_fit.R
+++ b/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().") }
diff --git a/R/step_optim.R b/R/step_optim.R
index 3c84ec3..7824283 100644
--- a/R/step_optim.R
+++ b/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"
}
diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp
index a76e06a..20e61f5 100644
--- a/src/RcppExports.cpp
+++ b/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) {
--
GitLab