tests/testthat/test-performance-guardrails.R

In neuroim2: Data Structures for Brain Imaging Data

context("performance guardrails")

library(neuroim2)

skip_if_perf_disabled <- function() {
  if (!identical(Sys.getenv("NEUROIM2_PERF"), "true")) {
    skip("Performance guardrails run only when NEUROIM2_PERF=true")
  }
}

old_sparse_subset_reference <- function(x, i, j, k, m, drop = TRUE) {
  grid_to_index3d <- get(".gridToIndex3D", envir = asNamespace("neuroim2"))
  vmat <- as.matrix(expand.grid(i, j, k))
  ind <- grid_to_index3d(dim(x)[1:3], vmat[, 1:3, drop = FALSE])
  mapped <- lookup(x, ind)
  keep <- mapped > 0
  dimout <- c(length(i), length(j), length(k), length(m))

  if (!any(keep)) {
    out0 <- array(0, dimout)
    return(if (drop) base::drop(out0) else out0)
  }

  out <- array(0, dimout)
  nz_idx <- which(keep)
  vals <- matricized_access(x, mapped[nz_idx])
  vals <- vals[m, , drop = FALSE]
  coords <- vmat[nz_idx, , drop = FALSE]
  ii_pos <- match(coords[, 1], i)
  jj_pos <- match(coords[, 2], j)
  kk_pos <- match(coords[, 3], k)
  for (col in seq_along(nz_idx)) {
    out[ii_pos[col], jj_pos[col], kk_pos[col], ] <- vals[, col]
  }

  if (drop) base::drop(out) else out
}

test_that("dense matrix series fast path beats scalar extraction", {
  skip_on_cran()
  skip_if_perf_disabled()

  set.seed(1)
  dims <- c(18, 18, 18, 40)
  x <- DenseNeuroVec(array(rnorm(prod(dims)), dim = dims), NeuroSpace(dims))
  coords <- cbind(
    sample.int(dims[1], 400, replace = TRUE),
    sample.int(dims[2], 400, replace = TRUE),
    sample.int(dims[3], 400, replace = TRUE)
  )

  fast_time <- system.time(replicate(
    10,
    series(x, coords),
    simplify = FALSE
  ))[["elapsed"]]

  ref_time <- system.time(replicate(
    10,
    vapply(
      seq_len(nrow(coords)),
      function(ii) series(x, coords[ii, 1], coords[ii, 2], coords[ii, 3]),
      numeric(dims[4])
    ),
    simplify = FALSE
  ))[["elapsed"]]

  expect_lt(fast_time, ref_time)
})

test_that("sparse subset path beats the old expand.grid implementation", {
  skip_on_cran()
  skip_if_perf_disabled()

  set.seed(1)
  dims <- c(24, 24, 16, 10)
  arr <- array(rnorm(prod(dims)), dim = dims)
  dense <- DenseNeuroVec(arr, NeuroSpace(dims))
  mask_arr <- array(runif(prod(dims[1:3])) > 0.92, dims[1:3])
  sparse <- as.sparse(dense, LogicalNeuroVol(mask_arr, drop_dim(space(dense))))
  i <- 3:18
  j <- 4:17
  k <- 2:11
  m <- 1:6

  fast_time <- system.time(replicate(
    20,
    sparse[i, j, k, m, drop = FALSE],
    simplify = FALSE
  ))[["elapsed"]]

  ref_time <- system.time(replicate(
    20,
    old_sparse_subset_reference(sparse, i, j, k, m, drop = FALSE),
    simplify = FALSE
  ))[["elapsed"]]

  expect_lt(fast_time, ref_time)
})