如何在R中评估不同主题数K下的BTM主题模型？

针对BTM包缺少内置评估指标的问题，以下是手动实现主题一致性和困惑度的方案，可辅助选择最优主题数K：

一、主题一致性（Topic Coherence）实现 #

主题一致性反映主题内词的语义相关性，这里采用UCI方法（基于词共现统计）：

1. 提取模型主题词 #

从训练好的BTM模型中获取每个主题的Top-N核心词：

# 每个主题取前10个核心词
top_terms_per_topic <- topTerms(model, n = 10)

2. 构建词共现矩阵 #

基于原始分词语料，统计词对在同一文档内的共现频次：

library(tm)
# 转换为文档-词矩阵
dtm <- DocumentTermMatrix(Corpus(VectorSource(df_title_tok)))
# 计算词-词共现次数
cooccur_matrix <- crossprod(t(dtm))
diag(cooccur_matrix) <- 0  # 剔除词自身的共现统计

3. 计算主题一致性得分 #

对每个主题的Top词组合，计算两两共现频次的对数和并归一化：

compute_topic_coherence <- function(top_terms, cooccur_mat) {
  coherence_sum <- 0
  term_count <- length(top_terms)
  pair_count <- term_count * (term_count - 1) / 2
  
  if (pair_count == 0) return(0)
  
  for (i in 1:(term_count-1)) {
    for (j in (i+1):term_count) {
      w1 <- top_terms[i]
      w2 <- top_terms[j]
      # 跳过共现矩阵中不存在的词对
      if (!w1 %in% rownames(cooccur_mat) || !w2 %in% colnames(cooccur_mat)) next
      # 累加对数共现次数（+1避免log(0)）
      coherence_sum <- coherence_sum + log(cooccur_mat[w1, w2] + 1)
    }
  }
  # 归一化后得到单个主题的一致性得分
  return(coherence_sum / pair_count)
}

# 计算所有主题的一致性得分，取平均值作为模型整体一致性
topic_coherences <- sapply(top_terms_per_topic, compute_topic_coherence, cooccur_mat = cooccur_matrix)
avg_coherence <- mean(topic_coherences)

二、困惑度（Perplexity）实现 #

困惑度衡量模型对未知数据的预测能力，需划分训练/测试集计算：

1. 划分训练与测试语料 #

set.seed(123)
train_idx <- sample(seq_along(df_title_tok), size = 0.8 * length(df_title_tok))
train_tok <- df_title_tok[train_idx]
test_tok <- df_title_tok[-train_idx]

2. 训练模型并提取核心参数 #

train_model <- BTM(
  train_tok,
  k = n_topics,
  alpha = 50/n_topics,
  beta = 0.01,
  iter = 1000,
  window = 15,
  background = FALSE,
  trace = FALSE,
  detailed = TRUE
)

# 提取词-主题分布（phi：行=主题，列=词）和主题先验alpha
phi <- train_model$phi
alpha <- train_model$alpha

# 生成测试集的滑动窗口（与模型window参数一致）
library(textmineR)
test_windows <- CreateWindows(
  documents = test_tok,
  window_size = 15,
  overlapping = TRUE
)

3. 计算测试集困惑度 #

compute_perplexity <- function(test_windows, phi, alpha) {
  total_log_prob <- 0
  total_word_count <- 0
  
  for (window in test_windows) {
    # 过滤模型未收录的词
    valid_words <- window[window %in% colnames(phi)]
    if (length(valid_words) == 0) next
    
    total_word_count <- total_word_count + length(valid_words)
    
    # 计算当前窗口的主题概率分布（alpha平滑 + 词主题概率加权）
    topic_weights <- colSums(phi[, valid_words, drop = FALSE]) + alpha
    topic_probs <- topic_weights / sum(topic_weights)
    
    # 累加每个词的对数概率
    word_log_probs <- sapply(valid_words, function(word) {
      log(sum(topic_probs * phi[, word]))
    })
    total_log_prob <- total_log_prob + sum(word_log_probs)
  }
  
  # 计算并返回困惑度
  return(exp(-total_log_prob / total_word_count))
}

test_perplexity <- compute_perplexity(test_windows, phi, alpha)

三、最优K值选择策略 #

• 遍历候选K值（如2~20），分别训练模型并计算对应平均主题一致性、测试集困惑度
• 优先选择平均主题一致性最高且困惑度较低的K值，最终结合人工校验（查看主题词语义关联）确定最优主题数

内容的提问来源于stack exchange，提问作者Valerio Ficcadenti