## ----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.")