more eg code

DESCRIPTION

@@ -17,26 +17,27 @@ Imports:
     cli,
     colorspace,
     dplyr (>= 1.1.0),
+    evaluate,
+    fable,
+    fabletools,
+    feasts,
     forcats,
+    fpp3,
     ggplot2,
     ggtext,
     glue,
     graphics,
     grDevices,
     grid,
+    lubridate,
     patchwork,
     rlang,
     stats,
+    tibble,
     tidyr,
-    utils,
     tsibble,
-    fable,
-    fabletools,
-    feasts,
-    evaluate,
-    lubridate,
+    utils,
     stringr,
-    tibble,
     urca
 Suggests:
     covr,

NAMESPACE

@@ -1,6 +1,12 @@
 # Generated by roxygen2: do not edit by hand
 
 S3method(.decomp,use_stl)
+S3method(as_year,Date)
+S3method(as_year,character)
+S3method(as_year,numeric)
+S3method(as_year,vctrs_vctr)
+S3method(get_model,"function")
+S3method(get_model,character)
 S3method(inzightts,character)
 S3method(inzightts,data.frame)
 S3method(inzightts,tbl_ts)
@@ -10,18 +16,21 @@ S3method(plot,inz_frct)
 S3method(plot,inz_ts)
 S3method(plot,inzts_fit)
 S3method(plot,seas_ts)
+S3method(plot,surrogate)
 S3method(predict,inz_ts)
 S3method(print,inzts_fit)
 S3method(print,summary_inz_frct)
 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)
 import(ggplot2)
 import(grDevices)
 import(graphics)

R/decomposition.R

@@ -182,7 +182,7 @@ as_year <- function(x) {
     UseMethod("as_year")
 }
 
-
+#' @export
 as_year.vctrs_vctr <- function(x) {
     1970 + as.numeric(x) / dplyr::case_when(
         inherits(x, "yearmonth") ~ 12,
@@ -192,15 +192,15 @@ as_year.vctrs_vctr <- function(x) {
     )
 }
 
-
+#' @export
 as_year.Date <- function(x) {
     1970 + as.numeric(x) / 365.25
 }
 
-
+#' @export
 as_year.numeric <- function(x) x
 
-
+#' @export
 as_year.character <- function(x) as.numeric(x)
 
 

R/forecastplot.R

@@ -30,15 +30,14 @@ log_if <- fabletools::new_transformation(
     }
 )
 
-
 get_model <- function(x) {
     UseMethod("get_model")
 }
 
-
+#' @export
 get_model.function <- function(x) x
 
-
+#' @export
 get_model.character <- function(x) {
     if (tolower(x) == "auto") {
         ARIMA_lite

R/model.R

@@ -51,8 +51,12 @@ plot.inzts_fit <- function(x, ...) {
     p
 }
 
+#' @export
 check <- function(x, ...) {
     if (attr(x, "checked")) {
         return(x)
     }
+
+    attr(x, "checked") <- TRUE
+    x
 }

R/surrogate_test.R

@@ -0,0 +1,83 @@
+#' Surrogate test for independence
+#' @export
+surrogate.test <- function(data, lag, N = 1000, test.stat = "ljung-box") {
+  # data: a tsibble or numeric vector object
+  # lag: number of lags in portmanteau test statistic
+  # N: number of permutations to perform
+  # test.stat: either "ljung-box" or "box-pierce"
+
+  if (tsibble::is_tsibble(data)) {
+    if (length(tsibble::measures(data)) != 1) {
+      stop("data must be a tsibble with one measurement variable")
+    }
+    # Extract time series
+    data <- data %>%
+      dplyr::pull(as.character(tsibble::measures(data)[[1]]))
+  }
+
+  n <- length(data)
+
+  Q.null <- rep(NA, N) # Open test statistic vectors
+
+  if (test.stat == "ljung-box") {
+    # Observed test statistic
+    r.obs <- acf(data, plot = FALSE)$acf[2:(lag + 1)]
+    Q.obs <- n * (n + 2) * sum(r.obs^2 / (n - 1:lag))
+
+    # Null distribution
+    for (i in 1:N) {
+      surrogate <- sample(data, n) # Permute data (kill autocorrelation, maintain amplitude)
+      r <- acf(surrogate, plot = FALSE)$acf[2:(lag + 1)] # Estimate autocorrelation
+      Q.null[i] <- n * (n + 2) * sum(r^2 / (n - 1:lag)) # Ljung-Box test statistic
+    }
+  }
+
+  if (test.stat == "box-pierce") {
+    # Observed test statistic
+    r.obs <- acf(data, plot = FALSE)$acf[2:(lag + 1)]
+    Q.obs <- n * sum(r.obs^2)
+
+    # Null distribution
+    for (i in 1:N) {
+      surrogate <- sample(data, n) # Permute data (kill autocorrelation, maintain amplitude)
+      r <- acf(surrogate, plot = FALSE)$acf[2:(lag + 1)] # Estimate autocorrelation
+      Q.null[i] <- n * sum(r^2) # Box-Pierce test statistic
+    }
+  }
+
+  # Compute p-value
+  p.value <- mean(Q.null >= Q.obs) # p-value
+
+  # Output
+  output <- list(
+    Q.null = Q.null,
+    Q.obs = Q.obs,
+    test.stat = test.stat,
+    p.value = p.value
+  )
+
+  class(output) <- "surrogate"
+
+  return(output)
+}
+
+
+# Function to plot surrogate null distribution and observed test statistic
+#' @export
+plot.surrogate <- function(x, ...) {
+  # x: Object of class "surrogate"
+
+  ggplot2::ggplot(
+    data = data.frame(Q = x$Q.null),
+    mapping = ggplot2::aes(x = Q)
+  ) +
+    ggplot2::geom_histogram(fill = "navy", colour = "black") +
+    ggplot2::geom_vline(
+      xintercept = x$Q.obs,
+      linetype = "dashed"
+    ) +
+    ggplot2::labs(
+      x = "Test statistic",
+      y = "Count"
+    )
+}

docs/pkgdown.yml

@@ -3,7 +3,7 @@ pkgdown: 2.0.9
 pkgdown_sha: ~
 articles:
   model-checking: model-checking.html
-last_built: 2024-05-24T04:01Z
+last_built: 2024-05-27T03:34Z
 urls:
   reference: https://inzightvit.github.io/iNZightTS/reference
   article: https://inzightvit.github.io/iNZightTS/articles

docs/sitemap.xml

@@ -54,6 +54,9 @@
   <url>
     <loc>https://inzightvit.github.io/iNZightTS/reference/subseries.html</loc>
   </url>
+  <url>
+    <loc>https://inzightvit.github.io/iNZightTS/reference/surrogate.test.html</loc>
+  </url>
   <url>
     <loc>https://inzightvit.github.io/iNZightTS/reference/visitorsA2.html</loc>
   </url>