## ----include = FALSE----------------------------------------------------------
knitr::opts_chunk$set(collapse = TRUE, comment = "#>")
fields <- function(...) {
  rows <- matrix(c(...), ncol = 2, byrow = TRUE)
  data.frame(field = rows[, 1], description = rows[, 2])
}
table_of <- function(x, header = c("Field", "What it is")) {
  x$field <- paste0("`", x$field, "`")
  knitr::kable(x, col.names = header, row.names = FALSE)
}

## ----setup--------------------------------------------------------------------
library(rcicr)

## ----generate, results = "hide", message = FALSE------------------------------
base_face <- tempfile(fileext = ".png")
png::writePNG(outer(seq(0, 1, length.out = 64), seq(1, 0, length.out = 64)), base_face)

stimulus_path <- tempfile("stimuli")
generateStimuli2IFC(list(face = base_face), n_trials = 20, img_size = 64,
                    stimulus_path = stimulus_path, seed = 1, ncores = 1, save_as_png = FALSE)
rdata_file <- list.files(stimulus_path, pattern = "\\.Rdata$", full.names = TRUE)

## ----ls-----------------------------------------------------------------------
basename(rdata_file)
stored <- new.env()
load(rdata_file, envir = stored)
ls(stored)

## ----rdata-fields, echo = FALSE-----------------------------------------------
rdata_fields <- fields(
  "p", "The noise basis, described in the next table. This is the expensive part and the reason the file exists.",
  "stimuli_params", "Named list, one entry per base image, each an `n_trials` by `nparams` matrix of contrast weights in [-1, 1]. **Row *i* is the noise of stimulus *i***: this is what `generateCI()` looks up and weights by the responses.",
  "base_faces", "Named list of the base images as greyscale matrices, after contrast maximization. The pixels themselves, not paths, so the file is self-contained.",
  "base_face_files", "The paths the base images were read from, for reference.",
  "img_size", "Width and height of the images, in pixels.",
  "n_trials", "Number of stimuli per base image. The InfoVal reference uses it to select trial rows.",
  "nscales", "Number of spatial scales in the basis. Added in 1.1.0.",
  "sigma", "Width of the Gabor patches, used when `noise_type` is `\"gabor\"`. Added in 1.1.0.",
  "noise_type", "`\"sinusoid\"` or `\"gabor\"`.",
  "seed", "The RNG seed. Regenerating the stimuli from it also needs the same generation settings and the same `RNGkind()`.",
  "rng_kind", "`RNGkind()` when the stimuli were drawn. InfoVal references replay the seed's stream under it, so they do not depend on the kind of the session that computes them. Files without it replay under the session's kind. Added in 1.6.0.",
  "use_same_parameters", "Whether every base image shared one parameter matrix (`TRUE`) or each got its own.",
  "label", "The label the stimulus files were named with.",
  "stimulus_path", "The directory the files were written to.",
  "generator_version", "The rcicr version that wrote the file, as a `package_version`. Unreliable in older files; see below."
)
table_of(rdata_fields)

## ----p-fields, echo = FALSE---------------------------------------------------
p_fields <- fields(
  "patches", "An `img_size` by `img_size` by `12 * nscales` array of sinusoid or Gabor layers.",
  "patchIdx", "Which parameter drives each pixel of each layer.",
  "noise_type", "As above.",
  "generator_version", "The rcicr version that built the basis. Unlike the top-level field, this one has always been correct."
)
table_of(p_fields)

## ----infoval, results = "hide", message = FALSE, warning = FALSE--------------
ci <- generateCI(stimuli = 1:20, responses = rep(c(1, -1), 10), baseimage = "face",
                 rdata = rdata_file, save_as_png = FALSE)
computeInfoVal2IFC(ci, rdata_file, iter = 1000)

## ----ls-infoval---------------------------------------------------------------
load(rdata_file, envir = stored)
grep("^reference", ls(stored), value = TRUE)

## ----reference-fields, echo = FALSE-------------------------------------------
reference_fields <- fields(
  "reference_norms", "The simulated null distribution: the norms of `iter` classification images built from random responses. Written when the base images share one parameter matrix.",
  "reference_norms_seed", "The `response_seed` those norms were drawn with, or `NULL` for the default stream. Added in 1.2.0.",
  "reference_norms_source", "What `reference_norms` was built from: `\"saved_noise\"` means the file's own saved parameters and basis. A default-stream reference without this marker and a matching `reference_norms_fingerprint` is rebuilt and, if the file is writable, saved. A reference drawn with a `response_seed` is kept; if it was built from an incorrect reconstruction, regenerate it yourself before recomputing InfoVal. Added in 1.4.0.",
  "reference_norms_fingerprint", "A full copy of the norms, as `list(norms = ...)`, compared with `identical()`. An older rcicr can keep the marker while replacing the norms; if the copy no longer matches, a default-stream reference is rebuilt. About 80 KB for 10,000 norms before compression. Added in 1.4.0.",
  "reference_norms_method", "How the norms were computed: `\"gram\"` (the default) or `\"images\"`. References from 1.5.0 and earlier, which lack this field, were computed with `\"images\"`; pass `reference_method = \"images\"` to reproduce them. Added in 1.6.0.",
  "reference_norms_by_base", "Written instead of the fields above when the base images have *different* parameter matrices, because each base then needs a null built from its own saved noise. A list named by base label, one entry each; the entries are described below. A `reference_norms` already in such a file is left in place and ignored. Added in 1.4.0.",
  "reference_norms_by_stimuli", "References for a classification image that did not use every saved stimulus (`reference_stimuli`) or that is masked. A list with one entry per stimulus set and mask, described below. The default reference is never read or written for these. Added in 1.6.0."
)
table_of(reference_fields)

