updates; working tests etc

DESCRIPTION

@@ -61,3 +61,16 @@ Config/Needs/dependencies:
 Config/Needs/coverage:
     covr
 VignetteBuilder: knitr
+Collate:
+    'check_input.R'
+    'check.R'
+    'datasets.R'
+    'decomposition.R'
+    'feat.R'
+    'forecastplot.R'
+    'iNZightTS-package.R'
+    'iNZightTS.R'
+    'model.R'
+    'rawplot.R'
+    'seasonplot.R'
+    'surrogate_test.R'

NAMESPACE

@@ -5,6 +5,9 @@ S3method(as_year,Date)
 S3method(as_year,character)
 S3method(as_year,numeric)
 S3method(as_year,vctrs_vctr)
+S3method(check,inz_ts)
+S3method(check,inzts_chk_fit)
+S3method(check,inzts_fit)
 S3method(get_model,"function")
 S3method(get_model,character)
 S3method(inzightts,character)
@@ -16,21 +19,23 @@ S3method(plot,inz_frct)
 S3method(plot,inz_ts)
 S3method(plot,inzts_fit)
 S3method(plot,seas_ts)
-S3method(plot,surrogate)
+S3method(plot,srgt_indep)
 S3method(predict,inz_ts)
+S3method(print,chk_input)
 S3method(print,inzts_fit)
+S3method(print,srgt_indep)
 S3method(print,summary_inz_frct)
-S3method(print,surrogate)
 S3method(seasonplot,inz_ts)
 S3method(summary,inz_frct)
 export(check)
 export(decomp)
 export(fit_model)
 export(ggplotable)
 export(inzightts)
+export(log_if)
 export(seasonplot)
 export(subseries)
-export(surrogate.test)
+export(surrogate_independence)
 import(ggplot2)
 import(grDevices)
 import(graphics)

R/check.R

@@ -0,0 +1,49 @@
+#' Check model assumptions
+#' @param x An object of class "inzts_fit"
+#' @param ... Additional arguments
+#' @return The object with the checked and transformed fit
+#' @export
+#' @md
+check <- function(x, ...) {
+    UseMethod("check", x)
+}
+
+#' @include check_input.R
+ts_checks <- list(
+    independence = list(
+        name = "Independence of residuals",
+        # test = surrogate.test,
+        args = c(
+            lag = chk_number(min = 1, integer = TRUE, default = 4),
+            R = chk_number(min = 100, max = 1e6, integer = TRUE, default = 1000),
+            test.stat = chk_enum(c("ljung-box", "box-pierce"))
+        )
+    )
+)
+
+#' @export
+check.inz_ts <- function(x, ...) {
+    if (attr(x, "checked")) {
+        return(x)
+    }
+
+    attr(x, "checked") <- TRUE
+    class(x) <- c("inzts_chk_ts", class(x))
+    x
+}
+
+#' @export
+check.inzts_fit <- function(x, ...) {
+    if (attr(x, "checked")) {
+        return(x)
+    }
+
+    attr(x, "checked") <- TRUE
+    class(x) <- c("inzts_chk_fit", class(x))
+    x
+}
+
+#' @export
+check.inzts_chk_fit <- function(x, ...) {
+    # re-check a model
+}

R/check_input.R

@@ -0,0 +1,43 @@
+chk_input <- function(type, constraints, fun) {
+    obj <- list(
+        type = type,
+        constraints = constraints,
+        fun = fun
+    )
+    class(obj) <- "chk_input"
+    obj
+}
+
+#' @export
+print.chk_input <- function(x, ...) {
+    cat(x$type)
+}
+
+chk_number <- function(min = NULL, max = NULL, integer = TRUE, default = NA) {
+    constraints <- list()
+    if (!is.null(min)) constraints$min <- c("Minimum value" = min)
+    if (!is.null(max)) constraints$max <- c("Maximum value" = max)
+    if (integer) constraints$integer <- c("Must be an integer" = TRUE)
+    chk_input(
+        "number", constraints,
+        function(x) {
+            if (!is.na(default)) if (missing(x)) {
+                return(default)
+            }
+            if (!is.null(min)) if (x < min) stop("Value must be", min, "or greater")
+            if (!is.null(max)) if (x > max) stop("Value must be", max, "or greater")
+            if (integer) if (!is.integer(x)) stop("Value must be an integer")
+            x
+        }
+    )
+}
+
+chk_enum <- function(options) {
+    chk_input(
+        "enum",
+        list(
+            "values" = options
+        ),
+        function(x) match.arg(x, options)
+    )
+}

R/forecastplot.R

