inst/doc/corpora.R

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

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

knitr::opts_chunk$set(
  echo = TRUE,
  collapse = TRUE,
  comment = "#>",
  fig.width = 6,
  fig.height = 4
)

## -----------------------------------------------------------------------------
rollins_corpus$data
fm_corpus$data

## -----------------------------------------------------------------------------
names(rollins_corpus)
names(fm_corpus)

## -----------------------------------------------------------------------------
rollins_corpus$data$train$words[[1]]
rollins_corpus$data$train$objects[[1]]
str(rollins_corpus$gold)

## -----------------------------------------------------------------------------
res <- suppressWarnings(xsl_run(baseline(), rollins_corpus$data))
m <- res$fits[[1]]$matrix
dim(m)

# co-occurrence counts for one word (this corpus is a picture-book session,
# so the objects are animals and toys -- "moocow", "piggie", etc.)
sort(m["moocow", ], decreasing = TRUE)[1:4]

## -----------------------------------------------------------------------------
get_fscore(m / rowSums(m), threshold = 0.1, gold_lexicon = rollins_corpus$gold)

## -----------------------------------------------------------------------------
roc <- get_roc(m, gold_lexicon = rollins_corpus$gold)
head(roc, 3)

get_roc_max(m, gold_lexicon = rollins_corpus$gold)
plot_roc(m, gold_lexicon = rollins_corpus$gold)

## -----------------------------------------------------------------------------
assoc_models <- list(
  baseline        = baseline(),
  decay           = decay(C = 0.99),
  rescorla_wagner = rescorla_wagner(C = 1, alpha = 0.1, beta = 0.1, lambda = 1),
  fazly           = fazly(lambda = 1e-5, beta = 8500)
)

sapply(assoc_models, function(mod) {
  mm <- suppressWarnings(xsl_run(mod, rollins_corpus$data)$fits[[1]]$matrix)
  round(get_roc_max(mm, gold_lexicon = rollins_corpus$gold), 3)
})

## ----fgt-run, eval = FALSE----------------------------------------------------
# res <- xsl_run(
#   fgt2009(alpha = 3, gamma = 0.1, kappa = 0.05),
#   rollins_corpus$data
# )
# m_fgt <- res$fits[[1]]$matrix
# 
# # the learned lexicon: edges with posterior probability > 0.5
# edges <- which(m_fgt > 0.5, arr.ind = TRUE)
# data.frame(word   = rownames(m_fgt)[edges[, 1]],
#            object = colnames(m_fgt)[edges[, 2]],
#            prob   = round(m_fgt[edges], 2))
# #>       word object prob
# #> 1     bear   bear 1.00     # correct
# #> 2   bottle   bear 1.00     # "baby bottle" co-occurs with the bear
# #> 3  bigbird   bird 1.00     # correct
# #> 4     book   book 1.00     # correct
# #> 5   moocow    cow 1.00     # correct
# #> 6      hat    hat 1.00     # correct
# #> 7     oink    pig 1.00     # correct
# #> ...                        # 28 edges total
# 
# get_roc_max(m_fgt, gold_lexicon = rollins_corpus$gold)
# #> [1] 0.454   # MCMC: expect a little run-to-run variation

## ----sweep, eval = FALSE------------------------------------------------------
# sweep <- fgt2009_sweep_alpha(
#   rollins_corpus$data,
#   alphas = c(2, 4, 6, 9, 14),
#   gold   = rollins_corpus$gold,
#   gamma = 0.1, kappa = 0.05,
#   n_warmup = 50, n_samples = 120      # a lighter sampler for the sweep
# )
# sweep

## ----sweep-precomputed, echo = FALSE------------------------------------------
# precomputed -- each row is a full MCMC run (~40s); numbers wobble a little
# from run to run because the sampler is stochastic.
sweep <- data.frame(
  alpha = c(2, 4, 6, 9, 14),
  f_max = c(0.429, 0.404, 0.390, 0.400, 0.290)
)
plot(sweep$alpha, sweep$f_max, type = "b", pch = 19,
     xlab = expression(alpha), ylab = "best-threshold F",
     main = "fgt2009 on the Rollins corpus (gamma = 0.1)")

