tests/testthat/test-models.R

In XSLmodels: Run and Optimize Cross-Situational Word Learning Models

test_that("guess_and_test disconfirms a hypothesis once contradicted, rather than keeping it forever", {
  # regression test: an inverted guard clause (`if (length(which(m[w,]==1)))
  # next`) made the disconfirmation step permanently unreachable, since
  # have_hypoths is already filtered to words with a stored hypothesis (so
  # the guard's condition was always true). Word 1 forms some hypothesis
  # from {1,2} on trial 1, then every remaining trial only offers {3,4} --
  # neither 1 nor 2 is ever a candidate again, so the trial-1 hypothesis
  # MUST be disconfirmed (and a new one formed from {3,4}) for the model to
  # ever end up with weight on {3,4}. With the bug, the trial-1 hypothesis
  # is retained forever and {3,4} never receives any weight at all.
  dat <- xslData(
    train = list(words = list(1, 1, 1, 1, 1, 1),
                 objects = list(c(1, 2), c(3, 4), c(3, 4), c(3, 4), c(3, 4), c(3, 4))),
    accuracy = c(0.5),
    label = "disconfirmation test"
  )
  mod <- guess_and_test(f = 0, sa = 1)
  result <- xsl_run(mod, dat, control = xslControl(n_sim = 500))
  m <- result$fits[[1]]$matrix

  expect_equal(sum(m[1, 1:2]), 0, tolerance = 1e-6)
  expect_equal(sum(m[1, 3:4]), 500, tolerance = 1e-6)
})

test_that("guess_and_test() survives repeated words per utterance and non-integer object labels", {
  # regression: an utterance that repeats a word ("the doggy the doggy") made
  # that word appear twice in have_hypoths, and the first pass could clear its
  # hypothesis so the second pass hit `which(m[w, ] == 1)` of length 0 (->
  # "argument is of length zero") or 2 (-> "the condition has length > 1").
  # Separately, the disconfirmation check compared a column *position* to the
  # object *labels*, which only worked when objects were labelled 1..N. Both
  # broke the model on any naturalistic corpus.
  dat <- xslData(
    train = list(
      words = list(c("the", "dog", "the", "dog"), c("look", "a", "cat"),
                   c("dog", "dog"), c("the", "cat")),
      objects = list(c("dog_o", "ball"), c("cat_o", "dog_o"),
                     c("dog_o", "ball"), c("cat_o", "ball"))
    ),
    accuracy = numeric(), label = "repeated-word / string-label test"
  )
  # suppressWarnings: get_perf() inside xsl_run() recycles on a non-square
  # matrix (this toy has more word types than object types)
  res <- suppressWarnings(xsl_run(guess_and_test(f = 0.1, sa = 0.5), dat,
                                  control = xslControl(n_sim = 20)))
  m <- res$fits[[1]]$matrix
  expect_false(anyNA(m))
  expect_true(all(is.finite(m)))
})

test_that("tilles() runs on data with non-integer object labels", {
  # regression: tilles() did as.integer() on the words/objects (they index
  # m / novel_* by position), which turned string corpus labels into NA and
  # left the matrix all-zero; it also never set dimnames on its matrix, so
  # the result could not be scored against a gold lexicon by label.
  dat <- xslData(
    train = list(words = list(c("dog", "look"), c("cat", "a"), c("dog", "cat")),
                 objects = list(c("dog_o", "cat_o"), c("cat_o", "dog_o"),
                                c("dog_o", "cat_o"))),
    accuracy = numeric(), label = "string-label test"
  )
  m <- xsl_run(tilles(x = .5, b = .8, alpha_0 = .85), dat)$fits[[1]]$matrix
  expect_equal(rownames(m), sort(c("dog", "look", "cat", "a")))
  expect_equal(colnames(m), c("cat_o", "dog_o"))
  expect_true(all(is.finite(m)) && any(m != 0))
})

