前言
开篇碎碎念：R语言老师出的实验题，在原本代码的基础上进行修改才跑通的，小小记录一下(≧▽≦)
一、案例背景
随着电子商务的迅速发展和网络购物的流行，人们对于网络购物的需求变得越来越高，也给电商企业带来巨大的发展机遇，与此同时，这种需求也推动了更多电商企业的崛起，引发了激烈的竞争。而在这种激烈竞争的大背景下，除了提高商品质量、压低价格外，了解更多消费者的心声对电商企业来说也变得越来越有必要。其中非常重要的方式就是对消费者的评论文本数据进行内在信息的分析。
本案例主要针对京东商城上美的电热水器的文本评论数据进行分析,流程如下。
相关文件下载链接：
- 下载链接：https://pan.baidu.com/s/1VG_XT5jAinCUt6xpQHzgDg?pwd=bqtu
- 提取码：bqtu
二、代码
1.数据爬取
url <-'https://club.jd.com/comment/productPageComments.action?callback=fetchJSON_comment98vv80998&productId=1106432&score=0&sortType=5&page=0&pageSize=10&isShadowSku=0&rid=0&fold=1'
library(httr)
library(jsonlite)
response <- GET(url)
web <- content(response,as="text",encoding="GBK")
# 由于读取到的源码不是标准的JSON格式，因此需要将符合JSON格式的内容提取出来
web <- substr(web, nchar("fetchJSON_comment98vv80998") + 2, nchar(web) - 2)
# 将 JSON 格式数据转为 R 语言列表格式
result <- jsonlite::fromJSON(web)
# 提取评论数据
result$comments$referenceName # 品牌名
result$comments$nickname # 用户昵称
result$comments$creationTime # 发表时间
result$comments$content # 评论内容
# 批量提取评论数据
# 首先先构建评论地址
# 其中score=1表示差评数据，3表示好评数据
pos_url <- list() # 初始化好评评论地址集
neg_url <- list() # 初始化差评评论地址集
n <- 100 # 该商品评论页数最大 100 页
for(i in 1:n){
pos_url[[i]] <- paste0('https://club.jd.com/comment/productPageComments.action?callback=fetchJSON_comm
ent98vv80998&productId=1106432&score=3&sortType=5&page=',i-1,'&pageSize=10&isShadowS
ku=0&rid=0&fold=1')
neg_url[[i]] <- paste0('https://club.jd.com/comment/productPageComments.action?callback=fetchJSON_comm
ent98vv80998&productId=1106432&score=1&sortType=5&page=',i-1,'&pageSize=10&isShadowS
ku=0&rid=0&fold=1')
}
content_url <- data.frame(pos_url = unlist(pos_url), neg_url = unlist(neg_url))
head(content_url)
# 批量提取评论数据
pos_content <- list()
neg_content <- list()
for(i in 1:n){
response_pos <- GET(as.character(content_url[i, 1]))
pos_web <- content(response_pos, as = "text", encoding = "GBK")
pos_web <- substr(pos_web, nchar("fetchJSON_comment98vv80998") + 2, nchar(pos_web) - 2)
pos_result <- jsonlite::fromJSON(pos_web)
pos_content[[i]] <- data.frame(referenceName = pos_result$comments$referenceName,
nickname = pos_result$comments$nickname,
creationTime = pos_result$comments$creationTime,
content = pos_result$comments$content)
message("pos_page", i)
Sys.sleep(3)
response_neg <- GET(as.character(content_url[i, 2]))
neg_web <- content(response_neg, as = "text", encoding = "GBK")
neg_web <- substr(neg_web, nchar("fetchJSON_comment98vv80998") + 2, nchar(neg_web) - 2)
neg_result <- jsonlite::fromJSON(neg_web)
neg_content[[i]] <- data.frame(referenceName = neg_result$comments$referenceName,
nickname = neg_result$comments$nickname,
creationTime = neg_result$comments$creationTime,
content = neg_result$comments$content)
message("neg_page", i)
Sys.sleep(3)
}
pos_reviews <- Reduce(rbind, pos_content)
pos_reviews$type <- rep('pos', nrow(pos_reviews))
head(pos_reviews)
neg_reviews <- Reduce(rbind, neg_content)
neg_reviews$type <- rep('neg', nrow(neg_reviews))
head(neg_reviews)
reviews <- rbind.data.frame(pos_reviews, neg_reviews)
#创建文件路径，若以创建则不需要重复创建
dir.create("./tmp")
# 将评论数据输出
write.csv(reviews, "./tmp/reviews.csv", row.names = FALSE)
2.数据预处理
# 去重，去除完全重复的数据
meidi_reviews <- read.csv("./tmp/reviews.csv", stringsAsFactors = FALSE)
meidi_reviews <- unique(meidi_reviews[, c(4, 5)]) # 对评论内容去重
reviews <- meidi_reviews$content
# 去除去除英文字母、数字等
reviews <- gsub("[a-zA-Z0-9]", "", reviews)
# 由于评论主要为京东美的电热水器的评论，因此去除这些词语
reviews <- gsub("京东", "", reviews)
reviews <- gsub("美的", "", reviews)
reviews <- gsub("电热水器", "", reviews)
reviews <- gsub("热水器", "", reviews)
# 分词
library(jiebaR)
cutter <- worker(type = "tag", stop_word = "./data/stoplist.txt")
seg_word <- list()
for(i in 1:length(reviews)){
seg_word[[i]] <- segment(reviews[i], cutter)
}
head(seg_word, 40)
# 将词语转为数据框形式，一列是词，一列是词语所在的句子ID，最后一列是词语在该句子的位置
n_word <- sapply(seg_word, length) # 每个词条的词个数
index <- rep(1:length(seg_word), n_word) # 每个词条有多少个词就复制多少次
type <- rep(meidi_reviews$type, n_word)
nature <- unlist(sapply(seg_word, names))
result <- data.frame(index, unlist(seg_word), nature, type)
colnames(result) <- c("id", "word","nature", "type")
head(result)
# 将每个词在每个词条的位置标记出来
n_word <- sapply(split(result,result$id), nrow)
index_word <- sapply(n_word, seq_len)
index_word <- unlist(index_word)
result$index_word <- index_word
head(result)
# 提取含有名词类的评论数据
is_n <- subset(result, grepl("n", result$nature), "id")
result <- result[result$id %in% is_n$id, ]
# 绘制词云
# 查看分词效果，最快捷的方式是绘制词云
library(wordcloud2)
# 统计词频
word.frep <- table(result$word)
word.frep <- sort(word.frep, decreasing = TRUE)
word.frep <- data.frame(word.frep)
head(word.frep)
wordcloud2(word.frep[1:100,], color = "random-dark")
write.csv(result, "./tmp/word.csv", row.names = FALSE)
3.数据分析（情感倾向）
# 载入分词结果
word <- read.csv("./tmp/word.csv", stringsAsFactors = FALSE)
# 情感词定位
# 读入正面、负面情感评价词
pos.comment <- read.table("./data/词库/正面评价词语（中文）.txt",fileEncoding = "GB2312")
neg.comment <- read.table("./data/词库/负面评价词语（中文）.txt",fileEncoding = "GB2312")
pos.emotion <- read.table("./data/词库/正面情感词语（中文）.txt",fileEncoding = "GB2312")
neg.emotion <- read.table("./data/词库/负面情感词语（中文）.txt",fileEncoding = "GB2312")
positive <- rbind(pos.comment, pos.emotion)
negative <- rbind(neg.comment, neg.emotion)
# 查看正负面情感词表是否有相同的词语，如果有则根据情况将其删除
sameWord <- intersect(positive[, 1], negative[, 1])
positive <- data.frame(setdiff(positive[, 1], sameWord))
negative <- data.frame(setdiff(negative[, 1], sameWord))
# 给正面、负面词语赋权重，正面词语为1，负面为-1
positive$weight <- rep(1, length(positive))
colnames(positive) <- c("word", "weight")
negative$weight <- rep(-1, length(negative))
colnames(negative) <- c("word", "weight")
# 将正面、负面词语合并
posneg <- rbind(positive, negative)
head(posneg, 20)
# 将分词结果与正负面情感词表合并，定位情感词
library(plyr)
data.posneg <- join(word, posneg, by = "word", match = "first")
head(data.posneg)
# 【修正情感倾向】
# 根据情感词前是否有否定词或双层否定词对情感值进行修正
# 载入否定词表
notdict <- read.table("./data/not.csv", stringsAsFactors = FALSE)
notdict$weight <- rep(-1, length(notdict))
# 处理否定修饰词
data.posneg$amend_weight <- data.posneg$weight
only_inclination <- data.posneg[!is.na(data.posneg$weight),] # 只保留有情感值的词语
index <- as.numeric(row.names(only_inclination))
# 词语对应整个文档的位置
for(i in 1:nrow(only_inclination)){
# 提取第i个情感词所在的评论
review <- data.posneg[which(data.posneg$id == only_inclination[i,]$id), ]
# 第i个情感值在该文档的位置
affective <- only_inclination[i,]$index_word
if(affective == 2){ # 如果情感词的位置是某个文档的第二个词
# 如果情感词前的一个词在否定词表内出现则求出个数
a.1 <- sum(review$word[affective - 1] %in% notdict[,1])
# 如果求出的和为奇数，认为该词为相反的情感值
if(a.1 == 1) data.posneg$amend_weight[index[i]] <- -data.posneg$weight [index[i]]
}else if(affective >= 3){
a.2 <- sum(review$word[affective - c(1,2)] %in% notdict[,1])
if(a.2 == 1) data.posneg$amend_weight[index[i]] <- -data.posneg$weight [index[i]]
}
}
# 更新只保留情感值的数据
# 只保留有情感值的词语
only_inclination <- data.posneg[!is.na(data.posneg$amend_weight),]
index <- as.numeric(row.names(only_inclination))
head(only_inclination)
# 计算每条评论的情感值
meidi.posneg <- aggregate(only_inclination$amend_weight,by = list(only_inclination$id), sum)
head(meidi.posneg)
colnames(meidi.posneg) <- c("id", "weight")
meidi.posneg <- meidi.posneg[-which(meidi.posneg$weight == 0), ]
meidi.posneg$a_type <- rep(NA, nrow(meidi.posneg))
meidi.posneg$a_type[which(meidi.posneg$weight > 0)] <- "pos"
meidi.posneg$a_type[which(meidi.posneg$weight < 0)] <- "neg"
head(meidi.posneg)
result <- join(meidi.posneg, word[,c(1, 4)], by = "id", type = "left", match = "first")
head(result)
#计算情感分析的准确率
Confusion_matrix<-table(result$type,result$a_type)
Confusion_matrix
(Confusion_matrix[1,1]+Confusion_matrix[2,2]) / sum(Confusion_matrix)
# 【查看情感分析效果】
# 提取正负面评论信息
head(meidi.posneg)
ind.neg <- subset(meidi.posneg, meidi.posneg$weight < 0, select = c("id"))
ind.pos <- subset(meidi.posneg,meidi.posneg$weight > 0, select = c("id"))
negdata <- word[word$id %in% ind.neg$id, ]
posdata <- word[word$id %in% ind.pos$id, ]
head(negdata)
head(posdata)
# 绘制词云
# 查看分词效果，最快捷的方式是绘制词云
library(wordcloud2)
# 统计正面评论词频
posFrep <- table(posdata$word)
posFrep <- sort(posFrep, decreasing = TRUE)
posFrep <- data.frame(posFrep)
head(posFrep)
wordcloud2(posFrep[1:100, ], color = "random-dark")
# 统计负面面评论词频
negFrep <- table(negdata$word)
negFrep <- sort(negFrep, decreasing = TRUE)
negFrep <- data.frame(negFrep)
head(negFrep)
wordcloud2(negFrep[1:100, ], color = "random-dark")
write.csv(negdata, "./tmp/negdata.csv", row.names = FALSE)
write.csv(posdata, "./tmp/posdata.csv", row.names = FALSE)
4.使用LDA模型进行主题分析
# 载入情感分析后的数据
posdata <- read.csv("./tmp/posdata.csv", stringsAsFactors = FALSE)
negdata <- read.csv("./tmp/negdata.csv", stringsAsFactors = FALSE)
# 构建语料库
library(NLP)
library(tm)
pos.corpus <- Corpus(VectorSource(posdata$word))
neg.corpus <- Corpus(VectorSource(negdata$word))
# 词条-文档关系矩阵
pos.gxjz <- DocumentTermMatrix(pos.corpus,
control = list(wordLengths = c(1, Inf),
bounds = list(global = 5, Inf),
removeNumbers = TRUE))
neg.gxjz <- DocumentTermMatrix(neg.corpus,
control = list(wordLengths = c(1, Inf),
bounds = list(global = 5, Inf),
removeNumbers = TRUE))
# 【主题数寻优】
# 构造主题间余弦相似度函数
library(topicmodels)
lda.k <- function(gxjz){
# 初始化平均余弦相似度
mean_similarity <- c()
mean_similarity[1] = 1
# 循环生成主题并计算主题间相似度
for(i in 2:10){
control <- list(burnin = 500, iter = 1000, keep = 100)
Gibbs <- LDA(gxjz, k = i, method = "Gibbs", control = control)
term <- terms(Gibbs, 50) # 提取主题词
# 构造词频向量
word <- as.vector(term) # 列出所有词
freq <- table(word) # 统计词频
unique_word <- names(freq)
mat <- matrix(rep(0, i * length(unique_word)), # 行数为主题数，列数为词
nrow = i, ncol = length(unique_word))
colnames(mat) <- unique_word
# 生成词频向量
for(k in 1:i){
for(t in 1:50){
mat[k, grep(term[t,k], unique_word)] <- mat[k, grep(term[t, k], unique_word)] + 1
}
}
p <- combn(c(1:i), 2)
l <- ncol(p)
top_similarity <- c()
for(j in 1:l){
# 计算余弦相似度
x <- mat[p[, j][1], ]
y <- mat[p[, j][2], ]
top_similarity[j] <- sum(x * y) / sqrt(sum(x^2) * sum(y ^ 2))
}
mean_similarity[i] <- sum(top_similarity) / l
message("top_num ", i)
}
return(mean_similarity)
}
# 计算平均主题余弦相似度
pos_k <- lda.k(pos.gxjz)
neg_k <- lda.k(neg.gxjz)
par(mfrow = c(2, 1))
plot(pos_k, type = "l")
plot(neg_k, type = "l")
par(mfrow = c(1, 1))
# 【进行LDA主题分析】
# LDA主题分析
control <- list(burnin = 500, iter = 1000, keep = 100)
neg.gibbs <- LDA(neg.gxjz, k = 3, method = "Gibbs", control = control)
pos.gibbs <- LDA(pos.gxjz, k = 3, method = "Gibbs", control = control)
pos.termsl <- terms(pos.gibbs, 10)
neg.termsl <- terms(neg.gibbs, 10)
pos.termsl
neg.termsl
# 将主题结果写出
write.csv(neg.termsl, "./tmp/neg_termsl.csv", row.names = FALSE)
write.csv(pos.termsl, "./tmp/pos_termsl.csv", row.names = FALSE)
总结
原版代码使用的是RCurl包中的getURL()函数进行的页面的读取，但之后总是有一些小问题，索性换一种方法采用httr进行页面读取，这里使用的LDA模型是一种主题模型，用于将文本数据表示为主题分布。它可以用于文本分类、信息检索、推荐系统等应用场景，能够自动发现文本中的主题，并且有很强可解释性。
963
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
