Merge pull request #219 from config-i1/master

Making the branch up-to-date.
config-i1 · Apr 29, 2024 · cb87118 · cb87118
2 parents 9e86476 + 44bf5fe
commit cb87118
Show file tree

Hide file tree

Showing 29 changed files with 199 additions and 129 deletions.
diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml
@@ -3,90 +3,56 @@ name: R-CMD-check
 on:
   pull_request:
   workflow_dispatch:
-  release:
   schedule:
-    - cron:  '0 0 * * 1'
+   - cron:  '0 0 * * 1'
 
 jobs:
   R-CMD-check:
     runs-on: ${{ matrix.config.os }}
+
     name: ${{ matrix.config.os }} (${{ matrix.config.r }})
 
     strategy:
       fail-fast: false
       matrix:
         config:
+          - {os: macos-latest,   r: 'release'}
           - {os: windows-latest, r: 'release'}
-          - {os: macOS-latest, r: 'release'}
-          - {os: ubuntu-20.04, r: 'release', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"}
-          # - {os: ubuntu-20.04, r: 'oldrel', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"}
-          # - {os: ubuntu-20.04, r: '3.6', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"}
-          # - {os: ubuntu-20.04, r: 'devel', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest", http-user-agent: "R/4.1.0 (ubuntu-20.04) R (4.1.0 x86_64-pc-linux-gnu x86_64 linux-gnu) on GitHub Actions"}
+          #- {os: ubuntu-latest,   r: 'devel', http-user-agent: 'release'}
+          - {os: ubuntu-latest,   r: 'release'}
+          #- {os: ubuntu-latest,   r: 'oldrel-1'}
 
     env:
-      R_REMOTES_NO_ERRORS_FROM_WARNINGS: true
-      RSPM: ${{ matrix.config.rspm }}
       GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
+      R_KEEP_PKG_SOURCE: yes
 
     steps:
-      - name: Check out repository code
-        uses: actions/checkout@v2
+      - uses: actions/checkout@v4
+
+      - uses: r-lib/actions/setup-pandoc@v2
 
-      - name: Setup R (${{ matrix.config.r }})
-        uses: r-lib/actions/setup-r@v2
+      - uses: r-lib/actions/setup-r@v2
         with:
           r-version: ${{ matrix.config.r }}
           http-user-agent: ${{ matrix.config.http-user-agent }}
+          use-public-rspm: true
 
-      - name: Setup Pandoc
-        uses: r-lib/actions/setup-pandoc@v2
-
-      - name: Query dependencies
-        run: |
-          install.packages('remotes')
-          saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2)
-          writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version")
-        shell: Rscript {0}
-
-      - name: Restore R package cache
-        uses: actions/cache@v2
+      - uses: r-lib/actions/setup-r-dependencies@v2
         with:
-          path: ${{ env.R_LIBS_USER }}
-          key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }}
-          restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-
-
-      - name: Install dependencies
-        run: |
-          remotes::install_deps(dependencies = TRUE)
-          remotes::install_cran("rcmdcheck")
-        shell: Rscript {0}
-
-      - name: Install greybox from repo (devel only)
-        if: ${{ matrix.config.r == 'devel' }}
-        run: |
-          remotes::install_github("config-i1/greybox")
-        shell: Rscript {0}
-
-      - name: Session info
-        run: |
-          options(width = 100)
-          pkgs <- installed.packages()[, "Package"]
-          sessioninfo::session_info(pkgs, include_base = TRUE)
-        shell: Rscript {0}
-
-      - name: Check
-        env:
-          _R_CHECK_CRAN_INCOMING_REMOTE_: false
-          _R_CHECK_FORCE_SUGGESTS_: false
-        run: |
-          options(crayon.enabled = TRUE)
-          rcmdcheck::rcmdcheck(args = c("--no-manual", "--as-cran"), error_on = "warning", check_dir = "check")
-        shell: Rscript {0}
-
-      - name: Upload check results
-        if: failure()
-        uses: actions/upload-artifact@main
+          # Don't check suggests to avoid Windows issues with doMC
+          dependencies: '"hard"'
+          cache: false
+          extra-packages: |
+            any::rcmdcheck
+            any::testthat
+            any::knitr
+            any::rmarkdown
+            any::numDeriv
+            any::doParallel
+            any::foreach
+          needs: check
+
+      - uses: r-lib/actions/check-r-package@v2
         with:
-          name: ${{ runner.os }}-r${{ matrix.config.r }}-results
-          path: check
-
+          upload-snapshots: true
+          build_args: 'c("--no-manual","--compact-vignettes=gs+qpdf")'
diff --git a/CRAN-SUBMISSION b/CRAN-SUBMISSION
@@ -1,3 +1,3 @@
-Version: 4.0.0
-Date: 2023-09-16 10:25:42 UTC
-SHA: 93d2e3fa4bded6ac4faee02dd50694428bb1fac6
+Version: 4.0.1
+Date: 2024-04-01 13:00:09 UTC
+SHA: 2f43e562cd69285390b7a76aa420961b97bd8fcc
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,9 +1,9 @@
 Package: smooth
 Type: Package
 Title: Forecasting Using State Space Models
-Version: 4.0.1.41013
-Date: 2023-11-13
-Authors@R: person("Ivan", "Svetunkov", email = "ivan@svetunkov.ru", role = c("aut", "cre"),
+Version: 4.0.2.41003
+Date: 2024-04-11
+Authors@R: person("Ivan", "Svetunkov", email = "ivan@svetunkov.com", role = c("aut", "cre"),
                   comment="Lecturer at Centre for Marketing Analytics and Forecasting, Lancaster University, UK")
 URL: https://github.com/config-i1/smooth
 BugReports: https://github.com/config-i1/smooth/issues
@@ -44,7 +44,7 @@ Suggests:
     doParallel,
     foreach
 VignetteBuilder: knitr
-RoxygenNote: 7.2.3
+RoxygenNote: 7.3.1
 Encoding: UTF-8
 Roxygen: list(old_usage = TRUE)
 ByteCompile: true
diff --git a/NAMESPACE b/NAMESPACE
@@ -116,6 +116,7 @@ S3method(rstandard,smooth)
 S3method(rstudent,adam)
 S3method(rstudent,smooth)
 S3method(sigma,adam)
+S3method(sigma,msdecompose)
 S3method(sigma,smooth)
 S3method(sigma,smooth.sim)
 S3method(simulate,adam)

diff --git a/NEWS b/NEWS
@@ -1,4 +1,15 @@
-smooth v4.0.1 (Release data: 2023-11-13)
+smooth v4.0.2 (Release data: 2024-04-05)
+=======
+
+Changes:
+* occurrence in adam() now accepts proportions. This might be useful if you know that you only have a share of demand that you usually get.
+* adam() now allows pure models with some specific components. e.g. model="PNP" will check pure additive and pure multiplicative models without trend. Similarly, model="FNF" will now remove the unneeded trends and skip the branch-and-bound algorithm.
+
+Bugfixes:
+* Transition matrix was not correctly set for ARIMA with drift. It is now.
+
+
+smooth v4.0.1 (Release data: 2024-04-01)
 =======
 
 Changes:
@@ -14,6 +25,7 @@ Bugfixes:
 * 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!
+* Another bugfix in es() and xreg: resolved the issue with the simulated data.
 
 
 smooth v4.0.0 (Release data: 2023-09-15)

diff --git a/R/adam-es.R b/R/adam-es.R
@@ -30,7 +30,7 @@
 #'
 #' Also, there are posts about the functions of the package smooth on the
 #' website of Ivan Svetunkov:
-#' \url{https://forecasting.svetunkov.ru/en/tag/smooth/} - they explain the
+#' \url{https://openforecast.org/category/r-en/smooth/} - they explain the
 #' underlying models and how to use the functions.
 #'
 #'
@@ -280,7 +280,7 @@ es <- function(y, model="ZZZ", lags=c(frequency(y)), persistence=NULL, phi=NULL,
             }
         }
         phi <- model$phi;
