tests/testthat/test-fixed-bugs.R

In rcicr: Reverse-Correlation Image-Classification Toolbox

# Regression tests for bugs that HAVE been fixed.
#
# These began life in test-known-bugs.R as deliberately failing tests - the
# executable form of the P0 bug list from the modernization. Every one now passes,
# so the file was renamed: its job from here on is to stop these bugs coming
# back.
#
# Each test asserts intended behaviour, never the buggy output it replaced.
# Do not "fix" a failure here by asserting the broken result - that locks the
# bug back in. A failure means a regression.

test_that("generateStimuli2IFC saves nscales and sigma in the .Rdata file", {
  # Issue #81. Because nscales is not saved,
  # generateReferenceDistribution2IFC() silently rebuilds the InfoVal null
  # distribution on the default nscales=5 basis, so InfoVal values reported
  # from non-default nscales are computed against the wrong distribution.
  tmp <- withr::local_tempdir()
  rdata_path <- make_fixture_rdata(tmp, img_size = 32, n_trials = 6, nscales = 1, seed = 1)

  e <- new.env()
  load(rdata_path, envir = e)

  expect_true("nscales" %in% ls(e))
  expect_equal(e$nscales, 1)
  expect_true("sigma" %in% ls(e))
})

test_that("computeInfoVal2IFC(force_gen_ref_dist = TRUE) regenerates the reference distribution", {
  # Issue #113. The flag short-circuits the lookup-table
  # branch but never reaches the regeneration branch, because reference_norms
  # still exists() after load(). The user is given no indication it was ignored.
  tmp <- withr::local_tempdir()
  rdata_path <- make_fixture_rdata(tmp, img_size = 32, n_trials = 6, nscales = 1, seed = 1)
  seed_reference_norms(rdata_path, n = 5, seed = 1)

  testthat::local_mocked_bindings(detectCores = function(...) 2L, .package = "parallel")

  e <- new.env()
  load(rdata_path, envir = e)
  before <- e$reference_norms

  target_ci <- list(ci = matrix(withr::with_seed(2, rnorm(32 * 32)), 32, 32))
  suppressWarnings(invisible(utils::capture.output(
    computeInfoVal2IFC(target_ci, rdata_path, iter = 3, force_gen_ref_dist = TRUE)
  )))

  e2 <- new.env()
  load(rdata_path, envir = e2)
  expect_false(identical(before, e2$reference_norms))
})

test_that("generateCI accepts tibble columns as well as data.frame columns", {
  # Issues #70 and #123. tbl[, "col"] stays a 1-column tibble # nolint: commented_code_linter.
  # where df[, "col"] drops to a vector, so aggregate() fails with
  # "arguments must have same length". Since readr/dplyr return tibbles by
  # default this is now the normal path for a modern user.
  tmp <- withr::local_tempdir()
  rdata_path <- make_fixture_rdata(tmp, img_size = 32, n_trials = 6, nscales = 1, seed = 1)

  set.seed(1)
  tb <- tibble::tibble(stimulus = 1:6, response = sample(c(1, -1), 6, replace = TRUE))

  ci <- generateCI(
    stimuli = tb[, "stimulus"], responses = tb[, "response"],
    baseimage = "base", rdata = rdata_path, save_as_png = FALSE
  )

  expect_equal(dim(ci$ci), c(32, 32))
  expect_false(anyNA(ci$ci))
})

test_that("generateCI applies a matrix mask", {
  # No issue filed. generateCI() branches on
  # `if (!is.na(mask))`, which gets a matrix condition - a hard error since
  # R 4.2. A second bug sits behind it: applyMask() checks a hardcoded 512
  # rather than img_size, so masks fail for any other stimulus size.
  tmp <- withr::local_tempdir()
  rdata_path <- make_fixture_rdata(tmp, img_size = 32, n_trials = 6, nscales = 1, seed = 1)

  mask <- matrix(1, 32, 32)
  mask[1:10, 1:10] <- 0 # black (0) = masked # nolint: commented_code_linter.

  set.seed(1)
  ci <- generateCI(
    stimuli = 1:6, responses = sample(c(1, -1), 6, replace = TRUE),
    baseimage = "base", rdata = rdata_path, save_as_png = FALSE, mask = mask
  )

  expect_true(all(is.na(ci$ci[1:10, 1:10])))
  expect_false(anyNA(ci$ci[11:32, 11:32]))
})

