6.3 Tuning number of topics
https://juliasilge.com/blog/evaluating-stm/
To compare topic models (not necessarily LDA) with different number of topic \(K\), we need first to propose metrics for comparison or topic quality. Semantic coherence s maximized when the most probable words in a given topic frequently co-occur together, which correlates human judgement of topic quality.
https://rdrr.io/cran/stm/man/exclusivity.html
data("data_corpus_inaugural", package = "quanteda")
inaugural_counts <- tidy(data_corpus_inaugural) %>%
mutate(document = str_c(Year, President, sep = "_")) %>%
unnest_tokens(word, text) %>%
anti_join(stop_words) %>%
count(document, word, sort = TRUE)
inaugural_dfm <- inaugural_counts %>%
cast_dfm(document = document, term = word, value = n)
It took several minutes and quite a lot computing power to run the following code. So
library(furrr)
plan(multiprocess)
models <- tibble(K = 2:6) %>%
mutate(topic_model = future_map(K, ~ stm(inaugural_dfm,
init.type = "Spectral",
K = .,
verbose = FALSE)))
models
#> # A tibble: 5 x 2
#> K topic_model
#> <int> <list>
#> 1 2 <STM>
#> 2 3 <STM>
#> 3 4 <STM>
#> 4 5 <STM>
#> 5 6 <STM>
heldout <- make.heldout(inaugural_dfm)
k_result <- models %>%
mutate(exclusivity = map(topic_model, exclusivity),
semantic_coherence = map(topic_model, semanticCoherence, inaugural_dfm),
eval_heldout = map(topic_model, eval.heldout, heldout$missing),
residual = map(topic_model, checkResiduals, inaugural_dfm),
bound = map_dbl(topic_model, function(x) max(x$convergence$bound)),
lfact = map_dbl(topic_model, function(x) lfactorial(x$settings$dim$K)),
lbound = bound + lfact,
iterations = map_dbl(topic_model, function(x) length(x$convergence$bound)))
k_result %>%
transmute(K,
`Lower bound` = lbound,
Residuals = map_dbl(residual, "dispersion"),
`Semantic coherence` = map_dbl(semantic_coherence, mean),
`Held-out likelihood` = map_dbl(eval_heldout, "expected.heldout")) %>%
pivot_longer(-K, names_to = "metrics", values_to = "value") %>%
ggplot(aes(K, value, color = metrics)) +
geom_line(size = 1.5) +
facet_wrap(~ metrics, scales = "free_y")