with kseqopt

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

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])

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

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).

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

R/rls_optim.R

@@ -74,8 +74,11 @@ 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 != ""){
         # Have to insert the parameters in the expressions to get the right state of the model for unique checksum

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){

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))
         }
     }
+    if(length(L) == 1){
+        names(L) <- "final"
+    }else{
         names(L) <- c(pst("step",1:(length(L)-1)),"final")
+    }
     invisible(L)
 }