test_that("generateStimuli2IFC gives an informative error when the base image is not img_size", {
  # Issue #124. The base image resize step is commented out
  # (left behind when the biOps dependency was dropped), and only squareness
  # is validated - so a size mismatch surfaces from inside a foreach worker as
  # "non-conformable arrays", naming neither the file nor the sizes.
  tmp <- withr::local_tempdir()
  base_face <- file.path(tmp, "face64.png")
  make_square_png(base_face, size = 64)

  expect_error(
    generateStimuli2IFC(
      base_face_files = list(face = base_face),
      n_trials = 2, img_size = 32, stimulus_path = tmp,
      seed = 1, ncores = 1, nscales = 1, save_as_png = FALSE, save_rdata = FALSE
    ),
    regexp = "64|32|size|dimension",
    info = "the error should name the offending dimensions, not just 'non-conformable arrays'"
  )
})

test_that("generateNoiseImage supports pre-0.3.3 sinusoids/sinIdx noise patterns", {
  # No issue filed. The length check reads p$patchIdx before
  # the block that renames sinusoids/sinIdx to patches/patchIdx, so the
  # backward compatibility the code clearly intends never actually works.
  p <- generateNoisePattern(16, nscales = 1)
  p_legacy <- list(sinusoids = p$patches, sinIdx = p$patchIdx)
  params <- rep(1, max(p$patchIdx))

  expect_equal(generateNoiseImage(params, p_legacy), generateNoiseImage(params, p))
})

test_that("simulateNoiseIntensities returns a matrix of noise intensity ranges", {
  # No issue filed. Sizes its progress bar with `data[, by]`,
  # but neither is a parameter of the function, so `data` resolves to
  # utils::data and it errors every time. It also ignores img_size, hardcoding
  # generateNoisePattern(img_size = 512).
  # simulateNoiseIntensities() draws a boxplot as a side effect. Without an
  # open device that writes an Rplots.pdf into the working directory, which
  # R CMD check then flags as leftover detritus.
  grDevices::pdf(file = file.path(withr::local_tempdir(), "plot.pdf"))
  withr::defer(grDevices::dev.off())

  result <- simulateNoiseIntensities(nrep = 2, img_size = 32)

  expect_true(is.matrix(result))
  expect_equal(dim(result), c(2, 2))
  expect_true(all(result[, 1] <= result[, 2])) # min <= max per replication
})

test_that("generateReferenceDistribution2IFC does not write its own arguments into the .Rdata file", {
  tmp <- withr::local_tempdir()
  rdata_path <- make_fixture_rdata(tmp, img_size = 32, n_trials = 6, nscales = 1, seed = 1)

  # This function re-generates stimuli without forwarding a stimulus_path, so
  # it always creates ./stimuli relative to the working directory.
  withr::local_dir(tmp)

  suppressWarnings(generateReferenceDistribution2IFC(rdata_path, iter = 3, ncores = 1))

  e <- new.env()
  load(rdata_path, envir = e)

  # load() assigns straight into the caller's frame, so an `rdata` or `ncores`
  # object stored in the file overwrites the argument of the same name on the
  # next call: the caller's ncores would be silently ignored and the save
  # redirected to whatever path the file happened to record.
  expect_false(exists("rdata", envir = e, inherits = FALSE))
  expect_false(exists("ncores", envir = e, inherits = FALSE))
  expect_false(exists("i", envir = e, inherits = FALSE))

  # ...while everything the analysis functions actually need is still there.
  for (nm in c("base_faces", "stimuli_params", "p", "img_size", "seed",
               "n_trials", "nscales", "sigma", "reference_norms")) {
    expect_true(exists(nm, envir = e, inherits = FALSE), info = nm)
  }
})

