1、隐含狄利克雷分布LDA

隐含狄利克雷分布LDA(Latent Dirichlet allocation)，是一种主题模型，它可以将文档集中每篇文档的主题按照概率分布的形式给出。同时它是一种无监督学习算法，在训练时不需要手工标注的训练集，需要的仅仅是文档集以及指定主题的数量k即可。此外LDA的另一个优点是，对于每一个主题均可找出一些词语来描述它。
隐含狄利克雷分布模型是一种特别流行的适合主题模型的方法。它将每个文档视为一个主题的混合体，每个主题视为一个词汇的混合体。这允许词汇可以在主题之间共享，比如像“预算”这样的词可能同时出现在“政治”和“经济”两个主题中。

2、导入科学辟谣数据

require(pacman)
p_load(dplyr,tidytext)
# 已经提前分好词
df <- read.csv("./科学辟谣.jieba.csv",header = T,
               stringsAsFactors = F) %>% tbl_df()
head(df)

## # A tibble: 6 x 2
##   title                       content                                                                              
##   <chr>                       <chr>                                                                                
## 1 向大盘鸡、羊肉串滴血可以传播艾滋病~ 艾滋病 病毒传播 途径 固定 个人行为 血液 体液 传播 即可 性 接触 公用 针管 注射 毒品 输血 途径 感染 艾滋病 病毒 脆弱 暴露 环境 中 几分钟 感染 能~
## 2 美国加拿大叫停仰卧起坐      伤害 脊椎 仰卧起坐 双手 抱头 仰卧起坐 锻炼 腹肌 常用 方法 我国 国家 学生 体质 健康 标准 中 腰 腹 力量 测试 指标 强健 腹肌 腹部 肌肉 力量 展示~
## 3 “怀孕后喜好吃酸生儿子”是真的吗？~ 现代医学 比较发达 国家 政策 医学 原因 医生 宝宝 性别 提前 告诉 宝妈们 只能 民间 土 方法 判断 酸 辣 女 常见 一种 影视作品 里 渲染 酸 辣 女 说~
## 4 怀孕后腋下变黑生儿子        宝妈们 怀孕 皮肤 变得 怀孕 前 更 光滑 弹性 脸上 黄褐斑 脖子 腋下 乳头 变黑 民间 有种 说法 孕期 皮肤 好怀 女孩 皮肤 变黑 男孩 真的 怀孕期 黄褐~
## 5 孕妈肚脐凸起生的就是儿子    孕妈们 怀孕 月份 增加 肚子 一天天 增大 外 肚脐 形状 一种 奇特 状况 肚脐 比较突出 凹陷 现象 老 说法 肚脐 形状 判断 男孩 女孩 科学依据 原因 导致~
## 6 最聪明的孩子都吃素          体液 酸碱度 机体 严格控制 代谢 依赖 生物酶 精准 控制 PH值 体液 缓冲 体系 盐分 蛋白质 有机酸 成分 相互交织 稳定 环境 饮食 改变 体液 PH值 不太~

dtm <- df %>% unnest_tokens(content,content) %>%
  count(content,title,sort = T) %>%
  cast_dtm(title,content,n)
print(dtm)

## <<DocumentTermMatrix (documents: 1683, terms: 20542)>>
## Non-/sparse entries: 239621/34332565
## Sparsity           : 99%
## Maximal term length: 87
## Weighting          : term frequency (tf)

3、topicmodels包创建主题模型

p_load(topicmodels)

# 科学辟谣网共14个分类，所以设k=14
lda <- LDA(dtm,k=14,control = list(seed=1234))

print(lda)

## A LDA_VEM topic model with 14 topics.

4、词-主题概率

# 抽取每个词属于每个主题的概率beta
topic <- tidy(lda,matrix = "beta")
print(topic)

## # A tibble: 287,588 x 3
##    topic term      beta
##    <int> <chr>    <dbl>
##  1     1 真菌  9.26e- 5
##  2     2 真菌  9.27e-13
##  3     3 真菌  6.98e-13
##  4     4 真菌  3.61e- 3
##  5     5 真菌  1.41e-18
##  6     6 真菌  4.36e- 4
##  7     7 真菌  4.88e- 5
##  8     8 真菌  1.01e-11
##  9     9 真菌  1.74e- 4
## 10    10 真菌  1.41e- 4
## # ... with 287,578 more rows

5、查找主题前10个关键词

