tests/testthat/test-legacy-rdata.R

In rcicr: Reverse-Correlation Image-Classification Toolbox

# --------------------------------------------------------------------------
# Real .Rdata files from released versions, read by the current one
#
# The guiding constraint made mechanical from the other direction: researchers
# re-run stored scripts years later, against stimulus sets generated by whatever
# rcicr they had then. Every other test builds its fixture with the *current*
# generator, so none of them can catch a field this version expects and an older
# one never wrote.
#
# The fixtures are what those releases actually wrote -- generated by installing
# each tag and letting it run, see tools/make-legacy-rdata.R -- for the reason
# the release gate runs the old code rather than trusting the golden master. What
# they contain is not a reconstruction:
#
#   1.0.1        no `nscales`, no `sigma` (both added in 1.1.0).
#                generator_version '0.4.0', p$generator_version '1.0.1'.
#   1.0.1-gabor  the same release with noise_type = 'gabor', which it does save.
#                The case that hits both missing-field fallbacks at once, and the
#                only one where the missing `sigma` can change anything: sigma
#                reaches the basis through generateGabor() alone.
#   1.1.0        has nscales and sigma. generator_version still '0.4.0',
#                p$generator_version '1.1.0'.
#
# That both files really do claim 0.4.0 while `p` holds the truth is the measured
# basis for preferring p$generator_version -- see DECISIONS.md, "`generator_version`
# in old `.Rdata` files is not trustworthy".
#
# Do not regenerate these to make a red test pass. A failure here means this
# version can no longer read a file a researcher already has.
# --------------------------------------------------------------------------

legacy_versions <- c("1.0.1", "1.1.0")

# Fixture ids, not versions: a release can contribute more than one file, and the
# id is what names it on disk. Only the tests asserting the *writing version* are
# keyed on legacy_versions.
gabor_fixture <- "1.0.1-gabor"
legacy_fixtures <- c(legacy_versions, gabor_fixture)

legacy_fixture <- function(version) {
  path <- test_path("fixtures", paste0("legacy-rdata-", version, ".Rdata")) # nolint: object_usage_linter.
  # Committed, mandatory assets, so a missing one fails rather than skips: a skip
  # reads as "this passed" at a glance, and the scenario it would hide -- the
  # fixture deleted, renamed, or left out of a built package -- is precisely the
  # safeguard silently disappearing while CI stays green.
  expect_true(file.exists(path), info = paste("missing legacy fixture:", path)) # nolint: object_usage_linter.
  path
}

# generateCI() writes to disk, so each call gets its own directory. The fixture
# itself is never written to: it is copied first, because a test that mutated it
# would silently rewrite a committed artefact.
#
# `base_face_files` is repointed at a base image written here. These files store
# an *absolute* path from the machine that generated them -- a real property of
# every `.Rdata` rcicr writes, and the reason a researcher who moved their base
# image cannot re-generate either. Only readers that re-generate stimuli
# (generateReferenceDistribution2IFC()) ever open it; generateCI() works from the
# `base_faces` matrix already in the file. The image is the same synthetic square
# the rest of the suite uses, and its content is irrelevant to what is asserted.
local_fixture_copy <- function(version, env = parent.frame()) {
  dir <- withr::local_tempdir(.local_envir = env)
  dest <- file.path(dir, basename(legacy_fixture(version)))
  file.copy(legacy_fixture(version), dest)

  base_png <- make_square_png(file.path(dir, "base.png"), size = 32, seed = 1) # nolint: object_usage_linter.
  mutate_rdata(dest, base_face_files = list(base = base_png)) # nolint: object_usage_linter.

  dest
}

test_that("the current generateCI() reads .Rdata files written by older releases", {
  skip_if_not_installed("withr")

  for (version in legacy_fixtures) {
    rdata <- local_fixture_copy(version)

    ci <- generateCI(
      stimuli = 1:6, responses = rep(c(1, -1), 3), baseimage = "base",
      rdata = rdata, save_as_png = FALSE
    )

    # A classification image at the fixture's own size, and real numbers in it:
    # "it ran" is not the claim, "it produced a CI" is.
    expect_true(is.matrix(ci$ci), info = version)
    expect_equal(dim(ci$ci), c(32L, 32L), info = version)
    expect_false(anyNA(ci$ci), info = version)
    expect_gt(stats::sd(as.vector(ci$ci)), 0)
  }
})

test_that("a 1.0.1 file genuinely lacks nscales and sigma", {
  e <- new.env()
  load(legacy_fixture("1.0.1"), envir = e)

  expect_false(exists("nscales", envir = e, inherits = FALSE))
  expect_false(exists("sigma", envir = e, inherits = FALSE))
  # noise_type predates 1.0.1, so this file has it -- which is why the test below
  # expects the nscales warning and not the noise_type one.
  expect_true(exists("noise_type", envir = e, inherits = FALSE))
})

reference_norms_for <- function(rdata) {
  seen <- character()
  withCallingHandlers(
    generateReferenceDistribution2IFC(rdata, iter = 3, ncores = 1),
    warning = function(cond) {
      seen <<- c(seen, conditionMessage(cond))
      invokeRestart("muffleWarning")
    }
  )
  after <- new.env()
  load(rdata, envir = after)
  list(warnings = seen, norms = after$reference_norms)
}