test_that("uncfam_attention() falls back to uncfam()'s unscaled rate on a single-trial dataset", {
  # uncfam_attention() scales X by this trial's mean object entropy relative
  # to the mean entropy of all objects seen so far. With only one trial ever
  # presented, every object touched on it has just received its first
  # association -- Shannon entropy of a single nonzero cell is 0 -- so both
  # the trial's and the running mean's entropy are 0, hitting the
  # divide-by-zero fallback (scaled_X <- X). The two models should therefore
  # produce identical results whenever there's only one trial.
  dat <- xslData(
    train = list(words = list(c(1, 2)), objects = list(c(1, 2))),
    accuracy = c(0.5, 0.5),
    label = "single trial"
  )
  plain <- xsl_run(uncfam(X = .3, B = .5, C = .9), dat)
  attention <- xsl_run(uncfam_attention(X = .3, B = .5, C = .9), dat)
  expect_equal(attention$fits[[1]]$matrix, plain$fits[[1]]$matrix)
})

test_that("uncfam_gamma(gamma = 1) is identical to uncfam()", {
  # gamma raises familiarity (assocs) to a free power instead of uncfam()'s
  # implicit linear weight (assocs^1); gamma = 1 must reproduce uncfam()
  # exactly, on a real multi-trial dataset (not just a degenerate one-trial
  # case where every term is trivially equal).
  dat <- get_example_ambiguous_condition()
  plain <- xsl_run(uncfam(X = .1, B = .98, C = 1), dat)
  gamma1 <- xsl_run(uncfam_gamma(X = .1, B = .98, C = 1, gamma = 1), dat)
  expect_equal(gamma1$fits[[1]]$matrix, plain$fits[[1]]$matrix)
})

test_that("uncfam_elimination(eps = 0) is identical to uncfam()", {
  dat <- get_example_ambiguous_condition()
  plain <- xsl_run(uncfam(X = .1, B = .98, C = 1), dat)
  eps0 <- xsl_run(uncfam_elimination(X = .1, B = .98, C = 1, eps = 0), dat)
  expect_equal(eps0$fits[[1]]$matrix, plain$fits[[1]]$matrix)
})

test_that("uncfam_elimination() directs learning to the pair left over by a known pair", {
  # word 1 is first learned alone with object 1; then words 1 and 2 appear
  # together with objects 1 and 2. Elimination should favour the 2-2 pairing
  # over the 2-1 pairing more than uncfam() does.
  dat <- xslData(train = list(words = list(1, 1, 1, c(1, 2)), objects = list(1, 1, 1, c(1, 2))))
  run <- function(eps) xsl_run(uncfam_elimination(X = .5, B = .98, C = 1, eps = eps), dat)$fits[[1]]$matrix
  m0 <- run(0)
  m5 <- run(5)
  expect_gt(m5[2, 2], m0[2, 2])
  expect_gt(m5[2, 2] / m5[2, 1], m0[2, 2] / m0[2, 1])
  expect_true(all(is.finite(m5)))
})

test_that("uncfam_gamma()'s gamma actually changes the allocation away from uncfam()'s", {
  # get_example_ambiguous_condition() only has 2 trials with entirely
  # disjoint words/objects, so every trial's `assocs` are uniform (all
  # freshly-seen pairs at the same startval) -- and gamma raising a uniform
  # value to any power, then renormalizing, is a no-op. Needs a dataset
  # where some pairs are more familiar than others within the same later
  # trial for gamma to have anything to bite on: repeat pairs 1-2 on trial 2,
  # then present all four again on trial 3, so 1-2 and 3-4 differ in
  # familiarity within that trial.
  dat <- xslData(train = list(
    words   = list(c(1, 2, 3, 4), c(1, 2), c(1, 2, 3, 4)),
    objects = list(c(1, 2, 3, 4), c(1, 2), c(1, 2, 3, 4))
  ), label = "repeat-then-full")
  plain <- xsl_run(uncfam(X = .1, B = .98, C = 1), dat)
  dampened <- xsl_run(uncfam_gamma(X = .1, B = .98, C = 1, gamma = 0.3), dat)
  amplified <- xsl_run(uncfam_gamma(X = .1, B = .98, C = 1, gamma = 2), dat)
  expect_false(isTRUE(all.equal(dampened$fits[[1]]$matrix, plain$fits[[1]]$matrix)))
  expect_false(isTRUE(all.equal(amplified$fits[[1]]$matrix, plain$fits[[1]]$matrix)))
})

