## ----setup, include = FALSE---------------------------------------------------
library(XSLmodels)

knitr::opts_chunk$set(
  echo = TRUE,
  collapse = TRUE,
  comment = "#>"
)

## ----model-function-----------------------------------------------------------
rich_get_richer_model <- function(params, data, control) {
  C <- params[["C"]]
  eps <- params[["eps"]]
  voc <- sort(unique(unlist(data$words)))
  ref <- sort(unique(unlist(data$objects)))
  m <- if (is.null(control$start_matrix)) matrix(0, length(voc), length(ref)) else control$start_matrix
  dimnames(m) <- list(voc, ref)
  perf <- matrix(0, control$reps, length(voc))
  traj <- list()
  for (rep in seq_len(control$reps)) {
    for (t in seq_along(data$words)) {
      w <- stats::na.omit(data$words[[t]])
      o <- stats::na.omit(data$objects[[t]])
      m <- m * C
      if (length(w) && length(o)) {
        share <- m[w, o, drop = FALSE] + eps
        m[w, o] <- m[w, o] + share / rowSums(share)
      }
      if (isTRUE(control$keep_traj)) traj[[length(traj) + 1]] <- m
    }
    perf[rep, ] <- get_perf(m)
  }
  xslFit(perf = perf, matrix = m, traj = traj)
}

## ----constructor--------------------------------------------------------------
rich_get_richer <- function(C, eps) {
  xslMod(name = "rich_get_richer",
         description = "Shares each word's weight in proportion to its current associations",
         model = rich_get_richer_model, params = list(C = C, eps = eps),
         stochastic = FALSE, supports_start_matrix = TRUE)
}

## ----run----------------------------------------------------------------------
labels <- vapply(xsl_datasets, `[[`, "", "label")
conds <- xsl_datasets[labels %in% c("215", "216", "219", "220", "225")]
run <- xsl_run(rich_get_richer(C = .97, eps = .5), conds)
run$sse
xsl_run(baseline(), conds)$sse

## ----fit----------------------------------------------------------------------
fit <- xsl_fit(rich_get_richer(C = .97, eps = .5), conds,
               lower = c(.5, .001), upper = c(1, 10), free = c("C", "eps"),
               n_restarts = 2, seed = 1,
               deoptim_control = DEoptim::DEoptim.control(NP = 20, itermax = 15, trace = FALSE))
fit[[1]]$optim$bestmem
fit[[1]]$optim$bestval
fit[[1]]$restarts
fitted <- update_params(rich_get_richer(C = .97, eps = .5), fit[[1]]$optim$bestmem,
                        free = c("C", "eps"))

## ----checks-------------------------------------------------------------------
corners <- list(c(.5, .001), c(.5, 10), c(1, .001), c(1, 10))
runs <- lapply(corners, \(p) xsl_run(rich_get_richer(C = p[1], eps = p[2]), xsl_datasets))
all(vapply(runs, \(r) all(vapply(r$fits, \(f) all(is.finite(f$matrix)) &&
                                   all(f$perf >= 0 & f$perf <= 1), TRUE)), TRUE))

## ----dataset------------------------------------------------------------------
my_data <- xslData(
  train = list(words = list(c("dax", "wug"), c("dax", "fep"), c("wug", "fep"), "dax"),
               objects = list(c("dax", "wug"), c("dax", "fep"), c("wug", "fep"), "dax")),
  test = list(words = list("dax", "wug", "fep"),
              objects = list(c("dax", "wug", "fep"), c("dax", "wug", "fep"), c("dax", "wug", "fep"))),
  accuracy = c(.8, .5, .4), n_subj = 10,
  # columns: objects in sorted order (dax, fep, wug)
  response_matrix = rbind(c(8, 1, 1), c(3, 2, 5), c(4, 4, 2)),
  label = "toy", condition = "3 words, 1-2 per trial")
my_data

## ----score--------------------------------------------------------------------
f <- xsl_run(fitted, my_data)$fits[[1]]
f$perf
ch <- choice_probabilities(f$matrix, my_data)
ch
# what the model predicts, and what people chose, for "wug"
wug <- rbind(model = ch$p[[2]], people = ch$counts[[2]] / sum(ch$counts[[2]]))
colnames(wug) <- ch$alternatives[[2]]
round(wug, 2)