tests/testthat/test-api-coverage.R

In fmriAR: Fast AR and ARMA Noise Whitening for Functional MRI (fMRI) Design and Data

test_that("fit_noise with Y/X matches precomputed residuals", {
  set.seed(42)
  n <- 160
  runs <- rep(1:2, each = n / 2)
  X <- cbind(1, rnorm(n))
  beta <- c(0.5, -0.2)
  eps <- as.numeric(stats::arima.sim(list(ar = 0.4), n = n))
  Y <- matrix(X %*% beta + eps, ncol = 1L)
  resid <- Y - X %*% qr.solve(X, Y)

  plan_resid <- fit_noise(resid = resid, runs = runs, method = "ar", p = "auto", p_max = 4)
  plan_yx    <- fit_noise(Y = Y, X = X, runs = runs, method = "ar", p = "auto", p_max = 4)

  expect_equal(plan_resid$order, plan_yx$order)
  expect_equal(plan_resid$phi, plan_yx$phi)
  expect_equal(plan_resid$theta, plan_yx$theta)
})

test_that("fit_noise ignores ms_mode when multiscale = FALSE", {
  set.seed(9)
  n <- 120
  v <- 20
  X <- cbind(1, rnorm(n))
  Y <- matrix(rnorm(n * v), n, v)
  resid <- Y - X %*% qr.solve(X, Y)
  parcels <- rep(1:5, length.out = v)

  plan_plain <- fit_noise(resid, pooling = "parcel", parcels = parcels,
                          method = "ar", p = 2L)
  plan_off   <- fit_noise(resid, pooling = "parcel", parcels = parcels,
                          method = "ar", p = 2L,
                          multiscale = FALSE, ms_mode = "acvf_pooled")

  out_plain <- whiten_apply(plan_plain, X, Y, parcels = parcels, parallel = FALSE)
  out_off   <- whiten_apply(plan_off, X, Y, parcels = parcels, parallel = FALSE)

  expect_equal(out_plain$Y, out_off$Y)
})

test_that("whiten_apply honors run_starts input", {
  set.seed(7)
  n1 <- 60
  n2 <- 80
  phi1 <- 0.5
  phi2 <- -0.2
  y1 <- as.numeric(stats::filter(rnorm(n1), filter = phi1, method = "recursive"))
  y2 <- as.numeric(stats::filter(rnorm(n2), filter = phi2, method = "recursive"))
  Y <- rbind(matrix(y1, ncol = 1L), matrix(y2, ncol = 1L))
  X <- matrix(1, nrow(Y), 1L)

  plan <- fmriAR:::new_whiten_plan(
    phi = list(phi1, phi2),
    theta = list(numeric(0), numeric(0)),
    order = c(p = 1L, q = 0L),
    runs = NULL,
    exact_first = FALSE,
    method = "ar",
    pooling = "run"
  )

  out_runs <- whiten_apply(plan, X, Y, runs = c(rep(1L, n1), rep(2L, n2)), parallel = FALSE)
  out_starts <- whiten_apply(plan, X, Y, run_starts = c(0L, n1), parallel = FALSE)

  expect_equal(out_runs$Y, out_starts$Y)
  expect_equal(out_runs$X, out_starts$X)
})

test_that("whiten_apply inplace modifies matrices", {
  set.seed(12)
  n <- 90
  phi <- 0.4
  y <- as.numeric(stats::filter(rnorm(n), filter = phi, method = "recursive"))
  Y <- matrix(y, ncol = 1L)
  X <- matrix(1, n, 1L)
  plan <- fmriAR:::new_whiten_plan(
    phi = list(phi),
    theta = list(numeric(0)),
    order = c(p = 1L, q = 0L),
    runs = NULL,
    exact_first = FALSE,
    method = "ar",
    pooling = "global"
  )
  Y_ref <- Y
  X_ref <- X
  res_inplace <- whiten_apply(plan, X, Y, inplace = TRUE, parallel = FALSE)
  res_regular <- whiten_apply(plan, X_ref, Y_ref, parallel = FALSE)

  expect_equal(res_inplace$Y, res_regular$Y)
  expect_equal(res_inplace$X, res_regular$X)
})

test_that("global pooling averages run-level coefficients", {
  set.seed(23)
  n1 <- 400
  n2 <- 600
  phi1 <- 0.3
  phi2 <- 0.7
  y1 <- as.numeric(stats::filter(rnorm(n1), filter = phi1, method = "recursive"))
  y2 <- as.numeric(stats::filter(rnorm(n2), filter = phi2, method = "recursive"))
  resid <- rbind(cbind(y1, y1), cbind(y2, y2))
  runs <- c(rep(1L, n1), rep(2L, n2))

  plan <- fit_noise(resid = resid, runs = runs, pooling = "global",
                    method = "ar", p = 1L)
  if (plan$order[["p"]] == 0L) testthat::skip("Estimated AR order was zero")
  phi_hat <- plan$phi[[1]][1]
  expected <- (n1 * phi1 + n2 * phi2) / (n1 + n2)
  expect_equal(phi_hat, expected, tolerance = 0.05)
})