test_that("computeInfoVal2IFC ignores a stale `rdata` path stored inside the .Rdata file", {
  tmp <- withr::local_tempdir()
  rdata_path <- make_fixture_rdata(tmp, img_size = 32, n_trials = 6, nscales = 1, seed = 1)

  # Simulate a file written by an older generateReferenceDistribution2IFC(),
  # which saved its own `rdata` argument into the file. Here that recorded path
  # no longer exists, so if load() is allowed to overwrite the argument this
  # function was called with, the regeneration below reads a missing file.
  e <- new.env()
  load(rdata_path, envir = e)
  assign("rdata", file.path(tmp, "moved-away.Rdata"), envir = e)
  save(list = ls(e, all.names = TRUE), file = rdata_path, envir = e)

  testthat::local_mocked_bindings(detectCores = function(...) 2L, .package = "parallel")
  withr::local_dir(tmp)

  target_ci <- list(ci = matrix(0.01, 32, 32))
  iv <- suppressWarnings(
    computeInfoVal2IFC(target_ci, rdata_path, iter = 3, force_gen_ref_dist = TRUE)
  )

  expect_type(iv, "double")
  expect_length(iv, 1)
  expect_false(is.na(iv))
})

test_that("generateCI truncates 4096-parameter files for a single trial too", {
  # Pre-0.3.0 rcicr drew 4096 random contrasts per trial while only 4092 patch
  # indices exist (6 orientations x 2 phases x sum(4^0..4^4)); 0.3.0 dropped the
  # 4 redundant draws and generateCI() has truncated old files ever since. The
  # single-trial branch tested `length(params) == 4092` and then truncated to
  # 4092 -- a no-op that could never fire on the 4096-length input it exists
  # for, so this path died in generateNoiseImage(). The multi-trial branch was
  # always correct and is asserted here too, so the fix cannot invert them.
  tmp <- withr::local_tempdir()

  img_size <- 512
  p <- generateNoisePattern()          # defaults: 4092 parameters
  expect_equal(max(p$patchIdx), 4092)

  base_faces <- list(base = matrix(0.5, img_size, img_size))
  stimuli_params <- list(base = matrix(runif(6 * 4096, -1, 1), nrow = 6))
  seed <- 1
  rdata_path <- file.path(tmp, "old4096.Rdata")
  save(base_faces, stimuli_params, p, img_size, seed, file = rdata_path)

  single <- generateCI(
    stimuli = 1, responses = 1, baseimage = "base",
    rdata = rdata_path, save_as_png = FALSE
  )
  multi <- generateCI(
    stimuli = 1:3, responses = c(1, -1, 1), baseimage = "base",
    rdata = rdata_path, save_as_png = FALSE
  )

  expect_equal(dim(single$ci), c(img_size, img_size))
  expect_equal(dim(multi$ci), c(img_size, img_size))
  expect_false(anyNA(single$ci))

  # The single-trial CI must be the noise of trial 1 alone, which is also what
  # the multi-trial route produces from that one row -- so the truncation cannot
  # be silently dropping or shifting parameters.
  expect_equal(single$ci, generateNoiseImage(stimuli_params$base[1, 1:4092], p))
})

test_that("computeCumulativeCICorrelation truncates 4096-parameter files like generateCI", {
  # Same pre-0.3.0 over-allocation as the test above: 4096 stored contrasts, 4092
  # real patches. generateCI() truncated these files; computeCumulativeCICorrelation()
  # did not, so the extra four columns reached generateNoiseImage() as a length
  # mismatch and it aborted with "number of parameters doesn't equal number of
  # patches" -- an availability gap on old files for this one analysis function.
  tmp <- withr::local_tempdir()

  # nscales = 5 gives 4092 patches at any image size, so a 16px pattern is enough.
  p <- generateNoisePattern(img_size = 16, nscales = 5)
  expect_equal(max(p$patchIdx), 4092)

  img_size <- 16
  base_faces <- list(base = matrix(0.5, img_size, img_size))
  seed <- 1
  params4092 <- matrix(runif(6 * 4092, -1, 1), nrow = 6)
  responses <- c(1, -1, 1, -1, 1, -1)

  write_rdata <- function(stimuli_params_mat) {
    stimuli_params <- list(base = stimuli_params_mat)
    path <- file.path(tmp, paste0("f", ncol(stimuli_params_mat), ".Rdata"))
    save(base_faces, stimuli_params, p, img_size, seed, file = path)
    path
  }
  # A 4096-column file (four unused padding contrasts) and its 4092 equivalent.
  path4096 <- write_rdata(cbind(params4092, matrix(runif(6 * 4, -1, 1), nrow = 6)))
  path4092 <- write_rdata(params4092)

  cc96 <- suppressWarnings(
    computeCumulativeCICorrelation(1:6, responses, "base", path4096)
  )
  cc92 <- suppressWarnings(
    computeCumulativeCICorrelation(1:6, responses, "base", path4092)
  )

  expect_length(cc96, 6)
  # Truncation must drop exactly the four padding columns, so the 4096 file gives
  # the same curve as the already-4092 file -- not merely "runs without error".
  expect_equal(cc96, cc92)

  # A single presented stimulus makes the parameter row a vector unless it is kept
  # two-dimensional; the params[1:trial, ] slice then aborted with "incorrect
  # number of dimensions" for any file, 4092 or 4096. drop = FALSE fixes both.
  one96 <- suppressWarnings(
    computeCumulativeCICorrelation(1, 1, "base", path4096)
  )
  one92 <- suppressWarnings(
    computeCumulativeCICorrelation(1, 1, "base", path4092)
  )
  expect_length(one96, 1)
  expect_equal(one96, one92)
})

