1、导入豆瓣《庆余年》评论数据
library(pacman)
p_load(data.table,dplyr)
df <- fread("./qingyunian_all.csv",header = T,stringsAsFactors = F)
# 去除emoji表情符号
df$name <- df$name %>% gsub("<U\\++[0-9A-Z+]+>","",.)
df$comment <- df$comment %>% gsub("<U\\++[0-9A-Z+]+>","",.)
str(df)
## Classes 'data.table' and 'data.frame': 480 obs. of 6 variables:
## $ name : chr "Mikaa" "小熊" "Ten" "Wesley大表哥" ...
## $ status : chr "看过" "看过" "看过" "看过" ...
## $ time : chr "2019/12/7" "2019/12/2" "2019/11/27" "2019/11/30" ...
## $ rate : chr "很差" "很差" "很差" "很差" ...
## $ vote : int 44 44 44 44 44 44 44 44 44 44 ...
## $ comment: chr "剧情镜头都无比散乱，人物表演尴尬，场景处理粗糙，吐槽点太多，就第一集，无端拉着小女孩跑了一段就各种地位差摆出来"| __truncated__ "不是我的菜，进展缓慢，不知所云。" "好演员，烂故事。" "第一集真的尴尬溢出屏幕了，难道又是一部需要撑过前三集的剧吗？" ...
## - attr(*, ".internal.selfref")=<externalptr>
# 因为数据量比较少，所以将rate人为分成两类，“很差、较差”为0，“还行、推荐、力荐”为1
df <- df %>% mutate(sentiment=ifelse(rate=="很差" | rate=="较差",0,1))
df[sample(nrow(df),6),c(4,7)]
## rate sentiment
## 127 较差 0
## 453 很差 0
## 314 较差 0
## 363 很差 0
## 149 推荐 1
## 173 较差 0
# 转换为日期格式
df$time <- as.Date(df$time)
str(df)
## 'data.frame': 480 obs. of 7 variables:
## $ name : chr "Mikaa" "小熊" "Ten" "Wesley大表哥" ...
## $ status : chr "看过" "看过" "看过" "看过" ...
## $ time : Date, format: "2019-12-07" "2019-12-02" "2019-11-27" ...
## $ rate : chr "很差" "很差" "很差" "很差" ...
## $ vote : int 44 44 44 44 44 44 44 44 44 44 ...
## $ comment : chr "剧情镜头都无比散乱，人物表演尴尬，场景处理粗糙，吐槽点太多，就第一集，无端拉着小女孩跑了一段就各种地位差摆出来"| __truncated__ "不是我的菜，进展缓慢，不知所云。" "好演员，烂故事。" "第一集真的尴尬溢出屏幕了，难道又是一部需要撑过前三集的剧吗？" ...
## $ sentiment: num 0 0 0 0 0 0 0 0 0 0 ...
2、中文分词并将数据拆分为训练集和测试集
word_tokenizer(strings) 英语分词器
jieba <- jiebaR::worker()中文分词器
p_load(jiebaR,purrr)
wk <- worker()
tok_fun <- function(strings) {map(strings,segment,wk)}
# 对评论分词
words <- df$comment %>% tok_fun;words[5:6]
## [[1]]
## [1] "剧情" "有些" "雷人" "服化" "不" "太" "喜欢" "而且" "没有" "感觉" "到" "演员" "的" "演技"
## [15] "有" "多" "好"
##
## [[2]]
## [1] "这能" "8.0" "我" "感觉" "也" "就" "三星"
# 组成新的数据框
review <- df %>% select(-comment) %>% mutate(words=words)
head(review,1)
## name status time rate vote sentiment
## 1 Mikaa 看过 2019-12-07 很差 44 0
## words
## 1 剧情, 镜头, 都, 无比, 散乱, 人物, 表演, 尴尬, 场景, 处理, 粗糙, 吐槽, 点太多, 就, 第一集, 无端, 拉着, 小女孩, 跑, 了, 一段, 就, 各种, 地位, 差, 摆出来, 一巴掌, 打, 的, 管家, 飞, 那么, 远, 然后, 一个, 几秒, 镜头, 算是, 解释, 练, 了, 个, 什么, 霸气, 真气, 老师, 故弄玄虚, 的, 半夜, 近, 也, 没见, 有, 什么, 特殊, 的, 整个, 剧, 就, 像, 拿, 着, 一堆, 零散, 的, 积木, 胡乱, 拼凑, 一番
# 拆分训练集和测试集
setDT(review)
setkey(review,name)
set.seed(20200213)
ids <- review$name
ids.train <- sample(ids,length(ids) * 0.8)
ids.test <- setdiff(ids,ids.train)
train <- review[J(ids.train)]
test <- review[J(ids.test)]
3、文本向量化
3.1 创建词向量
p_load(text2vec)
# 创建迭代器
# itoken(strings, # 待处理字符串向量
# # 预处理函数集（去空格，去数字等）
# preprocessor = identity,
# # 分词器
# tokenizer = space_tokenizer,
# ids = _factors specified_, # 分组
# # 进度条
# progressbar = interactive())
it_train <- itoken(train$words,
ids = train$name,
progressbar = F)
# 创建训练集词汇表
vocab.train <- create_vocabulary(it_train);vocab.train
## Number of docs: 399
## 0 stopwords: ...
## ngram_min = 1; ngram_max = 1
## Vocabulary:
## term term_count doc_count
## 1: 线改 1 1
## 2: 模糊 1 1
## 3: 不太懂 1 1
## 4: 几十部 1 1
## 5: 点心 1 1
## ---
## 3529: 我 134 86
## 3530: 看 142 109
## 3531: 是 203 130
## 3532: 了 375 200
## 3533: 的 736 255
# 创建词向量
vec.train <- vocab_vectorizer(vocab.train)
3.2 创建DTM矩阵
t <- Sys.time()
dtm.train <- create_dtm(it_train,vec.train)
print(difftime(Sys.time(),t,units = "sec"))
## Time difference of 0.02393699 secs
# 查看dtm维度
dim(dtm.train)
## [1] 399 3533
# 检查dtm的文档与训练集每一行是否一一对应
identical(rownames(dtm.train),train$name)
## [1] TRUE
3.3 基于logistics的情感标注
监督式的机器学习算法很多，logistics是一个较为经典、解释性比较强的方法。使用R语言中的glmnet包。
p_load(glmnet)
NFOLDS <- 4
t <- Sys.time()
glmnet.classifier <- cv.glmnet(x = dtm.train,
y = train[["sentiment"]],
family = "binomial",
# L1惩罚
alpha = 1,
# ROC曲线
type.measure = "auc",
# 交叉验证
nfolds = NFOLDS,
# 值越高准确性越低，但速度快
thresh = 1e-5,
# 值越小速度越快
maxit = 1e5)
print(difftime(Sys.time(),t,units = "sec"))
## Time difference of 0.6961379 secs
plot(glmnet.classifier)
glmnet_BOW
print(paste("Max AUC =",round(max(glmnet.classifier$cvm),4)))
## [1] "Max AUC = 0.5886"
3.4 在测试集上验证
it_test <- itoken(test$words,
ids = test$name)
vec.test <- vocab_vectorizer(vocab.train)
dtm.test <- create_dtm(it_test,vec.test)
preds <- predict(glmnet.classifier,dtm.test,type="response")
glmnet:::auc(test$sentiment,preds)
## [1] 0.4929577
3.5 修剪停止词和低频词
stop.words <- read.table("./dict/stopwords_wf.txt",header = F,stringsAsFactors = F)
vocab <- create_vocabulary(it_train,stopwords = stop.words$V1)
# prune_vocabulary(vocabulary, #词汇表
# term_count_min = 1L, #最小次数
# term_count_max = Inf,
# doc_proportion_min = 0, #最小比例
# doc_proportion_max = 1,
# max_number_of_terms = Inf)
# 修剪词频低于2的词
pruned.vocab <- prune_vocabulary(vocab,
term_count_min = 2,
doc_proportion_max = 0.5,
doc_proportion_min = 0.001)
vectorizer <- vocab_vectorizer(pruned.vocab)
dtm <- create_dtm(it_train,vectorizer)
# 新DTM矩阵的列比原来少很多
print(rbind(dim(dtm.train),dim(dtm)))
## [,1] [,2]
## [1,] 399 3533
## [2,] 399 1165
3.6 N-grams
vocab.ngrams <- create_vocabulary(it_train,ngram = c(1L,2L))
vocab.prune <- prune_vocabulary(vocab.ngrams,term_count_min = 2,
doc_proportion_max = 0.5)
vec.ngrams <- vocab_vectorizer(vocab.prune)
dtm.train.ngrams <- create_dtm(it_train,vec.ngrams)
glmnet.ngrams.classifier <- cv.glmnet(x = dtm.train.ngrams,
y = train$sentiment,
family = "binomial",
alpha = 1,
type.measure = "auc",
nfolds = NFOLDS,
thresh = 1e-9,
maxit = 1e9)
plot(glmnet.ngrams.classifier)
glmnet_ngrams
print(paste("Max AUC =",round(max(glmnet.ngrams.classifier$cvm),4)))
## [1] "Max AUC = 0.6158"
# 测试集测试
dtm.test.ngrams <- create_dtm(it_test,vec.ngrams)
pred.test <- predict(glmnet.ngrams.classifier,
dtm.test.ngrams,
type = "response")
glmnet:::auc(test$sentiment,pred.test)
## [1] 0.5
3.7 特征哈希（Feature hashing）
在机器学习中，特征哈希也称为哈希技巧，是一种快速且空间利用率高的特征向量化方法，即将任意特征转换为向量或矩阵中的索引。它通过对特征应用散列函数并直接使用特征的散列值作为索引来工作，而不是在关联数组中查找索引。
Hash化主要在第三步，设置、形成语料文件时进行操作，之后操作一样。hashing化的好处主要有两个：
(1)、非常快，效率高
(2)、内存占用很低
vec.hash <- hash_vectorizer(hash_size = 2 ^ 14,ngram = c(1L,2L))
dtm.train.hash <- create_dtm(it_train, vec.hash)
glmnet.hash.classifier <- cv.glmnet(x = dtm.train.hash,
y = train$sentiment,
family = "binomial",
alpha = 1,
type.measure = "auc",
nfolds = NFOLDS,
thresh = 1e-5,
maxit = 1e5)
plot(glmnet.hash.classifier)
glmnet_hash
# 测试集测试
dtm.test.hash <- create_dtm(it_test,vec.hash)
pred.test.hash <- predict(glmnet.hash.classifier,
dtm.test.hash,
type = "response")
print(paste("Max AUC =",round(max(glmnet.hash.classifier$cvm),4)))
## [1] "Max AUC = 0.6217"
glmnet:::auc(test$sentiment,pred.test.hash)
## [1] 0.5246479
4、基本转换
4.1 数据转换优化方法一：标准化
一般来说，文本分析中有时候文档长度很长，但是这一指标对最终结果都是无效的，所以需要惩罚一下文档长度。
数据转化主要作用在DTM上，而且主要用于惩罚文档长度，l1（归一化）的效果就是每行相加为1，函数如下：
# 有三种可选方式：l1 l2 none
dtm_train_l1_norm = normalize(dtm.train, "l1")
4.2 数据转换优化方法二：TFIDF
TFIDF对于效率的提升很显著，一般的任务都会提升。所以，是个提升精度的好办法。同样也是作用在DTM最后一步，作用过程有些繁琐：
（1）设置TFIDF编译器tfidf = TfIdf$new()；
（2）转换成TFIDF格式fit_transform(dtm.train, tfidf)。
tfidf = TfIdf$new()
# TF-IDF矩阵
dtm.train.tfidf = fit_transform(dtm.train, tfidf)
dtm.test.tfidf = create_dtm(it_test, vec.train) %>% transform(tfidf)
4.3 重新使用logistics情感标注
glmnet.tfidf.classifier <- cv.glmnet(x = dtm.train.tfidf,
y = train$sentiment,
family = "binomial",
alpha = 1,
type.measure = "auc",
nfolds = NFOLDS,
thresh = 1e-5,
maxit = 1e5)
plot(glmnet.tfidf.classifier)
glmnet_tfidf
# 测试集测试
pred.test.tfidf <- predict(glmnet.tfidf.classifier,
dtm.test.tfidf,
type = "response")
print(paste("Max AUC =",round(max(glmnet.tfidf.classifier$cvm),4)))
## [1] "Max AUC = 0.6381"
glmnet:::auc(test$sentiment,pred.test.tfidf)
## [1] 0.4859155
网友评论