Topic Models
Petr Ya
5/16/2020
rm(list = ls())
date()## [1] "Wed May 20 23:21:12 2020"sessionInfo()## R version 3.6.1 (2019-07-05)
## Platform: x86_64-apple-darwin15.6.0 (64-bit)
## Running under: macOS Catalina 10.15.4
##
## Matrix products: default
## BLAS: /Library/Frameworks/R.framework/Versions/3.6/Resources/lib/libRblas.0.dylib
## LAPACK: /Library/Frameworks/R.framework/Versions/3.6/Resources/lib/libRlapack.dylib
##
## locale:
## [1] en_US.UTF-8/en_US.UTF-8/en_US.UTF-8/C/en_US.UTF-8/en_US.UTF-8
##
## attached base packages:
## [1] stats graphics grDevices utils datasets methods base
##
## loaded via a namespace (and not attached):
## [1] compiler_3.6.1 magrittr_1.5 tools_3.6.1 htmltools_0.4.0
## [5] yaml_2.2.0 Rcpp_1.0.2 stringi_1.4.3 rmarkdown_1.16
## [9] knitr_1.25 stringr_1.4.0 xfun_0.10 digest_0.6.21
## [13] rlang_0.4.6 evaluate_0.14##Библиотеки
library(quanteda)## Package version: 1.5.1## Parallel computing: 2 of 4 threads used.## See https://quanteda.io for tutorials and examples.##
## Attaching package: 'quanteda'## The following object is masked from 'package:utils':
##
## Viewlibrary(topicmodels)## Warning: package 'topicmodels' was built under R version 3.6.2library(ldatuning)## Warning: package 'ldatuning' was built under R version 3.6.2library(wordcloud2)
library(data.table)
# library(dplyr)
# library(stringr)
library(ggplot2)
require(pals)## Loading required package: pals library(magrittr)
# # library(tibble)
# #
# library(igraph)
# library(Matrix)Импорт данных
# load(file = "Tokens_S2.RData")
load(file = "Tokens_S.RData")
# load(file = "Corpus_S2.RData")Обработка токенизатора
Tokens_S <- Tokens_S %>%
tokens_keep(pattern = c("*_S", "*_V", "*_A")
, padding = TRUE
) # оставляю пустоты вместо удаленных слов
Collocation <- Tokens_S %>%
textstat_collocations(min_count = 25)
#Tokens_S <- tokens_compound(Tokens_S, Collocation)
head(Collocation) ## collocation count count_nested length lambda z
## 1 окружающий_a среда_s 293 0 2 7.674044 59.21067
## 2 мочь_v позволять_v 227 0 2 5.041889 52.95458
## 3 природный_a ресурс_s 124 0 2 5.101227 43.70098
## 4 живой_a существо_s 71 0 2 6.589237 38.18878
## 5 вырубать_v лес_s 77 0 2 6.426373 34.63412
## 6 огромный_a количество_s 51 0 2 6.132416 33.24050Получаются тройные сочетания - нужно ли их ограничивать?
DTM <- Tokens_S %>%
tokens_remove("") %>% # убираем пустые места, которые были нужны для поиска словосочетаний
dfm() %>%
dfm_trim(min_docfreq = 2, max_docfreq = Inf)
# Слова которые встрчаются больше чем в одном тексте
dim(DTM)## [1] 225 4286Удаление частых слов
topfeatures(DTM)## природа_s человек_s быть_v мочь_v отношение_s жизнь_s
## 4337 4145 1398 1097 1062 626
## животное_s мир_s должный_a позволять_v
## 579 565 559 511FriqWord <- names(topfeatures(DTM))[1:5]
DTM <- dfm_remove(DTM, FriqWord)
dim(DTM)## [1] 225 4281Подбор параметров
t <- Sys.time()
DTM2topicmodels <- convert(DTM, to = "topicmodels")
LDAtuning.metrics_Gibbs <- FindTopicsNumber(DTM2topicmodels
, topics = seq(from = 4, to = 15, by = 1)
, metrics = c("Griffiths2004", "CaoJuan2009", "Arun2010", "Deveaud2014")
, method = "Gibbs"
, control = list(seed = 77)
, mc.cores = 2L, verbose = TRUE
)## fit models... done.
## calculate metrics:
## Griffiths2004... done.
## CaoJuan2009... done.
## Arun2010... done.
## Deveaud2014... done.Sys.time() - t## Time difference of 1.078525 minsFindTopicsNumber_plot(LDAtuning.metrics_Gibbs)
Создание модели
K <- 8 # Количество тем
set.seed(9161)
TopicModel <- LDA(DTM, K, method = "Gibbs", control = list(iter = 500, verbose = 25))## K = 8; V = 4281; M = 225
## Sampling 500 iterations!
## Iteration 25 ...
## Iteration 50 ...
## Iteration 75 ...
## Iteration 100 ...
## Iteration 125 ...
## Iteration 150 ...
## Iteration 175 ...
## Iteration 200 ...
## Iteration 225 ...
## Iteration 250 ...
## Iteration 275 ...
## Iteration 300 ...
## Iteration 325 ...
## Iteration 350 ...
## Iteration 375 ...
## Iteration 400 ...
## Iteration 425 ...
## Iteration 450 ...
## Iteration 475 ...
## Iteration 500 ...
## Gibbs sampling completed!# have a look a some of the results (posterior distributions)
TmResult <- posterior(TopicModel)
# format of the resulting object
attributes(TmResult)## $names
## [1] "terms" "topics"ncol(DTM)## [1] 4281Связь термина и темы
# topics are probability distribtions over the entire vocabulary
beta <- TmResult$terms # get beta from results
dim(beta) # K distributions over ncol(DTM) terms## [1] 8 4281rowSums(beta)## 1 2 3 4 5 6 7 8
## 1 1 1 1 1 1 1 1Во всех стобцах сумма равна единице
Связь темы и текста
theta <- TmResult$topics
dim(theta) ## [1] 225 8rowSums(theta)[1:5]## Bio1 Bio2 Bio3 Bio4 Bio5
## 1 1 1 1 1Cумма вероятностей по темам тоже единица.
Описание тем через термины
выведем по наиболее значимых терминов из каждой темы
terms(TopicModel, 15)## Topic 1 Topic 2 Topic 3 Topic 4
## [1,] "природный_a" "ребенок_s" "позволять_v" "мусор_s"
## [2,] "экологический_a" "лес_s" "животное_s" "проблема_s"
## [3,] "развитие_s" "новый_a" "ресурс_s" "вода_s"
## [4,] "общество_s" "земля_s" "вопрос_s" "год_s"
## [5,] "потребность_s" "относиться_v" "человечество_s" "океан_s"
## [6,] "цель_s" "должный_a" "должный_a" "количество_s"
## [7,] "являться_v" "поколение_s" "становиться_v" "отходы_s"
## [8,] "человеческий_a" "среда_s" "делать_v" "выбрасывать_v"
## [9,] "проблема_s" "окружающий_a" "говорить_v" "происходить_v"
## [10,] "человечество_s" "оставлять_v" "считать_v" "земля_s"
## [11,] "закон_s" "богатство_s" "данный_a" "страна_s"
## [12,] "мир_s" "река_s" "иметь_v" "загрязнение_s"
## [13,] "становиться_v" "жить_v" "начинать_v" "хотеть_v"
## [14,] "система_s" "природный_a" "думать_v" "большой_a"
## [15,] "качество_s" "вырубать_v" "помогать_v" "пакет_s"
## Topic 5 Topic 6 Topic 7 Topic 8
## [1,] "среда_s" "мир_s" "планета_s" "жизнь_s"
## [2,] "окружающий_a" "жизнь_s" "лес_s" "давать_v"
## [3,] "ресурс_s" "существо_s" "время_s" "животное_s"
## [4,] "вид_s" "существовать_v" "вид_s" "жить_v"
## [5,] "вода_s" "любовь_s" "животное_s" "земля_s"
## [6,] "жизнь_s" "брать_v" "становиться_v" "дерево_s"
## [7,] "природный_a" "являться_v" "растение_s" "воздух_s"
## [8,] "влияние_s" "сила_s" "год_s" "мир_s"
## [9,] "изменение_s" "место_s" "воздух_s" "понимать_v"
## [10,] "использовать_v" "образ_s" "газ_s" "живой_a"
## [11,] "приводить_v" "дом_s" "рыба_s" "вред_s"
## [12,] "использование_s" "правило_s" "сохранение_s" "защищать_v"
## [13,] "являться_v" "делать_v" "завод_s" "гармония_s"
## [14,] "человечество_s" "иметь_v" "создавать_v" "лес_s"
## [15,] "должный_a" "называть_v" "приводить_v" "современный_a"Создадим имена для тем в виде первых пяти слов
TopicNames <- TopicModel %>%
terms(5) %>%
apply(2, paste, collapse = " ")Визуализация Слов и Тем
Тема номер 1
TopicNames[1]## Topic 1
## "природный_a экологический_a развитие_s общество_s потребность_s"set.seed(1991)
#for (i in 1:K) {
i <- 1
TmResult$terms %>%
extract(i,) %>%
sort(decreasing = TRUE) %>%
extract(1:40) %>%
data.frame(names(.), .) %>%
wordcloud2(shuffle = FALSE, size = 0.4
, fontWeight = "normal", rotateRatio = 0)#}Тема номер 2
i <- 1
TmResult$terms %>%
extract(i,) %>%
sort(decreasing = TRUE) %>%
extract(1:40) %>%
data.frame(names(.), .) %>%
wordcloud2(shuffle = FALSE, size = 0.4
, fontWeight = "normal", rotateRatio = 0)Ранжирование тем
Вариант1. Сортировка на основе вероятности появления темы по всей коллекции
# What are the most probable topics in the entire collection?
topicProportions <- colSums(theta) / nrow(DTM) # mean probablities over all paragraphs
names(topicProportions) <- TopicNames # assign the topic names we created before
sort(topicProportions, decreasing = TRUE) # show summed proportions in decreased order## позволять_v животное_s ресурс_s вопрос_s человечество_s
## 0.1392022
## среда_s окружающий_a ресурс_s вид_s вода_s
## 0.1379369
## природный_a экологический_a развитие_s общество_s потребность_s
## 0.1276058
## мусор_s проблема_s вода_s год_s океан_s
## 0.1257142
## жизнь_s давать_v животное_s жить_v земля_s
## 0.1242554
## ребенок_s лес_s новый_a земля_s относиться_v
## 0.1242005
## планета_s лес_s время_s вид_s животное_s
## 0.1174876
## мир_s жизнь_s существо_s существовать_v любовь_s
## 0.1035975Разница минимальна.
Вариант 2. Как часто тема становится первой в тексте.
countsOfPrimaryTopics <- rep(0, K)
names(countsOfPrimaryTopics) <- TopicNames
for (i in 1:nrow(DTM)) {
topicsPerDoc <- theta[i, ] # select topic distribution for document i
# get first element position from ordered list
primaryTopic <- order(topicsPerDoc, decreasing = TRUE)[1]
countsOfPrimaryTopics[primaryTopic] <- countsOfPrimaryTopics[primaryTopic] + 1
}
sort(countsOfPrimaryTopics, decreasing = TRUE)## позволять_v животное_s ресурс_s вопрос_s человечество_s
## 45
## мусор_s проблема_s вода_s год_s океан_s
## 41
## среда_s окружающий_a ресурс_s вид_s вода_s
## 32
## природный_a экологический_a развитие_s общество_s потребность_s
## 29
## жизнь_s давать_v животное_s жить_v земля_s
## 24
## ребенок_s лес_s новый_a земля_s относиться_v
## 23
## планета_s лес_s время_s вид_s животное_s
## 22
## мир_s жизнь_s существо_s существовать_v любовь_s
## 9Соотношение тем по выборкам
a <- aggregate(theta, by = list(group = docvars(DTM)[, 1]), mean)
colnames(a)[2:(K + 1)] <- TopicNames
a <- melt(a, id.vars = "group")
# plot topic proportions per deacde as bar plot
ggplot(a, aes(x = group, y = value, fill = variable)) +
geom_bar(stat = "identity") + ylab("proportion") +
scale_fill_manual(values = paste0(alphabet(20), "FF"), name = "group") +
theme(axis.text.x = element_text(angle = 90, hjust = 1))