p_load(ggplot2)
topic %>% group_by(topic) %>%
  top_n(10,beta) %>%
  ungroup() %>% arrange(topic,-beta) %>%
  mutate(term=reorder_within(term,beta,topic)) %>%
  filter(topic<7) %>%
  ggplot(aes(term,beta,fill=factor(topic))) +
  geom_col(show.legend = F) +
  facet_wrap(~topic,ncol = 3,scales = "free") +
  coord_flip() + labs(x=NULL) +
  scale_x_reordered()

主题前10关键词

6、计算同一词在不同主题中的概率差距

p_load(tidyr)
topic %>% filter(topic < 3) %>%
  mutate(topic=paste0("topic",topic)) %>%
  spread(topic,beta) %>%
  filter(topic1 > 0.01 | topic2 > 0.01) %>%
  mutate(log_ratio = log2(topic2 / topic1)) %>%
  arrange(-log_ratio)

## # A tibble: 6 x 4
##   term    topic1   topic2 log_ratio
##   <chr>    <dbl>    <dbl>     <dbl>
## 1 治疗  0.000463 0.0141        4.93
## 2 患者  0.000402 0.0106        4.73
## 3 药    0.000960 0.0115        3.58
## 4 医院  0.00132  0.0118        3.16
## 5 性    0.00212  0.0108        2.35
## 6 睡眠  0.0117   0.000876     -3.74

7、文档-主题概率

# 抽取每个文档属于每个主题的概率gamma
document <- tidy(lda,matrix="gamma")
print(document)

## # A tibble: 23,562 x 3
##    document                          topic     gamma
##    <chr>                             <int>     <dbl>
##  1 “超级真菌”肆虐因抗真菌药滥用？        1 0.0000185
##  2 方便面是“垃圾食品”                   1 0.0000253
##  3 蕨菜致癌                            1 0.0000381
##  4 5G内涵、应用、辐射等热点问题          1 0.0000616
##  5 宝宝的脐带血是“废”还是“保”？          1 0.0000287
##  6 茶垢有重金属，会导致早衰              1 0.0000588
##  7 斑点香蕉不能吃                       1 0.0000421
##  8 O型血最招蚊子                        1 0.0000411
##  9 O型血、爱出汗的胖子和女人更招蚊子      1 0.0000415
## 10 “褐色脂肪”有助于减肥                  1 0.999    
## # ... with 23,552 more rows

模型估计文档1：‘“超级真菌”肆虐因抗真菌药滥用？’中有0.00185%的概率属于主题1。而文档10：‘“褐色脂肪”有助于减肥’有99.9%的概率属于主题1。

tidy(dtm) %>% 
  filter(document=="“褐色脂肪”有助于减肥") %>%
  arrange(desc(count))

## # A tibble: 235 x 3
##    document             term  count
##    <chr>                <chr> <dbl>
##  1 “褐色脂肪”有助于减肥 脂肪     49
##  2 “褐色脂肪”有助于减肥 褐色     38
##  3 “褐色脂肪”有助于减肥 组织     23
##  4 “褐色脂肪”有助于减肥 办法      6
##  5 “褐色脂肪”有助于减肥 更        5
##  6 “褐色脂肪”有助于减肥 人体      5
##  7 “褐色脂肪”有助于减肥 燃烧      5
##  8 “褐色脂肪”有助于减肥 分布      5
##  9 “褐色脂肪”有助于减肥 激活      5
## 10 “褐色脂肪”有助于减肥 细胞      4
## # ... with 225 more rows

8、查看文档-词矩阵中每个词分配给哪个主题

assignments <- augment(lda,data=dtm)
print(assignments)

## # A tibble: 239,621 x 4
##    document                                         term  count .topic
##    <chr>                                            <chr> <dbl>  <dbl>
##  1 “超级真菌”肆虐因抗真菌药滥用？                    真菌     66      4
##  2 斑点香蕉不能吃                                   真菌      1     10
##  3 毒蘑菇鉴别法                                     真菌      1      9
##  4 食品和保健品中经常添加的海藻糖会让致病菌毒力倍增    真菌      2      4
##  5 吃货须知：杨梅生虫的真假流言                      真菌      1      6
##  6 指甲上的月牙少代表不健康                          真菌      1     10
##  7 雾化是滥用抗生素                                 真菌      1      9
##  8 舒肤佳中的抗菌剂会致癌                            真菌      1      7
##  9 用醋泡脚能治脚臭                                 真菌      5      6
## 10 对抗生素的误解和误用                             真菌      1      4
## # ... with 239,611 more rows

9、mallet包实现LDA

p_load(mallet)

# 为“stopwords”创建一个空文件
file.create(empty.file <- tempfile())