test_that("uncfam_predictive()'s unnormalized update never drives an association negative", {
  # regression test: without the pmax(..., 0) floor documented in
  # model-uncfam_predictive.R, a large learning rate can overshoot an
  # association below 0, which inflates the next trial's prediction error
  # and diverges further -- the file's own comment reports this reaching
  # +-1e300 within a 45-trial run for some DEoptim candidate draws. An
  # aggressive (well outside normal fitting bounds) X/B still shouldn't ever
  # produce a negative or non-finite association.
  mod <- uncfam_predictive(X = 50, B = 15, C = 1)
  result <- xsl_run(mod, xsl_datasets[[1]])
  m <- result$fits[[1]]$matrix
  expect_true(all(is.finite(m)))
  expect_true(all(m >= 0))
})

test_that("uncfam_predictive() never pushes an association above beta (1)", {
  # regression test: on a word's first exposure the prediction error is ~beta
  # and is scaled by exp(B * entropy) of the word's row, which update_known()
  # spreads over every object seen so far -- uncapped, a word introduced
  # after many others jumped to thousands in one trial. Here: 18 words each
  # shown once with one object, in sequence.
  dat <- xslData(train = list(words = as.list(1:18), objects = as.list(1:18)))
  ctrl <- xslControl(keep_traj = TRUE)
  mod <- uncfam_predictive(X = .8, B = 1.6, C = .7)
  fit <- mod$model(mod$params, dat$train, ctrl)
  expect_true(all(vapply(fit$traj, \(m) all(m <= 1), logical(1))))
  expect_equal(unname(fit$traj[[18]][18, 18]), 1)
})

test_that("tilles() carries a word's alpha forward across trials it doesn't appear on", {
  # regression test: alpha was declared fresh (rep(NA, voc_sz)) inside the
  # trial loop and only ever filled in for words on the *current* trial
  # (tr_w). But the "other old" words update (a word seen before, not on
  # this trial) needs alpha[other_old_w] -- words never in tr_w on this
  # trial -- which was therefore always NA, crashing downstream in
  # shannon_entropy's `if`. alpha now persists across trials as per-word
  # state, updated only for the current trial's words, so absent words keep
  # their own last-computed value.
  mod <- tilles(x = .5, b = .8, alpha_0 = .85)
  result <- tryCatch(xsl_run(mod, xsl_datasets[[1]]), error = function(e) e)
  expect_false(inherits(result, "error"))
  expect_true(all(is.finite(result$fits[[1]]$matrix)))
})

test_that("tilles() works on an asymmetric dataset (word count != object count)", {
  # regression test: `r <- matrix(0, voc_sz, voc_sz)` should have been
  # matrix(0, voc_sz, ref_sz) (matching m's own dimensions, and the second
  # r declared later in the same function) -- a copy-paste bug that only
  # breaks assignments like r[w, tr_o] <- ... when an object index exceeds
  # voc_sz, i.e. whenever voc_sz != ref_sz.
  koehne <- Filter(function(d) d$label == "Koehne2013-aaappp", xsl_datasets)[[1]]
  expect_false(length(unique(unlist(koehne$train$words))) ==
                 length(unique(unlist(koehne$train$objects))))
  result <- tryCatch(xsl_run(tilles(x = .5, b = .8, alpha_0 = .85), koehne),
                     error = function(e) e)
  expect_false(inherits(result, "error"))
})