## ----entry-fields, echo = FALSE-----------------------------------------------
entry_fields <- fields(
  "norms", "The simulated null distribution, as in `reference_norms`.",
  "response_seed", "As `reference_norms_seed`.",
  "source", "As `reference_norms_source`.",
  "fingerprint", "As `reference_norms_fingerprint`.",
  "method", "As `reference_norms_method`. Added in 1.6.0.",
  "reference_stimuli", "`reference_norms_by_stimuli` only: the stimulus numbers the reference was built over.",
  "baseimage", "`reference_norms_by_stimuli` only: the base label, or `NULL` when the bases share one parameter matrix.",
  "mask", "`reference_norms_by_stimuli` only: the run-length encoding of the mask the classification image was scored under, or `NULL` when it was not masked. Added in 1.6.0."
)
by_stimuli_only <- c("reference_stimuli", "baseimage", "mask")
table_of(entry_fields)

## ----rdata-attributes, echo = FALSE-------------------------------------------
rdata_attributes <- data.frame(
  field = c("generator_version", "p$generator_version"),
  attribute = "class",
  description = c(
    "`package_version`, so versions compare with `<` and `>=`. Files from before 1.2.0 hold a character string instead.",
    "`package_version`, in files from every version back to 0.3.3, the oldest in the repository's history."
  )
)
x <- rdata_attributes
x$field <- paste0("`", x$field, "`")
x$attribute <- paste0("`", x$attribute, "`")
knitr::kable(x, col.names = c("Field", "Attribute", "What it is"), row.names = FALSE)

## ----ci-names-----------------------------------------------------------------
names(ci)

## ----ci-elements, echo = FALSE------------------------------------------------
ci_elements <- fields(
  "ci", "The raw classification noise: the stimuli's noise, weighted by the responses and averaged.",
  "scaled", "The noise after scaling, as recorded in the `scaling` attribute.",
  "base", "The base image.",
  "combined", "The scaled noise over the base image: what a CI PNG shows.",
  "zmap", "The z-map. Only with `zmap = TRUE`."
)
table_of(ci_elements, c("Element", "What it is"))

## ----ci-attributes------------------------------------------------------------
str(attr(ci, "trial_design"))
str(attr(ci, "scaling"))

## ----trial-design, echo = FALSE-----------------------------------------------
trial_design_fields <- fields(
  "stimuli", "The saved stimuli the classification image was built from, sorted and unique. Pass it as `reference_stimuli` to score a CI that did not use every stimulus.",
  "repeated", "Whether any stimulus was presented more than once (per participant, when `participants` was given).",
  "n_participants", "How many participants contributed; 1 when `participants` was not given."
)
table_of(trial_design_fields)

## ----scaling, echo = FALSE----------------------------------------------------
scaling_fields <- fields(
  "method", "The scaling method applied. An unrecognised one is recorded as the `\"none\"` used instead; after `autoscale()`, `\"autoscale\"`.",
  "constant", "The constant used: `NA` for `\"none\"` and `\"matched\"`, the one computed from this CI for `\"independent\"`, and the shared constant after `autoscale()`.",
  "individual", "With `participants`: the same `method` and `constant` for the individual CIs, with one constant per participant, named by ID, under `\"independent\"`. These are the CIs `save_individual_cis` writes, and the record is there whether or not they were written.",
  "combined", "After `autoscale()`: the `method` and `constant` that still describe `combined`, which `autoscale()` leaves as it was. `NULL` when there was no earlier record."
)
nested_scaling <- c("method", "constant")
table_of(scaling_fields)