test_that("multiscale acvf_pooled combines parcel scales", {
  set.seed(19)
  n <- 300
  v <- 96
  parcels_coarse <- rep(1:4, each = v / 4)
  parcels_medium <- rep(1:8, each = v / 8)
  parcels_fine <- rep(1:16, each = v / 16)

  phi_coarse <- runif(4, 0.3, 0.7)
  phi_vox <- phi_coarse[parcels_coarse] + rnorm(v, 0, 0.04)

  noise <- matrix(rnorm(n * v), n, v)
  Y <- noise
  for (j in seq_len(v)) {
    for (t in 2:n) {
      Y[t, j] <- phi_vox[j] * Y[t - 1, j] + noise[t, j]
    }
  }
  X <- cbind(1, rnorm(n))
  resid <- Y - X %*% qr.solve(X, Y)

  plan_fine <- fit_noise(resid, pooling = "parcel", parcels = parcels_fine,
                         method = "ar", p = "auto", p_max = 4)
  plan_ms <- fit_noise(resid, pooling = "parcel", parcels = parcels_fine,
                       parcel_sets = list(coarse = parcels_coarse,
                                          medium = parcels_medium,
                                          fine = parcels_fine),
                       method = "ar", p = "auto", p_max = 4,
                       multiscale = TRUE, ms_mode = "acvf_pooled")

  expect_equal(plan_ms$order[["p"]], plan_fine$order[["p"]])
  expect_true(any(abs(unlist(plan_ms$phi_by_parcel) - unlist(plan_fine$phi_by_parcel)) > 1e-6))

  out_ms <- whiten_apply(plan_ms, X, Y, parcels = parcels_fine, parallel = FALSE)
  expect_equal(dim(out_ms$Y), dim(Y))
})

test_that("parcel means handles NA removal", {
  set.seed(33)
  resid <- matrix(rnorm(30), nrow = 5)
  resid[2, 3] <- NA_real_
  parcels <- c(1, 1, 2, 2, 3, 3)

  fast <- fmriAR:::`.parcel_means`(resid, parcels, na.rm = TRUE)
  manual <- matrix(0, nrow = 5, ncol = 3)
  manual[, 1] <- rowMeans(resid[, 1:2], na.rm = TRUE)
  manual[, 2] <- rowMeans(resid[, 3:4], na.rm = TRUE)
  manual[, 3] <- rowMeans(resid[, 5:6], na.rm = TRUE)
  colnames(manual) <- colnames(fast)

  expect_equal(fast, manual)
})

test_that("segmented_acvf supports unbiased and no-centering", {
  y <- c(1, 3, 5, 7)
  rs0 <- 0L
  g_biased <- fmriAR:::`.segment_acvf`(y, rs0, lag_max = 2L, unbiased = FALSE, center = FALSE)
  g_unbiased <- fmriAR:::`.segment_acvf`(y, rs0, lag_max = 2L, unbiased = TRUE, center = FALSE)

  expect_equal(g_biased[1], mean(y^2))
  expect_equal(g_unbiased[2], sum(y[-1] * y[-length(y)]) / (length(y) - 1))
})

test_that("whiten() matches fit_noise + whiten_apply", {
  set.seed(27)
  n <- 180
  runs <- rep(1:3, each = 60)
  X <- cbind(1, rnorm(n))
  beta <- c(0.2, 0.5)
  eps <- as.numeric(stats::arima.sim(list(ar = 0.3), n = n))
  Y <- matrix(X %*% beta + eps, ncol = 1L)

  plan <- fit_noise(resid = Y - X %*% qr.solve(X, Y), runs = runs,
                    method = "ar", p = "auto", p_max = 4)
  manual <- whiten_apply(plan, X, Y, runs = runs, parallel = FALSE)
  shortcut <- whiten(X, Y, runs = runs, method = "ar", p = "auto", p_max = 4)

  expect_equal(manual$X, shortcut$X)
  expect_equal(manual$Y, shortcut$Y)
})

test_that("compat plan_info exposes parcel coefficients", {
  set.seed(101)
  n <- 160
  v <- 40
  parcels <- rep(1:8, each = v / 8)
  X <- cbind(1, rnorm(n))
  Y <- matrix(rnorm(n * v), n, v)
  resid <- Y - X %*% qr.solve(X, Y)

  plan <- fit_noise(resid, pooling = "parcel", parcels = parcels,
                    method = "ar", p = 2L, p_max = 4)
  info <- fmriAR:::compat$plan_info(plan)

  expect_true(!is.null(info$phi_by_parcel))
  expect_equal(dim(info$phi_by_parcel), c(plan$order[["p"]], length(unique(parcels))))
})

test_that("compat plan_info omits parcel coefficients for global plans", {
  set.seed(55)
  resid <- matrix(rnorm(200), nrow = 100, ncol = 2)
  plan <- fit_noise(resid, method = "ar", p = 1L, pooling = "global")
  info <- fmriAR:::compat$plan_info(plan)
  expect_true(is.null(info$phi_by_parcel))
})