@@ -1,3 +1,10 @@
+#' Conditional log transform
+#'
+#' @param x A numeric vector to be transformed.
+#' @param mult_fit Logical; set to `TRUE` for a multiplicative model, or `FALSE` for the additive model.
+#' @return A numeric vector.
+#' @md
+#' @export
 log_if <- fabletools::new_transformation(
     transformation = function(x, mult_fit) {
         if (mult_fit) log(x) else as.numeric(x)

R/model.R

@@ -59,17 +59,3 @@ plot.inzts_fit <- function(x, ...) {
 
     p
 }
-
-#' Check model assumptions
-#' @param x An object of class "inzts_fit"
-#' @return The object with the checked and transformed fit
-#' @export
-#' @md
-check <- function(x, ...) {
-    if (attr(x, "checked")) {
-        return(x)
-    }
-
-    attr(x, "checked") <- TRUE
-    x
-}

R/surrogate_test.R

@@ -4,6 +4,7 @@
 #' @param lag Number of lags in portmanteau test statistic.
 #' @param R Number of permutations to perform.
 #' @param test.stat Either "ljung-box" or "box-pierce".
+#' @param interactive Whether to prompt the user for input or just show warnings.
 #'
 #' @return An object of class "surrogate" containing the following components:'
 #' \itemize{
@@ -19,23 +20,24 @@
 #' plot(data, type = "l")
 #' acf(data)
 #' par(o)
-#' (s <- surrogate.test(data, lag = 10))
+#' (s <- surrogate_independence(data, lag = 10, interactive = FALSE))
 #' plot(s)
 #'
 #' data <- tsibble::tsibble(value = rnorm(256), Time = 1:256, index = Time)
 #' o <- par(mfrow = c(1, 2))
 #' plot(data$value, type = "l")
 #' acf(data$value)
 #' par(o)
-#' (s <- surrogate.test(data, lag = 8, R = 5000, test.stat = "box-pierce"))
+#' (s <- surrogate_independence(data, lag = 8, R = 5000, test.stat = "box-pierce"))
 #' plot(s)
 #'
 #' @export
-surrogate.test <- function(
+surrogate_independence <- function(
     data,
-    lag = 4,
+    lag = 10,
     R = 1000,
-    test.stat = c("ljung-box", "box-pierce")) {
+    test.stat = c("ljung-box", "box-pierce"),
+    interactive = base::interactive()) {
   test.stat <- match.arg(test.stat)
 
   if (tsibble::is_tsibble(data)) {
@@ -64,20 +66,56 @@ surrogate.test <- function(
   Q.obs <- Qobs(r.obs, n, lag)
   Q.null <- apply(r.null, 2L, Qobs, n = n, l = lag)
 
+  p.value <- mean(Q.null >= Q.obs)
+  ntail <- sum(Q.null >= Q.obs)
+
+  if (ntail < 10) {
+    if (!interactive) {
+      cli::cli_alert_warning("Fewer than 10 permutations in the tail")
+    } else {
+      res <- utils::menu(
+        c(
+          "Continue",
+          sprintf("Repeat with %d permutations", R * 10),
+          "Let me choose the number of permutations"
+        ),
+        title = "Fewer than 10 permutations in the tail"
+      )
+      if (res > 1) {
+        if (res == 2) {
+          R <- R * 10
+        } else {
+          R <- as.integer(readline(sprintf(
+            "Enter a new number of permutations: (current = %d) ",
+            R
+          )))
+        }
+        return(
+          surrogate_independence(data,
+            lag = lag,
+            R = R,
+            test.stat = test.stat,
+            interactive = interactive
+          )
+        )
+      }
+    }
+  }
+
   # Output
   output <- list(
     Q.null = Q.null,
     Q.obs = Q.obs,
     test.stat = test.stat,
-    p.value = mean(Q.null >= Q.obs)
+    p.value = p.value
   )
 
-  class(output) <- "surrogate"
+  class(output) <- "srgt_indep"
   output
 }
 
 #' @export
-print.surrogate <- function(x, ...) {
+print.srgt_indep <- function(x, ...) {
   cat("Surrogate test for independence\n")
   cat(x$test.stat, "test statistic: ", x$Q.obs, "\n")
   cat("p-value: ", x$p.value, "(based on", length(x$Q.null), "permutations)\n")
@@ -86,9 +124,10 @@ print.surrogate <- function(x, ...) {
 
 #' Plot surrogate null distribution and observed test statistic
 #' @param x Object of class "surrogate".
-#' @describeIn surrogate.test Plot method
+#' @param ... Additional arguments to pass to the plot function.
+#' @describeIn surrogate_independence Plot method
 #' @export
-plot.surrogate <- function(x, ...) {
+plot.srgt_indep <- function(x, ...) {
   # x: Object of class "surrogate"
 
   ggplot2::ggplot(
@@ -107,3 +146,7 @@ plot.surrogate <- function(x, ...) {
       y = "Count"
     )
 }
+
+surrogate_stationary <- function(data, ...) {
+
+}

docs/pkgdown.yml

@@ -3,7 +3,7 @@ pkgdown: 2.0.9
 pkgdown_sha: ~
 articles:
   model-checking: model-checking.html
-last_built: 2024-05-29T05:56Z
+last_built: 2024-05-31T01:45Z
 urls:
   reference: https://inzightvit.github.io/iNZightTS/reference
   article: https://inzightvit.github.io/iNZightTS/articles