-        if(is.null(xreg) && !is.null(model$initial$xreg)){
+        if(is.null(xreg) && is.list(model$initial) && !is.null(model$initial$xreg)){
             # Exctract xreg
             xreg <- model$data[,all.vars(model$formula)[-1]];
         }

diff --git a/R/adam.R b/R/adam.R
@@ -77,6 +77,7 @@ utils::globalVariables(c("adamFitted","algorithm","arEstimate","arOrders","arReq
 #' @template ssAuthor
 #' @template ssKeywords
 #'
+#' @template smoothRef
 #' @template ssADAMRef
 #' @template ssGeneralRef
 #' @template ssIntermittentRef
@@ -240,7 +241,7 @@ utils::globalVariables(c("adamFitted","algorithm","arEstimate","arOrders","arReq
 #' procedure.
 #' @param bounds The type of bounds for the persistence to use in the model
 #' estimation. Can be either \code{admissible} - guaranteeing the stability of the
-#' model, \code{traditional} - restricting the values with (0, 1) or \code{none} - no
+#' model, \code{usual} - restricting the values with (0, 1) or \code{none} - no
 #' restrictions (potentially dangerous).
 #' @param regressors The variable defines what to do with the provided explanatory
 #' variables:
@@ -850,7 +851,7 @@ adam <- function(data, model="ZXZ", lags=c(frequency(data)), orders=list(ar=c(0)
         }
 
         # Modify transition to do drift
-        if(constantRequired){
+        if(!arimaModel && constantRequired){
             matF[1,ncol(matF)] <- 1;
         }
 
@@ -895,6 +896,7 @@ adam <- function(data, model="ZXZ", lags=c(frequency(data)), orders=list(ar=c(0)
             arimaPolynomials <- NULL;
         }
 
+
         if(!profilesRecentProvided){
             # ETS model, initial state
             # If something needs to be estimated...
@@ -3628,6 +3630,11 @@ adam <- function(data, model="ZXZ", lags=c(frequency(data)), orders=list(ar=c(0)
             yFitted[] <- yFitted * pFitted;
         }
 
+        # Fix the cases, when we have zeroes in the provided occurrence
+        if(occurrence=="provided"){
+            yFitted[!otLogical] <- yFitted[!otLogical] * pFitted[!otLogical];
+        }
+
         # Produce forecasts if the horizon is non-zero
         if(horizon>0){
             if(any(yClasses=="ts")){
@@ -3655,7 +3662,7 @@ adam <- function(data, model="ZXZ", lags=c(frequency(data)), orders=list(ar=c(0)
             if(occurrenceModel && !occurrenceModelProvided){
                 yForecast[] <- yForecast * c(suppressWarnings(forecast(oesModel, h=h))$mean);
             }
-            else if(occurrenceModel && occurrenceModelProvided){
+            else if((occurrenceModel && occurrenceModelProvided) || occurrence=="provided"){
                 yForecast[] <- yForecast * pForecast;
             }
         }
@@ -6654,7 +6661,8 @@ xtable.summary.adam <- function(x, caption = NULL, label = NULL, align = NULL, d
 
 #' @importFrom greybox coefbootstrap
 #' @export
-coefbootstrap.adam <- function(object, nsim=100, size=floor(0.5*nobs(object)),
+coefbootstrap.adam <- function(object, nsim=100,
+                               size=floor(0.5*nobs(object)),
                                replace=FALSE, prob=NULL, parallel=FALSE, ...){
 
     startTime <- Sys.time();

diff --git a/R/adamGeneral.R b/R/adamGeneral.R
@@ -4,7 +4,7 @@ parametersChecker <- function(data, model, lags, formulaToUse, orders, constant=
                               distribution=c("default","dnorm","dlaplace","dalaplace","ds","dgnorm",
                                              "dlnorm","dinvgauss","dgamma"),
                               loss, h, holdout, occurrence,
-                              ic=c("AICc","AIC","BIC","BICc"), bounds=c("traditional","usual","admissible","none"),
+                              ic=c("AICc","AIC","BIC","BICc"), bounds=c("usual","admissible","none"),
                               regressors, yName,
                               silent, modelDo, ParentEnvironment,
                               ellipsis, fast=FALSE){
@@ -219,9 +219,9 @@ parametersChecker <- function(data, model, lags, formulaToUse, orders, constant=
     if(!fast){
         # Deal with the list of models. Check what has been provided. Stop if there is a mistake.
         if(length(model)>1){
-            if(any(nchar(model)>4)){
+            if(any(nchar(model)>4) || any(nchar(model)<3)){
                 stop(paste0("You have defined strange model(s) in the pool: ",
-                            paste0(model[nchar(model)>4],collapse=",")),call.=FALSE);
+                            paste0(model[nchar(model)>4 | nchar(model)<3],collapse=",")),call.=FALSE);
             }
             else if(any(substr(model,1,1)!="A" & substr(model,1,1)!="M" & substr(model,1,1)!="C")){
                 stop(paste0("You have defined strange model(s) in the pool: ",
@@ -282,7 +282,8 @@ parametersChecker <- function(data, model, lags, formulaToUse, orders, constant=
         Stype <- substr(model,4,4);
         damped <- TRUE;
         if(substr(model,3,3)!="d"){
-            message(paste0("You have defined a strange model: ",model));
+            message(paste0("You have defined a strange model: ", model,
+                           ". Switching to ", paste0(Etype,Ttype,"d",Stype)));
             model <- paste0(Etype,Ttype,"d",Stype);
         }
     }
@@ -337,15 +338,51 @@ parametersChecker <- function(data, model, lags, formulaToUse, orders, constant=
                                 "MNN","MAN","MAdN","MMN","MMdN",
                                 "MNA","MAA","MAdA","MMA","MMdA",
                                 "MNM","MAM","MAdM","MMM","MMdM");
-                Etype[] <- Ttype[] <- Stype[] <- "Z";
+                # Remove models from pool if specific elements are provided
+                if(Etype!="F"){
+                    modelsPool <- modelsPool[substr(modelsPool,1,1)==Etype];
+                }
+                else{
+                    Etype[] <- "Z"
+                }
+                if(Ttype!="F"){
+                    modelsPool <- modelsPool[substr(modelsPool,2,2)==Ttype];
+                }
+                else{
+                    Ttype[] <- "Z"
+                }
+                if(Stype!="F"){
+                    modelsPool <- modelsPool[substr(modelsPool,nchar(modelsPool),nchar(modelsPool))==Stype];
+                }
+                else{
+                    Stype[] <- "Z"
+                }
                 model <- "FFF";
             }
 
             # The test for pure models only
             if(any(unlist(strsplit(model,""))=="P")){
                 modelsPool <- c("ANN","AAN","AAdN","ANA","AAA","AAdA",
                                 "MNN","MMN","MMdN","MNM","MMM","MMdM");
-                Etype[] <- Ttype[] <- Stype[] <- "Z";
+                # Remove models from pool if specific elements are provided
+                if(Etype!="P"){
+                    modelsPool <- modelsPool[substr(modelsPool,1,1)==Etype];
+                }
+                else{
+                    Etype[] <- "Z"
+                }
+                if(Ttype!="P"){
+                    modelsPool <- modelsPool[substr(modelsPool,2,2)==Ttype];
+                }
+                else{
+                    Ttype[] <- "Z"
+                }
+                if(Stype!="P"){
+                    modelsPool <- modelsPool[substr(modelsPool,nchar(modelsPool),nchar(modelsPool))==Stype];
+                }
+                else{
+                    Stype[] <- "Z"
+                }
                 model <- "PPP";
             }
         }
@@ -1071,6 +1108,11 @@ parametersChecker <- function(data, model, lags, formulaToUse, orders, constant=
     obsNonzero <- sum(ot);
     obsZero <- obsInSample - obsNonzero;
 
+    # If occurrence is provided, use it as is
+    if(occurrence=="provided"){
+        ot[] <- pFitted;
+    }
+
     # Check if multiplicative models can be fitted
     allowMultiplicative <- !((any(yInSample<=0) && !occurrenceModel) || (occurrenceModel && any(yInSample<0)));
 

diff --git a/R/autoadam.R b/R/autoadam.R
@@ -674,6 +674,13 @@ auto.adam <- function(data, model="ZXZ", lags=c(frequency(data)),
                 }
                 additionalModels <- additionalModels[modelsLeft,,drop=FALSE];
             }
+            # Form orders for ARIMA(1,1,2), SARIMA(1,1,2)(1,1,2) etc
+            # if(any(arMax!=0)){
+            #     arOrdersAdditional <- rep(1, ordersLength);
+            #     iOrdersAdditional <- rep(1, ordersLength);
+            #     maOrdersAdditional <- rep(2, ordersLength);
+            # }
+            # Check the additional models
             if(!is.null(additionalModels)){
                 # Save B from models to speed up calculation afterwards
                 BValues <- vector("list",iCombinations);

diff --git a/R/cma.R b/R/cma.R
@@ -6,7 +6,7 @@
 #' shifts it back in time. Otherwise an AR(order+1) model is constructed
 #' with the preset parameters:
 #'
-#' phi_i = {0.5,1,1,...,0.5} / order
+#' \deqn{phi_i = {0.5,1,1,...,0.5} / order}
 #'
 #' This then corresponds to the centered MA with 0.5 weight for the
 #' first observation and 0.5 weight for an additional one. e.g. if this is