More bugfixes

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: smooth
 Type: Package
 Title: Forecasting Using State Space Models
-Version: 4.0.1.41010
-Date: 2023-11-10
+Version: 4.0.1.41013
+Date: 2023-11-13
 Authors@R: person("Ivan", "Svetunkov", email = "ivan@svetunkov.ru", role = c("aut", "cre"),
                   comment="Lecturer at Centre for Marketing Analytics and Forecasting, Lancaster University, UK")
 URL: https://github.com/config-i1/smooth

NEWS

@@ -1,4 +1,4 @@
-smooth v4.0.1 (Release data: 2023-11-10)
+smooth v4.0.1 (Release data: 2023-11-13)
 =======
 
 Changes:
@@ -13,6 +13,7 @@ Bugfixes:
 * adam() would not remove components of ETS correctly in cases of small samples (e.g. obs == 2*frequency).
 * Fixed the code of sma() - there was a bug in the architecture resulting in wrong fitting.
 * ARIMA parameters are now initialised even when ACF/PACF returns NaNs (exotic case).
+* Fixed bugs in es() not accepting xreg of a different length than y and not using the existing data in pre-estimated model via model=ourModel. Thanks to Nikos Kourentzes for spotting these!
 
 
 smooth v4.0.0 (Release data: 2023-09-15)

R/adam-es.R

@@ -258,10 +258,11 @@ es <- function(y, model="ZZZ", lags=c(frequency(y)), persistence=NULL, phi=NULL,
     }
 
     # If a previous model provided as a model, write down the variables
-    if(is.smooth(model) | is.smooth.sim(model)){
+    if(is.smooth(model) || is.smooth.sim(model)){
         if(smoothType(model)!="ETS"){
             stop("The provided model is not ETS.",call.=FALSE);
         }
+
         # If this is the simulated data, extract the parameters
         if(is.smooth.sim(model) & !is.null(dim(model$data))){
             warning("The provided model has several submodels. Choosing a random one.",call.=FALSE);
@@ -273,31 +274,30 @@ es <- function(y, model="ZZZ", lags=c(frequency(y)), persistence=NULL, phi=NULL,
         else{
             persistence <- model$persistence;
             initial <- model$initial;
-            initialSeason <- model$initialSeason;
+            # initialSeason <- model$initialSeason;
             if(any(model$probability!=1)){
                 occurrence <- "a";
             }
         }
         phi <- model$phi;
-        if(is.null(xreg)){
-            xreg <- model$xreg;
-        }
-        else{
-            if(is.null(model$xreg)){
-                xreg <- NULL;
-            }
-            else{
-                if(ncol(xreg)!=ncol(model$xreg)){
-                    xreg <- xreg[,colnames(model$xreg)];
-                }
-            }
+        if(is.null(xreg) && !is.null(model$initial$xreg)){
+            # Exctract xreg
+            xreg <- model$data[,all.vars(model$formula)[-1]];
         }
 
-        initialX <- model$initialX;
+        # initialX <- model$initialX;
+
+        # if(is.adam(model)){
+        #     y <- model$data;
+        # }
+        # else{
+        #     y <- model$y;
+        # }
+
         model <- modelType(model);
-        if(any(unlist(gregexpr("C",model))!=-1)){
-            initial <- "o";
-        }
+        # if(any(unlist(gregexpr("C",model))!=-1)){
+        #     initial <- "o";
+        # }
     }
     else if(inherits(model,"ets")){
         # Extract smoothing parameters
@@ -353,8 +353,12 @@ es <- function(y, model="ZZZ", lags=c(frequency(y)), persistence=NULL, phi=NULL,
 
     # Merge y and xreg into one data frame
     if(!is.null(xreg) && is.numeric(y)){
-        data <- cbind(y=as.data.frame(y),as.data.frame(xreg));
-        data <- as.matrix(data)
+        if(is.matrix(xreg)){
+            data <- as.matrix(cbind(y=as.data.frame(y),as.data.frame(xreg[1:length(y),])));
+        }
+        else{
+            data <- as.matrix(cbind(y=as.data.frame(y),as.data.frame(xreg[1:length(y)])));
+        }
         data <- ts(data, start=start(y), frequency=frequency(y));
         colnames(data)[1] <- "y";
         # Give name to the explanatory variables if they do not have them
@@ -371,22 +375,28 @@ es <- function(y, model="ZZZ", lags=c(frequency(y)), persistence=NULL, phi=NULL,
         data <- y;
     }
 
-    # Prepare initials if they are numeric
-    initialValue <- vector("list",(!is.null(initial))*1 +(!is.null(initialSeason))*1 +(!is.null(initialX))*1);
-    names(initialValue) <- c("level","seasonal","xreg")[c(!is.null(initial),!is.null(initialSeason),!is.null(initialX))];
-    if(is.numeric(initial)){
-        initialValue <- switch(length(initial),
-                               "1"=list(level=initial[1]),
-                               "2"=list(level=initial[1],
-                                        trend=initial[2]));
-    }
-    if(!is.null(initialSeason)){
-        initialValue$seasonal <- initialSeason;
-    }
-    if(!is.null(initialX)){
-        initialValue$xreg <- initialX;
+    # If the initial is provided in the old school style
+    if(!is.list(initial)){
+        # Prepare initials if they are numeric
+        initialValue <- vector("list",(!is.null(initial))*1 +(!is.null(initialSeason))*1 +(!is.null(initialX))*1);
+        names(initialValue) <- c("level","seasonal","xreg")[c(!is.null(initial),!is.null(initialSeason),!is.null(initialX))];
+        if(is.numeric(initial)){
+            initialValue <- switch(length(initial),
+                                   "1"=list(level=initial[1]),
+                                   "2"=list(level=initial[1],
+                                            trend=initial[2]));
+        }
+        if(!is.null(initialSeason)){
+            initialValue$seasonal <- initialSeason;
+        }
+        if(!is.null(initialX)){
+            initialValue$xreg <- initialX;
+        }
+        if(length(initialValue)==1 && is.null(initialValue$level)){
+            initialValue <- initial;
+        }
     }
-    if(length(initialValue)==1 && is.null(initialValue$level)){
+    else{
         initialValue <- initial;
     }