test_that("tilles() doesn't divide by zero when an old word has no prior mass on this trial's objects", {
  # regression test: eq 5.1's flux <- sum(m[w,other_old_o]) / sum(m[w,tr_o])
  # assumes a currently-present, previously-seen word already has some
  # association with at least one of this trial's objects. That's not
  # guaranteed -- a word can be "old" yet paired with an entirely new-to-it
  # set of objects -- giving sum(m[w,tr_o]) == 0 and thus Inf, which then
  # multiplies by m[w,tr_o] == 0 to produce NaN. Reproduces dataset "206"'s
  # trial 3 exactly (word 18/3 reappear paired with objects they've never
  # been associated with), which failed on every one of 40 random parameter
  # draws before the fix.
  cond206 <- Filter(function(d) d$label == "206", xsl_datasets)[[1]]
  result <- tryCatch(xsl_run(tilles(x = .5, b = .5, alpha_0 = .5), cond206),
                     error = function(e) e)
  expect_false(inherits(result, "error"))
  expect_true(all(is.finite(result$fits[[1]]$matrix)))
})

test_that("kalman_filter()'s Kalman gain matches its closed-form definition and shrinks with confidence", {
  # exercises the model's core claim: an adaptive learning rate that starts
  # large under uncertainty and shrinks as confidence accumulates. Hand-
  # derived from the model's own update equations (gain = sigma2/(sigma2 +
  # sigma2_obs); mu <- mu + gain*(1-mu); sigma2 <- (1-gain)*sigma2, with
  # sigma2 += tau2 diffusion each trial before the update).
  dat <- xslData(
    train = list(words = list(c(1, 2), c(1, 2)), objects = list(c(1, 2), c(1, 2))),
    accuracy = c(0.5, 0.5),
    label = "two trial test"
  )
  tau2 <- .05; sigma2_obs <- 1; sigma2_0 <- 1
  mod <- kalman_filter(tau2 = tau2, sigma2_obs = sigma2_obs, sigma2_0 = sigma2_0)
  result <- xsl_run(mod, dat)

  sigma2_1 <- sigma2_0 + tau2
  gain_1 <- sigma2_1 / (sigma2_1 + sigma2_obs)
  mu_1 <- gain_1 # mu starts at 0, target is 1
  sigma2_after_1 <- (1 - gain_1) * sigma2_1

  sigma2_2 <- sigma2_after_1 + tau2
  gain_2 <- sigma2_2 / (sigma2_2 + sigma2_obs)
  mu_2 <- mu_1 + gain_2 * (1 - mu_1)

  expect_equal(unname(result$fits[[1]]$matrix[1, 1]), mu_2)
  expect_true(gain_2 < gain_1) # learning rate shrinks as confidence accumulates
})

test_that("softmax_rl() learns to prefer a consistently-confirmed referent over a rarely-confirmed one", {
  # word 1 always co-occurs with object 1 (always confirmed if guessed) but
  # only co-occurs with object 2 on 1 of 10 trials (rarely confirmed) -- a
  # reasonable learning rate/temperature should end up strongly favoring
  # object 1's Q-value over object 2's, averaged across many simulations
  dat <- xslData(
    train = list(
      words = as.list(rep(1, 10)),
      objects = c(as.list(rep(1, 9)), list(c(1, 2)))
    ),
    accuracy = c(0.9),
    label = "confirmation preference test"
  )
  mod <- softmax_rl(alpha = .3, beta = 3)
  result <- xsl_run(mod, dat, control = xslControl(n_sim = 500))
  q <- result$fits[[1]]$matrix
  expect_true(q[1, 1] > q[1, 2])
})

test_that("softmax_rl() rewards a guess against object labels, not their positions", {
  # regression: the reward check was `proposal %in% tr_o`, comparing a column
  # *position* (1..ref_sz) against the trial's object *labels*. For
  # xsl_datasets the labels happen to be 1..18 so it worked, but on any
  # dataset with non-integer (or non-contiguous) object labels every reward
  # was 0 and the Q-matrix stayed identically zero.
  dat <- xslData(
    train = list(words = as.list(rep("dog", 12)),
                 objects = as.list(rep("kitty", 12))),   # "dog" always with "kitty"
    accuracy = c(0.9), label = "string-label reward test"
  )
  q <- xsl_run(softmax_rl(alpha = .3, beta = 3), dat,
               control = xslControl(n_sim = 50))$fits[[1]]$matrix
  expect_gt(max(q), 0)                       # something got rewarded
  expect_equal(unname(which.max(q["dog", ])), unname(which(colnames(q) == "kitty")))
})

