看书标记【R语言 商务数据分析实战8】

【R语言 商务数据分析实战8】

---

chapter 8

电商产品评论数据情感分析

网页爬虫+文本数据预处理>>对数据进行情感分析>>用LDA模型对正、负评论进行主题分析
文本数据预处理主要有文本去重、文本清洗、分词、去除停用词，其中中文的分词和英文的分词会用到不同的程序包，R中关分词的程序包主要都对英文比较可爱，后期想看看关于自然语言的相关知识。

8.2 任务实现

获取评论页面网页源码（数据获取）

# 设置工作目录
setwd()

# 对一个URL进行测试
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(RCurl)  # 需要使用getURL函数
library(jsonlite)  # Version:1.5  需要使用fromJSON函数

# 读取网页源码
web <- getURL(url, .encoding = 'GBK')

# 代码 8-2

# 由于读取到的源码不是标准的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  # 评论内容

# 代码 8-3

#  批量提取评论数据
#  首先先构建评论地址
# 其中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_comment98vv80998&productId=1106432&score=3&sortType=5&page=',i-1,'&pageSize=10&isShadowSku=0&rid=0&fold=1')
  neg_url[[i]] <- paste0('https://club.jd.com/comment/productPageComments.action?callback=fetchJSON_comment98vv80998&productId=1106432&score=1&sortType=5&page=',i-1,'&pageSize=10&isShadowSku=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){
  # 好评数据提取
  pos_web <- getURL(as.character(content_url[i, 1]), .encoding = 'GBK')
  pos_web <- substr(pos_web,
                    nchar("fetchJSON_comment98vv80926") + 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(2)

  # 差评数据提取
  neg_web <- getURL(as.character(content_url[i, 2]), .encoding = 'GBK')
  neg_web <- substr(neg_web,
                    nchar("fetchJSON_comment98vv80926") + 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(2)
}
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(pos_reviews))
head(neg_reviews)

reviews <- rbind.data.frame(pos_reviews, neg_reviews)

# 将评论数据输出
write.csv(reviews, "./tmp/reviews.csv", row.names = FALSE)

对电商产品评论数据进行预处理

# 设置工作目录
setwd()
# 去重，去除完全重复的数据
meidi_reviews <- read.csv("./data/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)  # Version:0.9.1
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)  # Version:0.2.0
#  统计词频
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)

评论数据情感倾向分析

# 【匹配情感词】
# 设置工作目录
setwd()
# 载入分词结果
word <- read.csv("./tmp/word.csv", stringsAsFactors = FALSE)

# 情感词定位
# 读入正面、负面情感评价词
pos.comment <- read.table("./data/正面评价词语（中文）.txt")
neg.comment <- read.table("./data/负面评价词语（中文）.txt")
pos.emotion <- read.table("./data/正面情感词语（中文）.txt")
neg.emotion <- read.table("./data/负面情感词语（中文）.txt")

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)

使用LDA模型进行主题分析

# 【建立文档-词条矩阵】
# 设置工作目录
setwd()

# 载入情感分析后的数据
posdata <- read.csv("./tmp/posdata.csv", stringsAsFactors = FALSE)
negdata <- read.csv("./tmp/negdata.csv", stringsAsFactors = FALSE)

# 构建语料库
library(NLP)
library(tm)  # Version:0.7-1
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)