## -----------------------------------------------------------------------------
fm_corpus$data$train$words[[1]]
fm_corpus$intents[[1]]

mean(lengths(fm_corpus$intents) == 0)   # fraction non-referential

## -----------------------------------------------------------------------------
lengths(lapply(list(curated    = fm_corpus$gold,
                    strict     = fm_corpus$gold_variants$strict,
                    permissive = fm_corpus$gold_variants$permissive),
               `[[`, "words"))

## ----fm-score-----------------------------------------------------------------
m_fm <- suppressWarnings(xsl_run(baseline(), fm_corpus$data)$fits[[1]]$matrix)

sapply(list(curated    = fm_corpus$gold,
            strict     = fm_corpus$gold_variants$strict,
            permissive = fm_corpus$gold_variants$permissive),
       function(g) round(get_roc_max(m_fm, gold_lexicon = g), 3))

## ----comparison-table, echo = FALSE-------------------------------------------
# precomputed by tests/bakeoff_comparison/corpus_gold_comparison.R
cmp <- data.frame(
  model = c("bayesian_decay", "fazly", "fgt2009_rsa", "fgt2009",
            "uncfam_sampling", "multi_sampling", "uncfam", "uncfam_gamma",
            "uncfam_elimination", "uncfam_attention", "propose_but_verify",
            "softmax_rl", "pursuit", "guess_and_test", "baseline", "minerva2",
            "rescorla_wagner", "decay", "kalman_filter", "uncfam_predictive",
            "todam", "tilles"),
  Rollins = c(0.449, 0.450, 0.395, 0.385, 0.394, 0.394, 0.377, 0.377,
              0.377, 0.377, 0.409, 0.376, 0.400, 0.396, 0.377, 0.359,
              0.312, 0.320, 0.303, 0.235, 0.174, 0.080),
  FM = c(0.450, 0.407, 0.421, 0.421, 0.360, 0.352, 0.360, 0.360,
         0.360, 0.351, 0.318, 0.336, 0.307, 0.304, 0.268, 0.267,
         0.290, 0.272, 0.211, 0.185, 0.048, 0.048)
)
knitr::kable(cmp, digits = 3,
             caption = "Best-threshold F of the learned lexicon vs. the gold lexicon.")

## ----fits-table, echo = FALSE-------------------------------------------------
# precomputed by tests/bakeoff_comparison/corpus_gold_fits.R
fit <- data.frame(
  model = c("bayesian_decay", "fgt2009", "fgt2009_rsa", "softmax_rl", "fazly",
            "uncfam_gamma", "uncfam_attention", "tilles", "uncfam",
            "guess_and_test", "uncfam_elimination", "propose_but_verify",
            "rescorla_wagner", "decay", "kalman_filter", "uncfam_predictive"),
  Rollins_default = c(0.449, NA, NA, 0.360, 0.450, 0.377, 0.377, 0.080, 0.377,
                      0.372, 0.377, 0.400, 0.312, 0.320, 0.303, 0.235),
  Rollins_fitted  = c(0.465, 0.452, 0.447, 0.447, 0.463, 0.450, 0.420, 0.427,
                      0.420, 0.440, 0.404, 0.438, 0.389, 0.382, 0.382, 0.333),
  FM_default = c(0.450, NA, NA, 0.299, 0.407, 0.360, 0.351, 0.048, 0.360,
                 0.292, 0.360, 0.325, 0.290, 0.272, 0.211, 0.185),
  FM_fitted  = c(0.560, 0.529, 0.515, 0.429, 0.412, 0.425, 0.417, 0.400, 0.388,
                 0.368, 0.400, 0.360, 0.343, 0.288, 0.275, 0.233)
)
knitr::kable(fit, digits = 3,
             caption = "Best-threshold F: registry default vs. fit to the corpus.")