34-tidytext包学习：主题建模
2020-02-11 本文已影响0人
wonphen
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