test_that("softmax_rl() only updates the sampled action, not every co-occurring pair", {
  # regression/design check: unlike every other model in this package,
  # which updates the full word x object cross-product on a trial, this
  # model should only ever move the ONE q-cell it actually sampled and
  # scored -- so across many single-trial simulations, the total number of
  # nonzero q-cells changed should equal (not exceed) the number of words
  # x sims, never words x objects x sims
  dat <- xslData(
    train = list(words = list(c(1, 2)), objects = list(c(1, 2, 3))),
    accuracy = c(0.5, 0.5),
    label = "sparse update test"
  )
  mod <- softmax_rl(alpha = .5, beta = 1)
  result <- xsl_run(mod, dat, control = xslControl(n_sim = 1))
  q <- result$fits[[1]]$matrix
  # exactly one nonzero cell per word (the one it sampled), never both
  # candidates updated for the same word in a single trial
  expect_equal(sum(q[1, ] != 0), 1)
  expect_equal(sum(q[2, ] != 0), 1)
})

test_that("uncfam_sampling()/multi_sampling() survive an utterance with no objects present", {
  # a non-referential utterance (words but no visible objects) leaves the
  # per-word sampling weights all zero; sample(prob = <all zeros>) used to
  # error ("too few positive probabilities"), which made both models unable
  # to run on a naturalistic corpus. Now such a trial is a no-op (decay only).
  dat <- xslData(
    train = list(
      # trial 3: words heard but no objects visible (non-referential)
      words = list(c(1, 2), c(1, 2), c(1, 2), c(1, 2)),
      objects = list(c(1, 2), c(1, 2), integer(0), c(1, 2))
    ),
    accuracy = c(0.5, 0.5),
    label = "objectless-trial test"
  )

  for (mod in list(uncfam_sampling(X = .1, C = 1, B = .98, K = 5),
                   multi_sampling(C = 1, X = .1, B = .98, K = 5))) {
    res <- xsl_run(mod, dat, control = xslControl(n_sim = 5))
    m <- res$fits[[1]]$matrix
    expect_false(anyNA(m))
    expect_true(all(is.finite(m)))
    expect_gt(sum(m), 0)   # the objectless trial didn't wipe out learning
  }
})

test_that("uncfam_sampling()/multi_sampling() handle a repeated word/object within a trial", {
  # regression test for the trial-scoped-submatrix optimization: the model
  # only builds entropy/weighting/update arrays over the trial's *distinct*
  # words/objects (cheap for large vocabularies), but must still process
  # every occurrence in tr_w/tr_o -- including repeats, which naturalistic
  # corpus utterances have and controlled lab trials don't. Checked against
  # a hand-verified noise floor: same-seed old-vs-new code differs far less
  # than the model's own seed-to-seed Monte Carlo variance.
  dat <- xslData(
    train = list(
      words = list(c(1, 2), c(1, 1, 3), c(2, 3), c(1, 2, 2), c(3, 1)),
      objects = list(c(1, 2), c(1, 3, 3), c(2, 3), c(1, 2, 2), c(3, 1))
    ),
    accuracy = c(0.3, 0.3, 0.3),
    label = "repeat-within-trial test"
  )

  for (mod in list(uncfam_sampling(X = .1, C = 1, B = .98, K = 1),
                   uncfam_sampling(X = .1, C = 1, B = .98, K = 2),
                   multi_sampling(C = 1, X = .2, B = .3, K = 1),
                   multi_sampling(C = 1, X = .2, B = .3, K = 2))) {
    res <- xsl_run(mod, dat, control = xslControl(n_sim = 5))
    m <- res$fits[[1]]$matrix
    expect_false(anyNA(m))
    expect_true(all(is.finite(m)))
    expect_gt(sum(m), 0)
  }
})