test_that("a file without nscales is scored from its saved basis, whatever nscales says", {
  skip_if_not_installed("withr")

  # generateCI() never reads nscales or sigma, and the reference distribution no
  # longer does either: it is built from the basis the file saved (#301) rather
  # than rebuilt from an nscales *value*. So the fallback this used to pin is
  # gone, and what replaces it is the stronger claim -- the stored value cannot
  # influence the answer at all.
  #
  # That is what fixes these files. The old rebuild assumed 5 whenever nscales
  # was absent, which is right only for a file generated at the default; at any
  # other value it scored the participant's stimuli against a basis they never
  # saw, and finished just as happily.
  fallback <- reference_norms_for(local_fixture_copy("1.0.1"))

  explicit_5 <- local_fixture_copy("1.0.1")
  mutate_rdata(explicit_5, nscales = 5)
  explicit_5 <- reference_norms_for(explicit_5)

  explicit_3 <- local_fixture_copy("1.0.1")
  mutate_rdata(explicit_3, nscales = 3)
  explicit_3 <- reference_norms_for(explicit_3)

  # No field is missing any more, because none is consulted.
  expect_false(any(grepl("does not contain `nscales`", fallback$warnings, fixed = TRUE)))
  expect_false(any(grepl("does not contain `noise_type`", fallback$warnings, fixed = TRUE)))

  # The saved basis governs: injecting a right or a wrong nscales changes nothing.
  expect_identical(fallback$norms, explicit_5$norms)
  expect_identical(fallback$norms, explicit_3$norms)
  expect_length(fallback$norms, 3)
  expect_false(anyNA(fallback$norms))
})

test_that("a 1.0.1 gabor file lacks nscales and sigma but records its noise type", {
  e <- new.env()
  load(legacy_fixture(gabor_fixture), envir = e)

  expect_false(exists("nscales", envir = e, inherits = FALSE))
  expect_false(exists("sigma", envir = e, inherits = FALSE))
  # noise_type is saved, which is what makes this file usable as the both-
  # fallbacks case rather than one that also has to guess the kind of noise.
  expect_equal(get("noise_type", envir = e), "gabor")
})

test_that("a gabor file without sigma is scored from its saved basis", {
  skip_if_not_installed("withr")

  # sigma reaches the noise basis through generateGabor() alone, and the basis is
  # no longer rebuilt: it is read from the file (#301). So the value that used to
  # be assumed, warned about and pinned here cannot reach the answer at all --
  # which is what makes these files right rather than merely quiet. Under the old
  # rebuild a gabor file generated at sigma 10 was scored at the assumed 25, and
  # the norms differ: 0.615/0.620/0.626 against 0.681/0.689/0.680.
  fallback <- reference_norms_for(local_fixture_copy(gabor_fixture))

  explicit_25 <- local_fixture_copy(gabor_fixture)
  mutate_rdata(explicit_25, sigma = 25)
  explicit_25 <- reference_norms_for(explicit_25)

  explicit_10 <- local_fixture_copy(gabor_fixture)
  mutate_rdata(explicit_10, sigma = 10)
  explicit_10 <- reference_norms_for(explicit_10)

  sinusoidal <- reference_norms_for(local_fixture_copy("1.0.1"))

  warned <- function(x) any(grepl("does not contain `sigma`", x$warnings, fixed = TRUE))

  # No field is missing any more, on any of them, because none is consulted.
  expect_false(warned(fallback))
  expect_false(warned(explicit_25))
  expect_false(warned(sinusoidal))

  # The saved basis governs: injecting either sigma changes nothing.
  expect_identical(fallback$norms, explicit_25$norms)
  expect_identical(fallback$norms, explicit_10$norms)
  expect_length(fallback$norms, 3)
  expect_false(anyNA(fallback$norms))
})

test_that("a 1.1.0 file is scored from its basis, not from its recorded nscales", {
  skip_if_not_installed("withr")

  # 1.1.0 records nscales, and this fixture records 1 -- deliberately unlike the
  # 5 the old rebuild fell back to. The reference is read from the saved basis
  # now (#301), so the recorded value has no influence: what pins the reader is
  # that mutating nscales to 5 leaves the null untouched, where the rebuild would
  # have moved it.
  e <- new.env()
  load(legacy_fixture("1.1.0"), envir = e)
  expect_equal(get("nscales", envir = e), 1)

  saved <- reference_norms_for(local_fixture_copy("1.1.0"))

  as_1 <- local_fixture_copy("1.1.0")
  mutate_rdata(as_1, nscales = 1)
  as_1 <- reference_norms_for(as_1)

  as_5 <- local_fixture_copy("1.1.0")
  mutate_rdata(as_5, nscales = 5)
  as_5 <- reference_norms_for(as_5)

  expect_false(any(grepl("does not contain `nscales`", saved$warnings, fixed = TRUE)))
  expect_identical(saved$norms, as_1$norms)
  expect_identical(saved$norms, as_5$norms)
})

test_that("the writing version is read from p, not from the field that says 0.4.0", {
  skip_if_not_installed("withr")

  # The synthetic version of this is in test-rdata-writer-note.R; this is the
  # same assertion against files a release actually wrote.
  for (version in legacy_versions) {
    e <- new.env()
    load(legacy_fixture(version), envir = e)
    expect_equal(as.character(get("generator_version", envir = e)), "0.4.0", info = version)
    expect_equal(as.character(get("p", envir = e)$generator_version), version, info = version)

    rdata <- local_fixture_copy(version)
    mutate_rdata(rdata, .remove = "stimuli_params")

    msg <- tryCatch(
      generateCI(stimuli = 1:6, responses = rep(c(1, -1), 3), baseimage = "base",
                 rdata = rdata, save_as_png = FALSE),
      error = conditionMessage
    )

    expect_match(msg, paste("written by rcicr", version), fixed = TRUE)
    expect_false(grepl("0.4.0", msg, fixed = TRUE))
  }
})