test_that("generateCI's z-map sigma is not overwritten by the .Rdata's noise sigma", {
  # Found by tools/compare-release-output.R, 2026-07-28. load() assigns into
  # generateCI()'s own frame, and 1.1.0 started storing the noise `sigma` in the
  # .Rdata -- which has the same name as the z-map blur argument. So every
  # z-map from a 1.1.0-generated stimulus set was smoothed with the noise sigma
  # (25 by default) instead of the requested 3, silently, and passing `sigma`
  # did nothing at all. v1.0.1 files have no `sigma` field and were unaffected.
  tmp <- withr::local_tempdir()
  rdata_path <- make_fixture_rdata(tmp, img_size = 32, n_trials = 6, nscales = 1, seed = 1)
  withr::local_dir(tmp)

  e <- new.env()
  load(rdata_path, envir = e)
  # The field doing the shadowing. If this ever stops being saved, the bug is
  # gone for a different reason and this test stops testing anything.
  expect_equal(e$sigma, 25)

  zmap_at <- function(s) {
    ci <- generateCI(
      stimuli = 1:6, responses = c(1, -1, 1, -1, 1, -1), baseimage = "base",
      rdata = rdata_path, save_as_png = FALSE, targetpath = tmp,
      zmap = TRUE, zmapmethod = "quick", zmapdecoration = FALSE,
      zmaptargetpath = file.path(tmp, "zmaps"), sigma = s, threshold = 0
    )
    ci
  }

  small <- zmap_at(1)
  large <- zmap_at(e$sigma)

  # The z-map is exactly the blur at the sigma that was asked for...
  expected <- as.matrix(spatstat.explore::blur(spatstat.geom::as.im(small$ci), sigma = 1))
  expected <- matrix(scale(as.vector(expected)), 32, 32)
  expect_equal(small$zmap, expected, ignore_attr = TRUE)

  # ...and not the blur at the sigma stored in the file, which is what it was.
  expect_false(isTRUE(all.equal(small$zmap, large$zmap, check.attributes = FALSE)))
})

test_that("autoscale handles masked CIs instead of returning all NA", {
  # generateCI(mask = ...) sets masked pixels to NA by design, and autoscale()
  # called a bare range() on the result -- so the scaling constant became NA and
  # the function aborted with "missing value where TRUE/FALSE needed".
  # applyScaling() has always guarded its reductions; this path had not.
  ci <- matrix(seq(-0.2, 0.2, length.out = 64), 8, 8)
  ci[1:3, 1:3] <- NA

  cis <- list(p1 = list(ci = ci, base = matrix(0.5, 8, 8)))
  out <- autoscale(cis, save_as_pngs = FALSE)

  # The masked cells stay masked and everything else is scaled into [0, 1].
  expect_true(all(is.na(out$p1$scaled[1:3, 1:3])))
  expect_false(anyNA(out$p1$scaled[4:8, 4:8]))
  expect_gte(min(out$p1$scaled, na.rm = TRUE), 0)
  expect_lte(max(out$p1$scaled, na.rm = TRUE), 1)

  # The constant must come from the unmasked pixels only, so scaling matches
  # what the same CI with those cells simply absent would give.
  constant <- max(abs(range(ci, na.rm = TRUE)))
  expect_equal(out$p1$scaled, (ci + constant) / (2 * constant))
})