test_that("fgt2009()'s scoring kernel matches the Python `wordlearn` reference", {
  # The log-posterior kernel (fgt_score_map) is a direct port of
  # wordlearn/model.py::score_lexicon. These values were computed by the
  # Python package on this exact 6-trial corpus (words == objects each
  # trial: (1,2) (1,3) (2,3) x2), gamma = 0.1, kappa = 0.05, and must be
  # reproduced to numerical precision for the port to be faithful.
  raw <- list(c(1, 2), c(1, 3), c(2, 3), c(1, 2), c(1, 3), c(2, 3))
  corpus <- lapply(raw, function(p) list(words = p, objects = p))
  cache <- fgt_build_intent_cache(corpus, gamma = 0.1)
  m <- function(...) {
    a <- list(...)
    if (!length(a)) matrix(integer(0), 2, 0) else matrix(unlist(a), 2)
  }
  expect_equal(fgt_score_map(m(), cache, 3, 3, alpha = 0.5, kappa = 0.05),
               -13.1833, tolerance = 1e-4)
  expect_equal(fgt_score_map(m(c(1, 1)), cache, 3, 3, alpha = 0.5, kappa = 0.05),
               -17.7007, tolerance = 1e-4)
  expect_equal(
    fgt_score_map(m(c(1, 1), c(2, 2), c(3, 3)), cache, 3, 3,
                  alpha = 1, kappa = 0.05),
    -15.802, tolerance = 1e-3)
})

test_that("fgt2009()'s Gibbs sampler targets the exact posterior (3x3 enumeration)", {
  # the whole space of lexicons over 3 words x 3 objects is 2^9 = 512, so the
  # posterior edge marginals can be computed exactly by enumeration. The
  # sampler's marginals must match them within Monte Carlo tolerance -- this
  # is what validates that the moves leave the right distribution invariant.
  pairs <- list(c(1, 2), c(1, 3), c(2, 3))
  corpus <- unlist(lapply(1:4, function(r) {
    lapply(pairs, function(q) list(words = q, objects = q))
  }), recursive = FALSE)
  cache <- fgt_build_intent_cache(corpus, gamma = 1)
  alpha <- 1.5; kappa <- 0.5

  ae <- expand.grid(w = 1:3, o = 1:3)
  lp <- vapply(0:511, function(mask) {
    sel <- which(as.integer(intToBits(mask)[1:9]) == 1)
    mp <- if (length(sel)) rbind(ae$w[sel], ae$o[sel]) else matrix(integer(0), 2, 0)
    fgt_score_map(mp, cache, 3, 3, alpha, kappa)
  }, numeric(1))
  post <- exp(lp - max(lp)); post <- post / sum(post)
  exact <- matrix(0, 3, 3)
  for (mask in 0:511) {
    sel <- which(as.integer(intToBits(mask)[1:9]) == 1)
    if (length(sel)) {
      exact[cbind(ae$w[sel], ae$o[sel])] <-
        exact[cbind(ae$w[sel], ae$o[sel])] + post[mask + 1]
    }
  }

  sf <- function(mp) fgt_score_map(mp, cache, 3, 3, alpha, kappa)
  sp <- function(mp, s) fgt_score_map(mp, cache, 3, 3, alpha, kappa, sit_indices = s)
  gibbs <- fgt_run_gibbs(cache, 3, 3, alpha, 1, kappa, sf, sp,
                         n_chains = 4, n_warmup = 200, n_samples = 1500, seed = 1)
  expect_lt(max(abs(gibbs - exact)), 0.08)
})

test_that("fgt2009() learns an unambiguous pairing and rejects its distractors", {
  # word 1's referent (object 1) is present on every trial word 1 appears in,
  # while its trial-mates rotate through the other objects -- so the joint
  # posterior should put clear mass on edge (1, 1) and little on (1, other).
  set.seed(1)
  trials <- list()
  distractors <- c(2, 3, 4, 5, 6)
  for (rep in 1:4) for (d in distractors) {
    trials[[length(trials) + 1]] <- list(words = c(1, d), objects = c(1, d))
  }
  dat <- xslData(train = list(words = lapply(trials, `[[`, "words"),
                              objects = lapply(trials, `[[`, "objects")),
                 accuracy = rep(0.8, 6), label = "one clear pair")

  m <- xsl_run(fgt2009(alpha = 1, n_warmup = 80, n_samples = 200), dat)$fits[[1]]$matrix
  expect_gt(m[1, 1], 0.75)
  expect_true(all(m[1, distractors] < m[1, 1]))
})