## [1] TRUE

docs <- mallet.import(df$title,df$content,empty.file)

lda.mallet <- MalletLDA(num.topics = 14)

lda.mallet$loadDocuments(docs)

lda.mallet$train(100)

# 模型创建后，可以使用tidy()和augment()函数进行操作
# 创建词-主题对
tidy(lda.mallet)

## # A tibble: 505,596 x 3
##    topic term          beta
##    <int> <chr>        <dbl>
##  1     1 艾滋病 0.000000551
##  2     2 艾滋病 0.000000432
##  3     3 艾滋病 0.000000509
##  4     4 艾滋病 0.000000578
##  5     5 艾滋病 0.000000587
##  6     6 艾滋病 0.000000521
##  7     7 艾滋病 0.000000343
##  8     8 艾滋病 0.000000407
##  9     9 艾滋病 0.000000361
## 10    10 艾滋病 0.000000578
## # ... with 505,586 more rows

# 创建文档-主题对
tidy(lda.mallet, matrix = "gamma")

## # A tibble: 23,562 x 3
##    document                           topic   gamma
##    <chr>                              <int>   <dbl>
##  1 向大盘鸡、羊肉串滴血可以传播艾滋病     1 0.0123 
##  2 美国加拿大叫停仰卧起坐                1 0.536  
##  3 “怀孕后喜好吃酸生儿子”是真的吗？       1 0.00109
##  4 怀孕后腋下变黑生儿子                  1 0.00726
##  5 孕妈肚脐凸起生的就是儿子               1 0.0830 
##  6 最聪明的孩子都吃素                    1 0.00152
##  7 家养猪笼草可以有效灭蚊                 1 0.00164
##  8 月经期间洗头会致癌                     1 0.0317 
##  9 爱因斯坦的数学很烂                     1 0.0185 
## 10 利用磁铁和钢丝可制作永动机             1 0.0210 
## # ... with 23,552 more rows

# 使用augment()函数前需要将词语列名改为term，文档列名改为document
word.counts <- df %>% 
  unnest_tokens(content,content) %>%
  count(content,title,sort = T)
term.counts <- rename(word.counts, term = content,
                      document = title)
augment(lda.mallet, term.counts)

## # A tibble: 239,621 x 4
##    term  document                              n .topic
##    <chr> <chr>                             <int>  <int>
##  1 真菌  “超级真菌”肆虐因抗真菌药滥用？       66      4
##  2 食品  方便面是“垃圾食品”                   61     11
##  3 蕨    蕨菜致癌                             57      8
##  4 g     5G内涵、应用、辐射等热点问题         55     12
##  5 血    宝宝的脐带血是“废”还是“保”？         55      4
##  6 茶    茶垢有重金属，会导致早衰             54     10
##  7 香蕉  斑点香蕉不能吃                       53      3
##  8 蚊子  O型血最招蚊子                        52      4
##  9 蚊子  O型血、爱出汗的胖子和女人更招蚊子    50      4
## 10 脂肪  “褐色脂肪”有助于减肥                 49      7
## # ... with 239,611 more rows

# 两个模型对比
aug.mallet <- augment(lda.mallet, term.counts) %>% 
  filter(term=="真菌") %>%
  arrange(-n) %>%
  select(document,term,mallet.topic=.topic)

aug.topicmodel <- assignments %>%
  filter(term=="真菌") %>%
  arrange(-count) %>%
  select(document,topicmodel.topic=.topic)

compare <- aug.mallet %>% full_join(aug.topicmodel,by="document")
print(compare)

## # A tibble: 31 x 4
##    document                                         term  mallet.topic topicmodel.topic
##    <chr>                                            <chr>        <int>            <dbl>
##  1 “超级真菌”肆虐因抗真菌药滥用？                   真菌             4                4
##  2 闻臭袜子会感染超级真菌吗                         真菌             4                4
##  3 用醋泡脚能治脚臭                                真菌             4                6
##  4 夏天去公共泳池游泳会得病                         真菌             4                4
##  5 发烧吃点消炎药                                  真菌             4                4
##  6 关于“超级真菌”你需要知道的真相                   真菌             4                4
##  7 藿香正气水和头孢一起服用会产生剧毒                真菌             4                6
##  8 食品和保健品中经常添加的海藻糖会让致病菌毒力倍增   真菌             4                4
##  9 夏天的这些皮肤问题，你知道该怎么办吗？            真菌             4                6
## 10 “甲醛白菜”影响健康                              真菌             2               12
## # ... with 21 more rows