利用R語言進行LDA主題挖掘

準備：

每個文檔以txt形式儲存在E:/1

1.設定工作路徑

#加載包tm
library("tm")
#設定工作路徑
setwd(“E:/1”)
corpus<-Corpus(DirSource(directory="E:/1",encoding="UTF-8",recursive=TRUE,mode="text"))
#顯示語料庫有多少個文檔
corpus

           

2.預處理語料庫

library("SnowballC")
#設定停用詞詞典和自定義詞彙
myStopwords <- c(stopwords("english"), "SalesForce",”null”)
myStopwords <- c(stopwords("english"), stopwords("SMART"))
your_corpus <- tm_map(corpus, content_transformer(tolower))#每個變換隻是在一個文檔上，tm_map将其作用到所有文檔
your_corpus <- tm_map(your_corpus, removeWords, myStopwords)
your_corpus <- tm_map(your_corpus, removeNumbers)
your_corpus <- tm_map(your_corpus, removePunctuation)#标點
your_corpus <- tm_map(your_corpus, stripWhitespace)#空白
your_corpus <- tm_map(your_corpus, stemDocument)

           

3.建構文檔-詞矩陣

#這隻是一個矩陣，其中文檔是行，單詞是列，矩陣單元包含單詞的頻率計數（weightTf），其中wordLengths=c(3,Inf)指單詞長度從3到無限大；結果中Sparsity指稀疏性
myDtm<-DocumentTermMatrix(your_corpus,control=list(wordLengths=c(3,Inf)))
myDtm
#超過100次的術語清單
findFreqTerms(myDtm, 100)
#加載slam包，計算TF-IDF，将值較高的保留下來
library("slam")
term_tfidf <-tapply(myDtm$v/row_sums(myDtm)[myDtm$i], myDtm$j, mean)* log2(nDocs(myDtm)/col_sums(myDtm > 0))
summary(term_tfidf)
# term_tfidf是Median值，保留TF-IDF較高的值，使用中值是因為它不受資料中較大的TF-IDF值的影響，而平均值會受到更大的影響。
myDtm <- myDtm[,term_tfidf >= 0.22240] 
myDtm <- myDtm[row_sums(myDtm) > 0,]
summary(col_sums(myDtm))
save(myDtm, file = "E:/my_Dtm.Rdata")

           

4.建構單詞詞雲

library("wordcloud")
#将文檔-術語矩陣轉換為術語-文檔矩陣（t函數為矩陣轉置）
myTdm <- t(myDtm)
#将tdm定義為矩陣
m = as.matrix(myTdm)
#按降序擷取字數
word_freqs = sort(rowSums(m), decreasing=TRUE)
#建立一個包含單詞及其頻率的資料幀
dm = data.frame(word=names(word_freqs), freq=word_freqs)
#用前200詞作詞雲
wordcloud(dm$word, dm$freq,  max.words=200, random.order=FALSE, rot.per=.2, colors=brewer.pal(9, "Dark2"))

           

5.确定主題個數

要在資料集中确定主題的個數，需要事先設定主題個數的搜尋範圍，然後分别使用LDA計算主題模型在不同主題數目下的困惑度或者似然估計數值，最終能夠使得模型困惑度最低或者似然估計值最大的主題數即為最佳的主題個數，一般為了降低困惑度，通常還會采取交叉驗證的方法進行。下面給出計算似然估計數值的基本代碼，最佳主題數為最大值。

burnin = 1000
#疊代次數
iter = 1000
#儲存記錄的步長
keep = 50
#主題範圍（從5到50，以步長5進行遞增）
sequ <- seq(5, 50, 5)
#疊代進行試驗
fitted_many <- lapply(sequ, function(k) LDA(myDtm, k = k, method = "Gibbs",control = list(burnin = burnin, iter = iter, keep = keep) ))
#抽取每個主題的對數似然估計值
logLiks_many <- lapply(fitted_many, function(L)  [email protected][-c(1:(burnin/keep))])
#定義計算調和平均值的函數
harmonicMean <- function(logLikelihoods, precision=2000L) {
  library("Rmpfr")
  llMed <- median(logLikelihoods)
  as.double(llMed - log(mean(exp(-mpfr(logLikelihoods,
                                       prec = precision) + llMed))))
}
#計算各個主題的調和平均數，将其最為模型的最大似然估計
#需加載程式包gmp、Rmpfr
 library("gmp")
 library("Rmpfr")
hm_many <- sapply(logLiks_many, function(h) harmonicMean(h))
#畫出主題數-似然估計曲線圖，用于觀察
plot(sequ, hm_many, type = "l")
# 計算最佳主題個數
sequ[which.max(hm_many)]


           

6.建構吉布斯抽樣的LDA模型

library("topicmodels")
load("my_Dtm.Rdata")
SEED <- 20080809
BURNIN = 1000
ITER = 1000
k = 20 #之前得出的最優主題數
model_lda <- LDA(myDtm, k = k, method = "Gibbs", control = list(seed = SEED, burnin = BURNIN, iter = ITER))
print(model_lda)
save(model_lda, file = "LDA_model.RData")
#看一下每個主題中頻率最高的十個數
terms(model_lda, 10)
#将每個主題出現的頻率最高的100個詞彙導入csv.
write.csv(terms(model_lda, 100), file = "E:/model_mini_news.csv")
#将主題分布導入進 csv
lda_terms <- posterior(model_lda)$terms
write.csv(lda_terms, file = " E:/LDA_TERMS_mini_news.csv")
#将主題導入csv
lda_topics <- posterior(model_lda)$topics
write.csv(lda_topics, file = " E:/LDA_TOPICS_mini_news.csv")

           

參考資料：

（1）主體部分

Text Mining and Visualization: Case Studies Using Open-Source Tools

作者 Markus Hofmann，Andrew Chisholm

（2）計算最優主題數部分：

https://www.cnblogs.com/deeplearningfans/p/4114892.html