test_that("fgt2009() is a batch model: control$reps does not change the result", {
  # unlike the incremental models, fgt2009 does joint inference over the whole
  # corpus and has no learning trajectory -- repeating the training data
  # should be a no-op (same seed -> identical posterior).
  dat <- get_example_unambiguous_condition()
  a <- xsl_run(fgt2009(alpha = 1, n_warmup = 40, n_samples = 80), dat,
               control = xslControl(reps = 1))
  b <- xsl_run(fgt2009(alpha = 1, n_warmup = 40, n_samples = 80), dat,
               control = xslControl(reps = 5))
  expect_equal(a$fits[[1]]$matrix, b$fits[[1]]$matrix)
})

test_that("fgt2009() maps an empty-lexicon posterior to chance, not NaN", {
  # a large lexicon-size prior drives the posterior to the empty lexicon;
  # the Jeffreys-smoothed marginal matrix must still be strictly positive so
  # get_perf()/mafc_test() return chance performance rather than 0/0.
  dat <- get_example_ambiguous_condition()
  r <- xsl_run(fgt2009(alpha = 50, n_warmup = 40, n_samples = 80), dat)
  m <- r$fits[[1]]$matrix
  expect_true(all(m > 0))
  expect_false(anyNA(r$fits[[1]]$perf))
  # empty lexicon -> ~uniform 4x4 matrix -> get_perf() ~ 1/4 (chance)
  expect_equal(unname(r$fits[[1]]$perf), rep(0.25, 4), tolerance = 0.02)
})

test_that("fgt2009_sweep_alpha() returns per-alpha SSE", {
  out <- fgt2009_sweep_alpha(get_example_ambiguous_condition(),
                             alphas = c(1, 8),
                             n_warmup = 30, n_samples = 60)
  expect_s3_class(out, "data.frame")
  expect_equal(out$alpha, c(1, 8))
  expect_true(all(is.finite(out$sse)))
})

test_that("minerva2()/todam()/rem() learn an unambiguous pairing above chance", {
  # each word co-occurs with its correct referent twice (vs. once with each
  # distractor); a memory model that's actually sensitive to co-occurrence
  # frequency should end up with diag(m) as each row's max most of the time
  dat <- get_example_unambiguous_condition()
  set.seed(42)
  mods <- list(minerva2 = minerva2(X = 5, D = 50),
              todam = todam(X = 5, D = 100),
              rem = rem(g = 0.4, u = 0.3, c = 0.7, w = 12))
  for (nm in names(mods)) {
    r <- xsl_run(mods[[nm]], dat, control = xslControl(n_sim = 100))
    m <- r$fits[[1]]$matrix
    expect_true(all(is.finite(m)), info = nm)
    perf <- r$fits[[1]]$perf
    expect_gt(mean(perf), 1 / 3, label = paste(nm, "mean accuracy"))
  }
})

test_that("minerva2() compares the echo's object half against object vectors, not the whole echo", {
  # regression test: the standalone prototype this was ported from compared
  # the full 2D echo content vector against each D-dim object vector
  # (mismatched lengths -- R recycles instead of erroring), silently folding
  # the word half of the echo into the object comparison. Sanity check here:
  # a word that always co-occurs with one object should overwhelmingly
  # prefer that object over one it's never been paired with.
  dat <- xslData(
    train = list(words = as.list(rep(1, 8)), objects = as.list(rep(1, 8))),
    accuracy = c(0.9), label = "single pairing"
  )
  set.seed(7)
  r <- xsl_run(minerva2(X = 8, D = 50), dat, control = xslControl(n_sim = 50))
  m <- r$fits[[1]]$matrix
  expect_equal(unname(which.max(m[1, ])), 1)
})