test_that("autoscale errors clearly on a fully masked CI", {
  cis <- list(p1 = list(ci = matrix(NA_real_, 8, 8), base = matrix(0.5, 8, 8)))
  expect_error(autoscale(cis, save_as_pngs = FALSE), "entirely NA")
})

test_that("the 'no parameters' error names the base image label, not the matrix", {
  # Both call sites pasted `base` -- the base image *matrix* -- into the message
  # where `baseimage`, the label, was meant. The result was an error message
  # carrying every pixel of the base face: 8,190 characters at 32px and roughly
  # 7 MB at the 512px researchers actually use, burying the diagnosis.
  skip_if_not_installed("withr")

  dir <- withr::local_tempdir()
  rdata <- make_fixture_rdata(dir)

  # Keep trial IDs valid so the missing-parameter diagnostic is reached.
  mutate_rdata(rdata, stimuli_params = list(base = matrix(numeric(), 6, 0)))
  err <- expect_error(
    computeCumulativeCICorrelation(
      stimuli = 1, responses = 1,
      baseimage = "base", rdata = rdata
    )
  )

  expect_match(conditionMessage(err), "No parameters found for base image: base")

  # The discriminating assertion: with the bug the message ran to thousands of
  # characters of pasted pixel values. Pin a bound far above any label and far
  # below a 32px matrix, so this cannot pass vacuously.
  expect_lt(nchar(conditionMessage(err)), 200)
})

test_that("generateCI() runs in parallel when targetpath is legitimately absent", {
  # foreach::getexports() scans the %dopar% body for free variables and get()s
  # each one, including the targetpath in the save_individual_cis branch. With
  # nothing being written that argument is absent and required, so the get()
  # aborted the call -- on the default core count, for anyone using
  # `participants` (#235). The branch it comes from never runs.
  skip_if_not_installed("withr")

  dir <- withr::local_tempdir()
  rdata <- make_fixture_rdata(dir, img_size = 32, n_trials = 6)
  responses <- rep(c(1, -1), 3)
  pids <- c(1, 1, 2, 2, 3, 3)

  # Serial has always worked: registerDoSEQ() exports nothing. Pinned so the
  # fix cannot break the path that was fine.
  expect_no_error(
    generateCI(1:6, responses, "base", rdata, save_as_png = FALSE,
               participants = pids, n_cores = 1)
  )

  skip_on_cran()

  expect_no_error(
    generateCI(1:6, responses, "base", rdata, save_as_png = FALSE,
               participants = pids, n_cores = 2)
  )

  # The case a .noexport = "targetpath" fix would have broken: with the branch
  # live, the workers do need the value. This passed before #235 was fixed and
  # must keep passing.
  target <- file.path(dir, "individual")
  expect_no_error(
    generateCI(1:6, responses, "base", rdata, save_as_png = FALSE,
               save_individual_cis = TRUE, targetpath = target,
               participants = pids, n_cores = 2)
  )
  expect_gt(length(list.files(file.path(target, "individual_cis"))), 0)
})

test_that("batchGenerateCI() still forwards a missing targetpath", {
  # batchGenerateCI() passes `targetpath=targetpath` even when its own is
  # absent, which is the forwarded-missing-promise case captureArgs() exists
  # for. Binding targetpath inside generateCI() (#235) happens downstream of
  # that forwarding, and this pins that it stays downstream.
  skip_if_not_installed("withr")

  dir <- withr::local_tempdir()
  rdata <- make_fixture_rdata(dir, img_size = 32, n_trials = 6)
  data <- data.frame(stim = 1:6, resp = rep(c(1, -1), 3), grp = rep(c("a", "b"), each = 3))

  expect_no_error(
    suppressWarnings(
      batchGenerateCI(data, by = "grp", stimuli = "stim", responses = "resp",
                      baseimage = "base", rdata = rdata, save_as_png = FALSE)
    )
  )
})