## ----check, include = FALSE---------------------------------------------------
# Every layout the package writes is generated and compared with the tables
# above, in both directions, so a field added without a row fails the build.
mismatch <- function(what, found, documented) {
  undocumented <- setdiff(found, documented)
  unwritten <- setdiff(documented, found)
  if (length(undocumented) || length(unwritten)) {
    stop(what, ": undocumented ", toString(undocumented),
         "; documented but not written ", toString(unwritten), call. = FALSE)
  }
}
attribute_paths <- function(x, path) {
  own <- setdiff(names(attributes(x)), c("names", "dim"))
  found <- if (length(own)) paste0(path, "@", own)
  if (is.list(x) && !is.null(names(x))) {
    for (n in names(x)) found <- c(found, attribute_paths(x[[n]], paste0(path, "$", n)))
  }
  found
}
loaded <- function(file) {
  env <- new.env()
  load(file, envir = env)
  as.list(env, all.names = TRUE)
}
quietly <- function(expr) {
  utils::capture.output(value <- suppressWarnings(suppressMessages(expr)))
  value
}
generate <- function(bases, ...) {
  path <- tempfile("stimuli")
  quietly(generateStimuli2IFC(bases, n_trials = 20, img_size = 64, stimulus_path = path,
                              seed = 1, ncores = 1, save_as_png = FALSE, ...))
  list.files(path, pattern = "\\.Rdata$", full.names = TRUE)
}
responses <- rep(c(1, -1), 10)
mask <- matrix(TRUE, 64, 64)
mask[20:30, ] <- FALSE

# Shared parameters: the file above already holds the default reference; a
# subset and a masked reference are added to it.
shared <- rdata_file
ci_all <- ci
ci_subset <- quietly(generateCI(1:15, responses[1:15], "face", shared, save_as_png = FALSE))
quietly(computeInfoVal2IFC(ci_subset, shared, iter = 1000,
                           reference_stimuli = attr(ci_subset, "trial_design")$stimuli))
ci_masked <- quietly(generateCI(1:20, responses, "face", shared, save_as_png = FALSE, mask = mask))
quietly(computeInfoVal2IFC(ci_masked, shared, iter = 1000))

# Per-base parameters.
other_face <- tempfile(fileext = ".png")
png::writePNG(outer(seq(1, 0, length.out = 64), seq(0, 1, length.out = 64)), other_face)
per_base <- generate(list(face = base_face, other = other_face), use_same_parameters = FALSE)
ci_other <- quietly(generateCI(1:20, responses, "other", per_base, save_as_png = FALSE))
quietly(computeInfoVal2IFC(ci_other, per_base, iter = 1000, baseimage = "other"))

files <- list(loaded(shared), loaded(per_base))
mismatch("Top-level fields of the .Rdata file", unique(unlist(lapply(files, names))),
         c(rdata_fields$field, reference_fields$field))
mismatch("Fields of p", unique(unlist(lapply(files, function(f) names(f$p)))), p_fields$field)
by_base <- unlist(lapply(files, function(f) lapply(f$reference_norms_by_base, names)))
mismatch("Fields of a reference_norms_by_base entry", unique(by_base),
         setdiff(entry_fields$field, by_stimuli_only))
by_stimuli <- unlist(lapply(files, function(f) lapply(f$reference_norms_by_stimuli, names)))
mismatch("Fields of a reference_norms_by_stimuli entry", unique(by_stimuli), entry_fields$field)
mismatch("Attributes in the .Rdata file",
         unique(unlist(lapply(files, function(f) attribute_paths(f, "")))),
         paste0("$", rdata_attributes$field, "@", rdata_attributes$attribute))

# Every shape of classification image.
participants <- rep(1:2, each = 10)
zmap_path <- tempfile("zmap")
cis <- list(
  plain = ci_all,
  participants = quietly(generateCI(1:20, responses, "face", shared, save_as_png = FALSE,
                                    participants = participants, n_cores = 1)),
  zmap = quietly(generateCI(1:20, responses, "face", shared, save_as_png = FALSE, zmap = TRUE,
                            zmapdecoration = FALSE, zmaptargetpath = zmap_path))
)
cis$autoscaled <- quietly(autoscale(list(a = cis$plain, b = cis$participants),
                                    save_as_pngs = FALSE))$b
batch <- quietly(batchGenerateCI2IFC(data.frame(s = 1:20, r = responses, p = participants),
                                     "p", "s", "r", "face", shared, save_as_png = FALSE))
cis <- c(cis, unname(batch))

mismatch("Elements of a classification image", unique(unlist(lapply(cis, names))),
         ci_elements$field)
mismatch("Attributes of a classification image",
         unique(unlist(lapply(cis, function(x) setdiff(names(attributes(x)), "names")))),
         c("trial_design", "scaling"))
mismatch("Fields of trial_design",
         unique(unlist(lapply(cis, function(x) names(attr(x, "trial_design"))))),
         trial_design_fields$field)
mismatch("Fields of scaling", unique(unlist(lapply(cis, function(x) names(attr(x, "scaling"))))),
         scaling_fields$field)
mismatch("Fields of scaling$individual and scaling$combined",
         unique(unlist(lapply(cis, function(x) {
           s <- attr(x, "scaling")
           c(names(s$individual), names(s$combined))
         }))),
         nested_scaling)
mismatch("Attributes inside a classification image",
         unique(unlist(lapply(cis, function(x) {
           c(attribute_paths(unclass(x)[names(x)], ""),
             attribute_paths(attr(x, "trial_design"), "trial_design"),
             attribute_paths(attr(x, "scaling"), "scaling"))
         }))),
         character(0))