test_that("todam()'s first-trial attention weighting doesn't propagate NaN", {
  # regression test: the "v2" prototype this was ported from computed each
  # trial's attention weights as a raw cos_sim(item, M), which is 0/0 = NaN
  # on trial 1 (M starts at the zero vector) and poisons M with NaN from
  # then on. A single-trial run must stay finite.
  dat <- xslData(train = list(words = list(c(1, 2)), objects = list(c(1, 2))),
                 accuracy = c(0.5, 0.5), label = "first trial")
  set.seed(3)
  m <- xsl_run(todam(X = 5, D = 50), dat, control = xslControl(n_sim = 10))$fits[[1]]$matrix
  expect_true(all(is.finite(m)))
})

test_that("rem()'s per-simulation choice weights are row-normalized before aggregation", {
  # regression test: REM's summed likelihood-ratio odds are heavy-tailed (a
  # lucky match on a single rare feature value can inflate one trace's odds
  # by orders of magnitude), so raw per-simulation magnitudes for the same
  # word/object pair can span 10-100000+ across simulations. xsl_run()
  # aggregates simulations by summing their matrices, which would let
  # whichever simulation got lucky dominate the n_sim-simulation average.
  # Each simulation's returned matrix must instead be row-normalized (one
  # probability distribution over objects per word), so summing n_sim of
  # them gives every simulated "subject" equal weight: rowSums(m) == n_sim
  # for every word that appeared in training.
  dat <- get_example_unambiguous_condition()
  control <- xslControl(n_sim = 40)
  m <- xsl_run(rem(g = 0.4, u = 0.3, c = 0.7, w = 12), dat, control = control)$fits[[1]]$matrix
  expect_equal(unname(rowSums(m)), rep(control$n_sim, nrow(m)), tolerance = 1e-6)
})

test_that("propose_but_verify() proposes from the objects on a single-object trial", {
  # regression: new hypotheses were drawn with sample(tr_o, n, replace = TRUE).
  # Models receive object *positions*, so on a trial with one object tr_o is a
  # single integer k, and sample(k, n) draws from 1:k -- a word seen alone with
  # object 8 hypothesized object 8 only ~1/8 of the time. Word 8's only exposure
  # here is alone with object 8, so every simulation must hypothesize object 8.
  dat <- xslData(
    train = list(words = list(1:7, 8L), objects = list(1:7, 8L)),
    label = "single-object proposal test"
  )
  m <- xsl_run(propose_but_verify(alpha = 1, alpha_increase = 0), dat,
               control = xslControl(n_sim = 50))$fits[[1]]$matrix
  expect_equal(unname(m["8", "8"] / sum(m["8", ])), 1, tolerance = 1e-6)
})

test_that("pursuit() re-proposes from the objects on a single-object trial", {
  # regression: when a word's strongest hypothesis was absent from a trial, its
  # new hypothesis was drawn with sample(tr_o, 1) -- which, on a single-object
  # trial, samples from 1:k rather than from the one object present. Word 8
  # first hypothesizes object 1 (trial 2, where 1 is the only object), then is
  # seen alone with object 8 (trial 3): object 1 is absent, so the new
  # hypothesis can only be object 8 -- never any of objects 2-7, which word 8
  # never co-occurred with.
  dat <- xslData(
    train = list(words = list(1:7, 8L, 8L), objects = list(1:7, 1L, 8L)),
    label = "single-object re-proposal test"
  )
  n_sim <- 50
  lex <- xsl_run(pursuit(gamma = .5, threshold = .5, lambda = .01), dat,
                 control = xslControl(n_sim = n_sim))$fits[[1]]$matrix
  expect_equal(unname(lex["8", "8"]), n_sim, tolerance = 1e-6)  # added to the lexicon every time
  expect_lt(sum(lex["8", as.character(2:7)]), 1e-6)              # never anything off-trial
})