diff --git a/R/as.data.list.R b/R/as.data.list.R
index fc685a0610e9ce69a821f6b6a64837e01fbaba4b..adeca1c8b6dc47cea32f3c3be674008da55f58f0 100644
--- a/R/as.data.list.R
+++ b/R/as.data.list.R
@@ -21,17 +21,15 @@
#' @title Convert to data.list class
#' @param object The object to be converted into a data.list
#' @return a value of class data.list
-#' @seealso \code{For specific detailed info see the children, e.g. \link{as.data.list.data.frame} }
-#' @family as.data.list
+#' @seealso \code{For specific detailed info see the children, e.g. \link{onlinefocast:::as.data.list.data.frame} }
#'
+#' @rdname as.data.list
#' @export
as.data.list <- function(object){
UseMethod("as.data.list")
}
-
-
#' Convert a data.frame into a data.list
#'
#' The convention is that columns with forecasts are postfixed with \code{.kxx} where
@@ -41,7 +39,6 @@ as.data.list <- function(object){
#' @param object The data.frame to be converted.
#' @return a data.list
#' @seealso as.data.list
-#' @family as.data.list
#' @examples
#' # Convert a dataframe with time and two observed variables
#' X <- data.frame(t=1:10, x=1:10, y=1:10)
@@ -55,7 +52,9 @@ as.data.list <- function(object){
#' X
#' as.data.frame(as.data.list(X))
#'
+#' @rdname as.data.list
#' @export
+
as.data.list.data.frame <- function(object) {
X <- object
#TEST
diff --git a/R/cache_name.R b/R/cache_name.R
index f3dd52288ce06b037daeb842bb5410bb417f70f1..9f76adad49e191481303683e864477b0a160fddb 100644
--- a/R/cache_name.R
+++ b/R/cache_name.R
@@ -92,7 +92,8 @@ cache_name <- function(..., cachedir = "cache"){
## }
## fundef <- digest::digest(attr(eval(val[[funname]]), "srcref"))
# Somehow the above stopped working, don't know why! just take it, this should do the same I guess
- fundef <- digest::digest(get(funname))
+ fundef <- try(get(funname), silent=TRUE)
+ fundef <- digest::digest(fundef)
# if no arguments were given, then use the arguments function from which cache_name was called
if(length(list(...)) == 0){
funargs <- digest::digest(as.list( match.call(definition = sys.function( -1 ), call = sys.call(-1)))[-1])
diff --git a/R/forecastmodel.R b/R/forecastmodel.R
index 463ab14229391f33c93df1e283ccae1f889f9b72..2c0c5954a93987b517ca6cf2102327b5fcf8fdcc 100644
--- a/R/forecastmodel.R
+++ b/R/forecastmodel.R
@@ -23,6 +23,8 @@ forecastmodel <- R6::R6Class("forecastmodel", public = list(
#
# The horizons to fit for
kseq = NA,
+ # The horizons to optimize for
+ kseqopt = NA,
# The (transformation stage) parameters (only the ones set in last call of insert_prm())
prm = NA,
# Stores the maximum lag for AR terms
diff --git a/R/forecastmodel.R-documentation.R b/R/forecastmodel.R-documentation.R
index 9b7fdcf0abf2ed15db92a33c9c9005c881114e8f..8e075849653a73d43bd64a1d534b711f0ff1fdf6 100644
--- a/R/forecastmodel.R-documentation.R
+++ b/R/forecastmodel.R-documentation.R
@@ -48,6 +48,8 @@
#'
#' - kseq = NA: The horizons to fit for.
#'
+#' - kseqopt = NA: The horizons to fit for when optimizing.
+#'
#' - p = NA: The (transformation stage) parameters used for the fit.
#'
#' - Lfits = list(): The regression fits, one for each k in kseq (simply a list with the latest fit).
diff --git a/R/lm_optim.R b/R/lm_optim.R
index 2c6bd686541cb148113291a2e31f95690b43b4e3..70c293e241575d7fd597ac5fbd04acd0961826bd 100644
--- a/R/lm_optim.R
+++ b/R/lm_optim.R
@@ -70,7 +70,10 @@ lm_optim <- function(model, data, kseq = NA, scorefun = rmse, cachedir="", cache
m <- model$clone_deep()
if(!is.na(kseq[1])){
m$kseq <- kseq
+ }else if(!is.na(m$kseqopt[1])){
+ m$kseq <- m$kseqopt
}
+
## Caching the results based on some of the function arguments
if(cachedir != ""){
# Have to insert the parameters in the expressions to get the right state of the model for unique checksum
diff --git a/R/rls_optim.R b/R/rls_optim.R
index 7c60e1daf98d5cb8d4834d9c91368f0066a680e1..40a30660acc40bf9fb2c0ee43befd9f33d8ebb24 100644
--- a/R/rls_optim.R
+++ b/R/rls_optim.R
@@ -74,7 +74,10 @@ rls_optim <- function(model, data, kseq = NA, scorefun = rmse, cachedir="", cach
m <- model$clone_deep()
if(!is.na(kseq[1])){
m$kseq <- kseq
+ }else if(!is.na(m$kseqopt[1])){
+ m$kseq <- m$kseqopt
}
+
# Caching the results based on some of the function arguments
if(cachedir != ""){
diff --git a/R/score.R b/R/score.R
index a1621a799de202f4800439cf85372f35fb743c58..0c13add2919d963fed646d293482a67801802eac 100644
--- a/R/score.R
+++ b/R/score.R
@@ -85,7 +85,7 @@ score.data.frame <- function(object, scoreperiod = NA, usecomplete = TRUE, score
if( length(scoreperiod) != nrow(object) ){
stop("scoreperiod is not same length as nrow(object): ",txt)
}else{
- if( all(is.na(scoreperiod)) ){ stop("scoreperiod is all NA: ",txt) }
+ if( all(is.na(scoreperiod)) ){ stop("At least one forecast horizon or scoreperiod is all NA: ",txt) }
}
# Calculate the objective function for each horizon
scoreval <- sapply(1:ncol(object), function(i){
diff --git a/R/step_optim.R b/R/step_optim.R
index dee77a9631d917168c4ac8fa880b2b0d4824bfd3..a0b178831153bcfdee4b56df1249bc798b67bb15 100644
--- a/R/step_optim.R
+++ b/R/step_optim.R
@@ -116,8 +116,8 @@
#' # Optimization bounds for parameters
#' model$add_prmbounds(lambda = c(0.9, 0.99, 0.9999))
#'
-#' # Select a model, just run it for a single horizon
-#' kseq <- 5
+#' # Select a model, in the optimization just run it for a single horizon
+#' model$kseqopt <- 5
#' #
#' prm <- list(mu_tday__nharmonics = c(min=3, max=7))
#'
@@ -126,7 +126,7 @@
#' control <- list(maxit=1)
#'
#' # Run the default selection scheme, which is "both" (same as "backwardboth" if no start model is given)
-#' L <- step_optim(model, D, kseq, prm, control=control)
+#' L <- step_optim(model, D, prm, control=control)
#'
#' # The optim value from each step is returned
#' getse(L, "optimresult")
@@ -136,26 +136,26 @@
#' L$final$model
#'
#' # Other selection schemes
-#' Lforward <- step_optim(model, D, kseq, prm, "forward", control=control)
-#' Lbackward <- step_optim(model, D, kseq, prm, "backward", control=control)
-#' Lbackwardboth <- step_optim(model, D, kseq, prm, "backwardboth", control=control)
-#' Lforwardboth <- step_optim(model, D, kseq, prm, "forwardboth", control=control, mc.cores=1)
+#' Lforward <- step_optim(model, D, prm, "forward", control=control)
+#' Lbackward <- step_optim(model, D, prm, "backward", control=control)
+#' Lbackwardboth <- step_optim(model, D, prm, "backwardboth", control=control)
+#' Lforwardboth <- step_optim(model, D, prm, "forwardboth", control=control, mc.cores=1)
#'
#' # It's possible avoid removing specified inputs
-#' L <- step_optim(model, D, kseq, prm, keepinputs = c("mu","mu_tday"), control=control)
+#' L <- step_optim(model, D, prm, keepinputs = c("mu","mu_tday"), control=control)
#'
#' # Give a starting model
#' modelstart <- model$clone_deep()
#' modelstart$inputs[2:3] <- NULL
-#' L <- step_optim(model, D, kseq, prm, modelstart=modelstart, control=control)
+#' L <- step_optim(model, D, prm, modelstart=modelstart, control=control)
#'
#' # If a fitting function is given, then it will be used for calculating the forecasts
#' # ONLY on the complete cases in each step
-#' L1 <- step_optim(model, D, kseq, prm, fitfun=rls_fit, control=control)
+#' L1 <- step_optim(model, D, prm, fitfun=rls_fit, control=control)
#'
#' # The easiest way to conclude if missing values have an influence is to
#' # compare the selection result running with and without
-#' L2 <- step_optim(model, D, kseq, prm, control=control)
+#' L2 <- step_optim(model, D, prm, control=control)
#'
#' # Compare the selected models
#' tmp1 <- capture.output(getse(L1, "model"))
@@ -166,13 +166,13 @@
#' # Note that caching can be really smart (the cache files are located in the
#' # cachedir folder (folder in current working directory, can be removed with
#' # unlink(foldername)) See e.g. `?rls_optim` for how the caching works
-#' # L <- step_optim(model, D, kseq, prm, "forward", cachedir="cache", cachererun=FALSE)
+#' # L <- step_optim(model, D, prm, "forward", cachedir="cache", cachererun=FALSE)
#'
#' @importFrom parallel mclapply
#'
#' @export
-step_optim <- function(modelfull, data, kseq = NA, prm=list(NA), direction = c("both","backward","forward","backwardboth","forwardboth"), modelstart=NA, keepinputs = FALSE, optimfun = rls_optim, fitfun = NA, scorefun = rmse, printout = FALSE, mc.cores = getOption("mc.cores", 2L), ...){
+step_optim <- function(modelfull, data, prm=list(NA), kseq = NA, direction = c("both","backward","forward","backwardboth","forwardboth"), modelstart=NA, keepinputs = FALSE, optimfun = rls_optim, fitfun = NA, scorefun = rmse, printout = FALSE, mc.cores = getOption("mc.cores", 2L), ...){
# Do:
# - checking of input, model, ...
# - Maybe have "cloneit" argument in optimfun, then don't clone inside optim.
@@ -246,7 +246,7 @@ step_optim <- function(modelfull, data, kseq = NA, prm=list(NA), direction = c("
while(!done){
message("\n------------------------------------------------------------------------\n")
message(pst("Step ",istep,". Current model:"))
- print(m)
+ message(print(m))
# If the init model is not yet optimized
if(istep == 1 & length(L) == 0){
# Optimize
@@ -393,7 +393,7 @@ step_optim <- function(modelfull, data, kseq = NA, prm=list(NA), direction = c("
tmp <- cbind(tmp, apply(casesStep != casesCurrent, 2, sum))
nams(tmp)[2] <- "CasesDiff"
}
- print(tmp)
+ onlineforecast:::print_to_message(tmp)
# Compare scores: Is one the step models score smaller than the current ref?
imin <- which.min(scoreStep)
@@ -421,6 +421,10 @@ step_optim <- function(modelfull, data, kseq = NA, prm=list(NA), direction = c("
message(print(m))
}
}
- names(L) <- c(pst("step",1:(length(L)-1)),"final")
+ if(length(L) == 1){
+ names(L) <- "final"
+ }else{
+ names(L) <- c(pst("step",1:(length(L)-1)),"final")
+ }
invisible(L)
}