R語言-文本挖掘 主題模型 文本分類

####需要先安裝幾個R包，如果有這些包，可省略安裝包的步驟。
#install.packages("Rwordseg")
#install.packages("tm");
#install.packages("wordcloud");
#install.packages("topicmodels")

例子中所用數據

數據來源於sougou實驗室數據。

數據網址：http://download.labs.sogou.com/dl/sogoulabdown/SogouC.mini.20061102.tar.gz

文件結構

└─Sample

├─C000007 汽車

├─C000008 財經

├─C000010 IT

├─C000013 健康

├─C000014 體育

├─C000016 旅游

├─C000020 教育

├─C000022 招聘

├─C000023

└─C000024 軍事

采用Python對數據進行預處理為train.csv文件，並把每個文件文本數據處理為1行。

預處理python腳本
<ignore_js_op> combineSample.zip (720 Bytes, 下載次數: 96) 

所需數據
<ignore_js_op> train.zip (130.2 KB, 下載次數: 164) 
大家也可以用R直接將原始數據轉變成train.csv中的數據

文章所需stopwords
<ignore_js_op> StopWords.zip (2.96 KB, 下載次數: 114) 

1.     讀取資料庫

1. csv <- read.csv("d://wb//train.csv",header=T, stringsAsFactors=F)
2. mystopwords<- unlist (read.table("d://wb//StopWords.txt",stringsAsFactors=F))

復制代碼

2.    

數據預處理（中文分詞、stopwords處理）

2. library(tm);
4. #移除數字
5. removeNumbers = function(x) { ret = gsub("[0-9０１２３４５６７８９]","",x) }
6. sample.words <- lapply(csv$$$$text, removeNumbers)

復制代碼

2. #處理中文分詞,此處用到Rwordseg包
4. wordsegment<- function(x) {
5.     library(Rwordseg)
6. segmentCN(x)
7. }
9. sample.words <- lapply(sample.words, wordsegment)

復制代碼

2. ###stopwords處理
3. ###先處理中文分詞，再處理stopwords，防止全局替換丟失信息
5. removeStopWords = function(x,words) {  
6.     ret = character(0)
7.     index <- 1
8.     it_max <- length(x)
9.     while (index <= it_max) {
10.       if (length(words[words==x[index]]) <1) ret <- c(ret,x[index])
11.       index <- index +1
12.     }
13.     ret
14. }
17. sample.words <- lapply(sample.words, removeStopWords, mystopwords)

復制代碼

3.    wordcloud展示

1. #構建語料庫
2. corpus = Corpus(VectorSource(sample.words))
3. meta(corpus,"cluster") <- csv$$$$type
4. unique_type <- unique(csv$$$$type)
5. #建立文檔-詞條矩陣
6. (sample.dtm <- DocumentTermMatrix(corpus, control = list(wordLengths = c(2, Inf))))

復制代碼

2. #install.packages("wordcloud"); ##需要wordcloud包的支持
3. library(wordcloud);
4. #不同文檔wordcloud對比圖
5. sample.tdm <-  TermDocumentMatrix(corpus, control = list(wordLengths = c(2, Inf)));
7. tdm_matrix <- as.matrix(sample.tdm);
9. png(paste("d://wb//sample_comparison",".png", sep = ""), width = 1500, height = 1500 );
10. comparison.cloud(tdm_matrix,colors=rainbow(ncol(tdm_matrix)));####由於顏色問題，稍作修改
11. title(main = "sample comparision");
12. dev.off();

復制代碼

2. #按分類匯總wordcloud對比圖
3. n <- nrow(csv)
4. zz1 = 1:n
5. cluster_matrix<-sapply(unique_type,function(type){apply(tdm_matrix[,zz1[csv$$$$type==type]],1,sum)})
6. png(paste("d://wb//sample_ cluster_comparison",".png", sep = ""), width = 800, height = 800 )
7. comparison.cloud(cluster_matrix,colors=brewer.pal(ncol(cluster_matrix),"Paired")) ##由於顏色分類過少，此處稍作修改
8. title(main = "sample cluster comparision")
9. dev.off()

復制代碼

<ignore_js_op> 

可以看出數據分布不均勻，culture、auto等數據很少。

2. #按各分類畫wordcloud
3. sample.cloud <- function(cluster, maxwords = 100) {
4.     words <- sample.words[which(csv$$$$type==cluster)]
5.     allwords <- unlist(words)
7.     wordsfreq <- sort(table(allwords), decreasing = T)
8.     wordsname <- names(wordsfreq) 
10.     png(paste("d://wb//sample_", cluster, ".png", sep = ""), width = 600, height = 600 )
11.     wordcloud(wordsname, wordsfreq, scale = c(6, 1.5), min.freq = 2, max.words = maxwords, colors = rainbow(100))
12.     title(main = paste("cluster:", cluster))
13.     dev.off()
14. }
15. lapply(unique_type,sample.cloud)# unique(csv$$$$type)

復制代碼

<ignore_js_op> 
<ignore_js_op> 

4.    主題模型分析

2. library(slam)
3. summary(col_sums(sample.dtm))
4. term_tfidf  <- tapply(sample.dtm$$$$v/row_sums( sample.dtm)[ sample.dtm$$$$i],   sample.dtm$$$$j,  mean)*
5. log2(nDocs( sample.dtm)/col_sums( sample.dtm  >  0))
6.         summary(term_tfidf)
9. sample.dtm  <-  sample.dtm[,  term_tfidf  >=  0.1]
10.         sample.dtm  <-  sample.dtm[row_sums(sample.dtm)  >  0,]
12. library(topicmodels)
13. k <- 30
14.     
15. SEED <- 2010
16. sample_TM <-
17. list(
18. VEM = LDA(sample.dtm, k = k, control = list(seed = SEED)),
19. VEM_fixed = LDA(sample.dtm, k = k,control = list(estimate.alpha = FALSE, seed = SEED)),
20. Gibbs = LDA(sample.dtm, k = k, method = "Gibbs",control = list(seed = SEED, burnin = 1000,thin = 100, iter = 1000)),
21. CTM = CTM(sample.dtm, k = k,control = list(seed = SEED,var = list(tol = 10^-4), em = list(tol = 10^-3)))
22. )

復制代碼

<ignore_js_op>

3. sapply(sample_TM[1:2], slot, "alpha")
5. sapply(sample_TM, function(x) mean(apply(posterior(x)$$$$topics,1, function(z) - sum(z * log(z)))))
7.    

復制代碼

<ignore_js_op> 

α估計嚴重小於默認值，這表明Dirichlet分布數據集中於部分數據，文檔包括部分主題。
數值越高說明主題分布更均勻

2.    
3. #最可能的主題文檔
4. Topic <- topics(sample_TM[["VEM"]], 1)
5. table(Topic)
7. #每個Topic前5個Term
8. Terms <- terms(sample_TM[["VEM"]], 5)
10. Terms[,1:10]

復制代碼

<ignore_js_op>

2. ######### auto中每一篇文章中主題數目
3. (topics_auto <-topics(sample_TM[["VEM"]])[ grep("auto", csv[[1]]) ])
6. most_frequent_auto <- which.max(tabulate(topics_auto))
8. ######### 與auto主題最相關的10個詞語
9. terms(sample_TM[["VEM"]], 10)[, most_frequent_auto]

復制代碼

<ignore_js_op>