small fixes

Author: alexiosg

DESCRIPTION

@@ -18,4 +18,5 @@ Encoding: UTF-8
 RoxygenNote: 7.3.2
 VignetteBuilder: knitr
 LazyData: true
+URL: https://github.com/tsmodels/tsissm
 Config/testthat/edition: 3

R/backtest.R

@@ -82,6 +82,11 @@ tsbacktest.tsissm.spec <- function(object, start = floor(length(object$target$y_
 {
     parameter <- b <- forecast_dates <- NULL
     data <- xts(object$target$y_orig, object$target$index)
+    
+    if (start > NROW(data)) stop("\nstart is greater than length of data")
+    if (end > NROW(data)) stop("\nend is greater than length of data")
+    
+    
     if (object$xreg$include_xreg) {
         use_xreg <- TRUE
         xreg <- xts(object$xreg$xreg, object$target$index)

R/estimation.R

@@ -69,6 +69,7 @@ estimate.tsissm.spec <- function(object, control = issm_control(algorithm = "SLS
         f$tmb <- opt$tmb
         f$opt <- opt$solver_out
     }
+    f$status <- opt$solver_out$status
     f$score_promise <- opt$scores
     f$elapsed <- difftime(Sys.time(), tic, units = "mins")
     f$hessian <- opt$hessian

R/hresiduals.R

@@ -9,14 +9,15 @@ hresiduals_issm <- function(object,  h = 12, nsim = 1000, start = 1, transformed
         y <- c(0, object$spec$target$y)
         actual <- y[(start + 1):(start + h)]
     } else {
-        y <- object$spec$target$y_orig
+        y <- c(0, object$spec$target$y_orig)
         actual <- y[(start + 1):(start + h)]
     }
     xseed <- object$model$states[start, ,drop = FALSE]
     if (!object$spec$xreg$include_xreg) {
         xreg = matrix(0, ncol = 1, nrow = h)
     } else {
-        xreg <- object$spec$xreg$x[(start + 1):(start + h)]
+        m <- NCOL(object$spec$xreg$xreg)
+        xreg <- rbind(matrix(0, ncol = m, nrow = 1), object$spec$xreg$xreg)[(start + 1):(start + h), ,drop = FALSE]
     }
     forecast_mu <- tsmoments.tsissm.estimate(object, h = h, newxreg = xreg, init_states = xseed, transform = !transformed)$mean
     e <- actual - forecast_mu

R/simulation.R

@@ -113,7 +113,7 @@ simulate.tsissm.estimate <- function(object, nsim = 1, seed = NULL, h = 1, newxr
             colnames(newxreg) <- colnames(object$spec$xreg$xreg)
         }
     }
-    newxreg <- rbind(matrix(0, ncol = ncol(newxreg), nrow = 1), newxreg)
+    newxreg <- rbind(matrix(0, ncol = ncol(newxreg), nrow = 1), coredata(newxreg))
 
     res <- object$model$error[-1]
     sigma_res <- object$model$sigma
@@ -236,7 +236,7 @@ simulate.tsissm.estimate <- function(object, nsim = 1, seed = NULL, h = 1, newxr
             colnames(newxreg) <- colnames(object$spec$xreg$xreg)
         }
     }
-    newxreg <- rbind(matrix(0, ncol = ncol(newxreg), nrow = 1), newxreg)
+    newxreg <- rbind(matrix(0, ncol = ncol(newxreg), nrow = 1), coredata(newxreg))
 
     res <- object$model$error
     garch_sigma <- object$model$sigma

R/specification.R

@@ -505,10 +505,11 @@ init_res <- function(y, spec) {
         } else {
             B <- box_cox(lambda = lambda)
             yt <- B$transform(y, frequency = seasonal_frequency)
-            res <- try(residuals(arima(yt, order = c(1,1,2), seasonal = list(order = c(1, 1, 1), period = seasonal_frequency))), silent = TRUE)
+            if (seasonal_frequency > 1) slist <- c(0,0,0) else slist <- c(1,1,1)
+            res <- try(residuals(arima(yt, order = c(1,1,2), seasonal = list(order = slist, period = seasonal_frequency))), silent = TRUE)
         }
         if (inherits(res,'try-error')) {
-            res <- residuals(tslinear(yt, trend = TRUE, seasonal = TRUE, frequency = seasonal_frequency))
+            res <- residuals(tslinear(yt, trend = TRUE, seasonal = ifelse(seasonal_frequency>1, TRUE, FALSE), frequency = seasonal_frequency))
         }
     }
     res <- as.numeric(res)
@@ -682,4 +683,4 @@ check_variance <- function(variance) {
         variance <- "constant"
     }
     return(variance)
-}
+}

R/tsprofile.R

@@ -60,7 +60,7 @@ profile_fun <- function(sim, object, h, control, trace)
         if (inherits(mod, 'try-error')) {
             return(list(L1 = NULL, L2 = NULL, L3 = NULL))
         }
-        if (mod$opt$status < 0) {
+        if (mod$status < 0) {
             return(list(L1 = NULL, L2 = NULL, L3 = NULL))
         }
         p <- predict(mod, h = h)

man/tsissm-package.Rd

@@ -0,0 +1,29 @@
+test_that("backtest", {
+    data("spy", package = "tsissm")
+    y <- as.xts(spy)
+    xreg <- auto_regressors(y["2014/"], frequency = 1, lambda = 0, sampling = "days", method = "full",
+                            check.rank = TRUE, discard.cval = 3.5, maxit.iloop = 10, maxit.oloop = 10, types = "LS")
+    exc <- which(xreg$xreg["2020-02-03"] == 1)
+    xreg$xreg <- xreg$xreg[,-exc]
+    xreg$init <- xreg$init[-exc]
+    spec_dynamic <- issm_modelspec(y["2014/"], slope = TRUE, seasonal = FALSE, ar = 1, ma = 0, xreg = xreg$xreg,
+                                   lambda = 0, variance = "dynamic", distribution = "jsu")
+    b <- tsbacktest(spec_dynamic, start = 2000, end = 2327, rolling = TRUE, h = 1, estimate_every = 30, trace = FALSE, seed = 100)
+    expect_s3_class(b, "tsissm.backtest")
+})
+
+test_that("profile", {
+    data("spy", package = "tsissm")
+    y <- as.xts(spy)
+    xreg <- auto_regressors(y["2014/"], frequency = 1, lambda = 0, sampling = "days", method = "full",
+                            check.rank = TRUE, discard.cval = 3.5, maxit.iloop = 10, maxit.oloop = 10, types = "LS")
+    exc <- which(xreg$xreg["2020-02-03"] == 1)
+    xreg$xreg <- xreg$xreg[,-exc]
+    xreg$init <- xreg$init[-exc]
+    spec_dynamic <- issm_modelspec(y["2014/"], slope = TRUE, seasonal = FALSE, ar = 1, ma = 0, xreg = xreg$xreg,
+                                   lambda = 0, variance = "dynamic", distribution = "jsu")
+    mod <- estimate(spec_dynamic)
+    p <- tsprofile(mod, h = 10, nsim = 100, seed = 100)
+    expect_s3_class(p, "tsissm.profile")
+})
+    

tests/longtests/test-backtest.R

@@ -0,0 +1,9 @@
+test_that("hresiduals", {
+    hr <- hresiduals(mod_dynamic_benchmark, h = 3, transformed = TRUE, index_start = 0)
+    rr <- residuals(mod_dynamic_benchmark, transformed = TRUE)
+    z1 <- as.numeric(hr$`1`)
+    z2 <- as.numeric(rr)
+    expect_equal(z1, z2, tolerance = 1e-8)
+})
+
+