R语言-文本挖掘 主题模型 文本分类

biostatistic

####需要先安装几个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脚本
combineSample.zip (720 Bytes, 下载次数: 177)

2013-8-9 14:12 上传

点击文件名下载附件

所需数据
train.zip (130.2 KB, 下载次数: 300)

2013-8-9 14:13 上传

点击文件名下载附件

大家也可以用R直接将原始数据转变成train.csv中的数据

文章所需stopwords
StopWords.zip (2.96 KB, 下载次数: 191)

2013-8-9 14:59 上传

点击文件名下载附件

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处理）

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

复制代码

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

复制代码

1. 
   
2. ###stopwords处理
   
3. ###先处理中文分词，再处理stopwords，防止全局替换丢失信息
   
4. 
   
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. }
    
15. 
    
16. 
    
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))))

复制代码

1. 
   
2. #install.packages("wordcloud"); ##需要wordcloud包的支持
   
3. library(wordcloud);
   
4. #不同文档wordcloud对比图
   
5. sample.tdm <-  TermDocumentMatrix(corpus, control = list(wordLengths = c(2, Inf)));
   
6. 
   
7. tdm_matrix <- as.matrix(sample.tdm);
   
8. 
   
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();
    

复制代码

1. 
   
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()
   

复制代码

可以看出数据分布不均匀，culture、auto等数据很少。

1. 
   
2. #按各分类画wordcloud
   
3. sample.cloud <- function(cluster, maxwords = 100) {
   
4.     words <- sample.words[which(csv$$$$type==cluster)]
   
5.     allwords <- unlist(words)
   
6. 
   
7.     wordsfreq <- sort(table(allwords), decreasing = T)
   
8.     wordsname <- names(wordsfreq)
   
9. 
   
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)
    

复制代码

4.    主题模型分析

1. 
   
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)
   
7. 
   
8. 
   
9. sample.dtm  <-  sample.dtm[,  term_tfidf  >=  0.1]
   
10.         sample.dtm  <-  sample.dtm[row_sums(sample.dtm)  >  0,]
    
11. 
    
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. )
    

复制代码

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

复制代码

α估计严重小于默认值，这表明Dirichlet分布数据集中于部分数据，文档包括部分主题。
数值越高说明主题分布更均匀

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

复制代码

1. 
   
2. ######### auto中每一篇文章中主题数目
   
3. (topics_auto <-topics(sample_TM[["VEM"]])[ grep("auto", csv[[1]]) ])
   
4. 
   
5. 
   
6. most_frequent_auto <- which.max(tabulate(topics_auto))
   
7. 
   
8. ######### 与auto主题最相关的10个词语
   
9. terms(sample_TM[["VEM"]], 10)[, most_frequent_auto]
   

复制代码

RRookie

这处理的是啥文本资料，我的Rwordseg安装好老显示 not available{:soso_e141:}

lully6

很好，正在学习！！！

biostatistic

RRookie 发表于 2013-5-2 15:14
这处理的是啥文本资料，我的Rwordseg安装好老显示 not available

Rwordseg 中文词汇分类工具包
该包与你用的R 版本有一些关系。可以参考下面这个链接说明

http://www.biostatistic.net/foru ... hread&tid=94955

zyfranklin

好文,学习了.

奔腾长江

楼主高水平，学习了

case63

挺强大的，多谢楼主分享

mafangsan

支持楼主，下载了程序慢慢学习！

biogemini

强大

支持共享

jiabiao1602

学习了，真厉害