test_that("individual CIs are named for the participant they were computed from", {
  # The loop indexes participants by sorted factor level; the filename used to
  # come from order of appearance. Where those disagreed -- any data not sorted
  # by participant, "p2" before "p10", IDs collected out of order -- every file
  # in individual_cis/ carried someone else's ID.
  #
  # Contents, not filenames: both the old code and the new write the same *set*
  # of names, so a filename assertion cannot see this. It is why the existing
  # check in test-generateCI-paths.R passed throughout, and that one also uses
  # rep(c("a","b","c"), each = 4), already in sorted order.
  skip_if_not_installed("withr")

  dir <- withr::local_tempdir()
  rdata <- make_fixture_rdata(dir, img_size = 32, n_trials = 12)

  # Appearance order c("b", "a") against sorted order c("a", "b"), and
  # responses that make the two participants differ as much as they can.
  participants <- rep(c("b", "a"), each = 6)
  responses <- c(rep(1, 6), rep(-1, 6))

  target <- file.path(dir, "cis")
  generateCI(1:12, responses, "base", rdata, participants = participants,
             save_individual_cis = TRUE, save_as_png = FALSE,
             targetpath = target, n_cores = 1)

  read_ci <- function(pid) {
    m <- png::readPNG(file.path(target, "individual_cis", paste0("ci_", pid, ".png")))
    if (length(dim(m)) == 3) m[, , 1] else m
  }

  # What each participant's CI is, computed from their trials alone.
  truth <- lapply(c(a = "a", b = "b"), function(pid) {
    rows <- which(participants == pid)
    generateCI(rows, responses[rows], "base", rdata, save_as_png = FALSE,
               scaling = "independent")$combined
  })

  # 0.01 sits between the two scales that matter here, both measured: 8-bit PNG
  # quantisation moves a pixel by at most 1/255 = 0.0039, while the two
  # participants' CIs differ by 0.419 at their furthest pixel. Neither
  # assertion below can be satisfied by the wrong image.
  expect_equal(read_ci("a"), truth$a, tolerance = 0.01)
  expect_equal(read_ci("b"), truth$b, tolerance = 0.01)

  # Not vacuous: with the participants swapped these would still both pass if
  # the two CIs happened to be alike.
  expect_gt(max(abs(truth$a - truth$b)), 0.05)
})

test_that("the batch functions label each CI with the participant it was computed from", {
  # generateCI(participants=, save_individual_cis=TRUE) mislabelled its output
  # (the test above). batchGenerateCI() and batchGenerateCI2IFC() wrap
  # generateCI(), so "they are unaffected" is a claim about the wrapper, not an
  # obvious fact -- and NEWS.md and the CRAN submission both make it. It holds
  # because each wrapper calls generateCI() once per group with participants =
  # NA, so the mislabelling loop never runs, and takes the filename from the
  # group value it is already iterating over. This pins that.
  skip_if_not_installed("withr")

  dir <- withr::local_tempdir()
  rdata <- make_fixture_rdata(dir, img_size = 32, n_trials = 12)

  # Appearance order p1, p2, p10 against lexical order p1, p10, p2 -- the same
  # disagreement that breaks the direct call.
  participants <- rep(c("p1", "p2", "p10"), each = 4)
  responses <- c(rep(1, 4), rep(-1, 4), rep(c(1, -1), 2))
  data <- data.frame(stim = 1:12, resp = responses, pid = participants,
                     stringsAsFactors = FALSE)

  truth <- lapply(c(p1 = "p1", p2 = "p2", p10 = "p10"), function(p) {
    rows <- which(participants == p)
    generateCI(rows, responses[rows], "base", rdata, save_as_png = FALSE)$ci
  })

  # Not vacuous: the three must actually differ, or any labelling would pass.
  expect_gt(max(abs(truth$p1 - truth$p2)), 0.01)
  expect_gt(max(abs(truth$p1 - truth$p10)), 0.01)

  for (fn in list(batchGenerateCI, batchGenerateCI2IFC)) {
    cis <- suppressWarnings(fn(data = data, by = "pid", stimuli = "stim",
                               responses = "resp", baseimage = "base",
                               rdata = rdata, save_as_png = FALSE))
    for (nm in names(cis)) {
      named <- sub("^.*_pid_", "", nm)
      dists <- vapply(truth, function(t) max(abs(cis[[nm]]$ci - t)), numeric(1))
      expect_identical(
        names(which.min(dists)), named,
        info = paste0(nm, " holds ", names(which.min(dists)), "'s CI")
      )
    }
  }
})