為了了解圖書館咨詢群的聊天情況，更好的了解學生情況，我對從3月份到目前圖書館咨詢群的聊天記錄進行了個初步的分析。對未來圖書館群管理做一個簡單的建議。全篇分為三個步驟：
- 數據準備和整理
- 基礎分析和高級分析
- 結論
# 首先，是數據準備和整理
library(stringr)
library(plyr)
library(lubridate)
library(ggplot2)
library(reshape2)
library(igraph)
# 下載QQ群聊天記錄txt
root = "/Users/zhangyi/Desktop/"
file = paste(root, "QQ2(427968708).txt", sep="")
file.data <- scan(file, what = "", sep="\n", encoding="UTF-8")
data <- data.frame(user.name=c(), time=c(),text=c())
time <- c();
user.name <- c();
text <- c()
file.data
我們需要先將其格式分為用戶、時間和文本內容三個簡單部分，以便后續進行分析。
# 遍歷所有的有效數據
for(i in 3:length(file.data)){
reg.time <- regexpr("[0-9]{4}-[0-9]{2}-[0-9]{2} [0-9]+:[0-9]+:[0-9]+", file.data[i])
if(reg.time==1){
data <-rbind(data, data.frame(time=time,user.name=user.name,text=text))
text <- c()
begin <- reg.time;end <- reg.time+attr(reg.time, "match.length")-1
time <- substr(file.data[i], begin, end)
begin <- as.numeric(reg.time+attr(reg.time, "match.length")+1);
end <- nchar(file.data[i])
user.name <- substr(file.data[i], begin,end)
}else{
text <- paste(text,file.data[i])
}
}
# 去掉NA
for(i in 1:dim(data)[1])
if(is.na(data[i,1]))
{
if(is.na(data[i,2]))
{
if(is.na(data[i,3]))
{
data<- data[-i,]
}
}
}
# 轉換格式
data$text <- as.character(data$text)
data$user.name <- as.character(data$user.name)
轉換前
轉換后
data-文本高級分析
# 文本處理data
# 格式化，將每個用戶的所有發言合并
user.name <- unique(data$user.name) # 所有不重復的用戶名單列表
text<-c();text.num<-c()
for(i in 1:length(user.name)){
text.i <- data$text[which(data$user.name==user.name[i])]
text.i.num <-length(text.i)
for(j in 1:text.i.num){
text[i]<-paste(text[i],text.i[j],sep="")
}
text.num[i]<-text.i.num
}
user.text <- data.frame(user.name=user.name,text=text,text.num=text.num)
user.text$user.name <- as.character(user.text$user.name)
user.text$text <- as.character(user.text$text)
user.text-各個用戶的發言合并以及條目
# 非文本處理newdata，主要用來進行基礎分析
# 將字符串中的日期和時間劃分為不同變量
temp1 <- str_split(data$time,' ')
result1 <- ldply(temp1,.fun=NULL)
names(result1) <- c('date','clock')#分離年月日
temp2 <- str_split(result1$date,'-')
result2 <- ldply(temp2,.fun=NULL)
names(result2) <- c('year','month','day')# 分離小時分鐘
temp3 <- str_split(result1$clock,':')
result3 <- ldply(temp3,.fun=NULL)
names(result3) <- c('hour','minutes','second')# 合并數據
newdata <- cbind(data,result1,result2,result3)
# 轉換日期為時間格式
newdata$date <- ymd(newdata$date)
newdata-沒用星期數據
# 提取星期數據
newdata$wday <- wday(newdata$date)# 轉換數據格式
newdata$month <- ordered(as.numeric(newdata$month) )
newdata$year <- ordered(newdata$year)
newdata$day <- ordered(as.numeric(newdata$day))
newdata$hour <- ordered(as.numeric(newdata$hour))
newdata$wday <- ordered(newdata$wday)
newdata
# 非文本基礎分析
# 一星期中每天合計的聊天記錄次數，可以看到該 QQ 群的聊天興致隨星期的分布。
qplot(wday,data=newdata,geom='bar')
周內分布
很明顯的可以看到周三的發言數量是最多的，而周一周二顯然比較低迷。同時，周四和周日的也不錯。
#聊天興致在一天中的分布。
qplot(hour,data=newdata,geom='bar')
一天分布
早上十點和下午五點六點是聊天高峰期，晚上十點也相對鼻尖活躍。到了十一點后基本就沒人了。
#前十大發言最多用戶&話癆
user <- as.data.frame(table(newdata$user.name)) # 用 table 統計頻數
user <- user[order(user$Freq,decreasing=T),]
user[1:10,] # 顯示前十大發言人的 ID 和 發言次數
topuser <- user[1:10,]$Var1 # 存前十大發言人的 ID
user_hl <- data$user.name
user_hl.n <- as.data.frame(table(user_hl))
user_hl.n.20 <- user_hl.n[order(user_hl.n[,2],decreasing=T),]
user_hl.n.20 <- user_hl.n.20[1:20,]
ggplot(data=user_hl.n.20,aes(x=user_hl,y=Freq))+
geom_bar(stat='identity')+coord_flip()+
theme(text = element_text(family = 'STKaiti'))
#coord_flip()的作用就是講條形圖這些這樣90度的旋轉。
話癆1
話癆2
# 根據活躍天數統計前十大活躍用戶
# 活躍天數計算# 將數據展開為寬表，每一行為用戶，每一列為日期，對應數值為發言次數
flat.day <- dcast(newdata,user.name~date,length,value.var='date')
flat.mat <- as.matrix(flat.day[-1]) #轉為矩陣# 轉為0-1值，以觀察是否活躍
flat.mat <- ifelse(flat.mat>0,1,0)# 根據上線天數求和
topday <- data.frame(flat.day[,1],apply(flat.mat,1,sum))
names(topday) <- c('id','days')
topday <- topday[order(topday$days,decreasing=T),]# 獲得前十大活躍用戶
topday[1:10,]
活躍天數
# 尋找聊天峰值日
# 觀察每天的發言次數# online.day為每天的發言次數
online.day <- sapply(flat.day[,-1],sum) # -1 表示去除第一列，第一列是 ID
tempdf <- data.frame(time=ymd(names(online.day)),online.day )
qplot(x=time,y=online.day ,ymin=0,ymax=online.day ,data=tempdf,geom='linerange')
# 觀察到有少數峰值日，看超過200次發言以上是哪幾天
names(which(online.day>200))
每天活躍度-聊天次數
# 每天活躍人數統計
# 根據flat.day數據觀察每天活躍用戶變化# numday為每天發言人數
numday <- apply(flat.mat,2,sum)
tempdf <- data.frame(time=ymd(names(numday)),numday)
qplot(x=time,y=numday,ymin=0,ymax=numday,data=tempdf,geom='linerange')
每天活躍人數
四月好像有一天特別活躍。。。
# 十強選手的日內情況
# 再觀察十強選手的日內情況
flat.hour <- dcast(newdata,user.name~hour,length,value.var='hour',subset=.(user.name %in% topuser)) # 平行坐標圖
hour.melt <- melt(flat.hour)
p <- ggplot(data=hour.melt,aes(x=variable,y=value))
p + geom_line(aes(group=user.name,color=user.name))+theme_bw()+theme(legend.position = "none")
各有千秋
# 連續對話的次數，以三十分鐘為間隔
newdata$realtime <- strptime(newdata$time,'%Y-%m-%d %H:%M')# 時間排序有問題，按時間重排數據
newdata2 <- newdata[order(newdata$realtime),]# 將數據按討論來分組
group <- rep(1,dim(newdata2)[1])
for (i in 2:dim(newdata2)[1]) {
d <- as.numeric(difftime(newdata2$realtime[i],
newdata2$realtime[i-1],
units='mins'))
if ( d < 30) {
group[i] <- group[i-1]
}
else {group[i] <- group[i-1]+1}
}
barplot(table(group))
連續對話的次數
看來也就那一天多了。
# 畫社交網絡圖
# 得到 93 多組對話
newdata2$group <- group
# igraph進行十強之間的網絡分析
# 建立關系矩陣，如果兩個用戶同時在一次群討論中出現，則計數+1
newdata3 <- dcast(newdata2, user.name~group, sum,value.var='group',subset=.(user.name %in% user[1:10,]$Var1))#
newdata4 <- ifelse(newdata3[,-1] > 0, 1, 0)
rownames(newdata4) <- newdata3[,1]
relmatrix <- newdata4 %*% t(newdata4)# 很容易看出哪兩個人聊得最多
deldiag <- relmatrix-diag(diag(relmatrix))
which(deldiag==max(deldiag),arr.ind=T)# 根據關系矩陣畫社交網絡畫
g <- graph.adjacency(deldiag,weighted=T,mode='undirected')
g <-simplify(g)
V(g)$label<-rownames(relmatrix)
V(g)$degree<- degree(g)
layout1 <- layout.fruchterman.reingold(g)#
egam <- 10*E(g)$weight/max(E(g)$weight)
egam <- (log(E(g)$weight)+1) / max(log(E(g)$weight)+1) +
V(g)$label.cex <- V(g)$degree / max(V(g)$degree)+
V(g)$label.color <- rgb(0, 0, .2, .8) +
V(g)$frame.color <- NA +
E(g)$width <- egam +
# E(g)$color <- rgb(0, 0, 1, egam)
plot(g, layout=layout1,vertex.label.family="STKaiti")
社交圖
# 找到配對
# 找到配對
pairlist=data.frame(pair=1:length(attributes(deldiag)$dimnames[[1]]))
rownames(pairlist)<-attributes(deldiag)$dimnames[[1]]
for(i in(1:length(deldiag[1,]))){
pairlist[i,1]<-attributes(which(deldiag[i,]==max(deldiag[i,]),arr.ind=T))$names[1]
}
pairlist
pairmatrix=data.frame(pairA=1:length(attributes(deldiag)$dimnames[[1]]),pairB=1:length(attributes(deldiag)$dimnames[[1]]))
pairmatrix=data.frame(pair=1:length(attributes(deldiag)$dimnames[[1]]))
for(i in (1:dim(deldiag)[1])){
deldiag[i,] <- ifelse(deldiag[i,] == max(deldiag[i,]), 1, 0)
}
deldiag
# 分詞
library(jiebaR)
cutter<-worker()
jiebatext <-c()
for(i in 1:length(user.text$text)){
jiebatext <- c(jiebatext,list(cutter <= user.text$text[i]))
}#
#分詞結束，現在開始統計詞頻
library(wordcloud2)
library(dplyr)
target_words <- unlist(jiebatext)
p=as.data.frame(table(unlist(target_words)))%>%
arrange(desc(Freq))
wordcloud2(p)
詞云
大家都挺喜歡圖片和表情的。把的、0等詞刪除后再看：
# 刪除詞
target_words=gsub(pattern="[的],[NA],[0]","",target_words);
q=as.data.frame(table(unlist(target_words)))%>%
arrange(desc(Freq))
wordcloud2(q)
刪除部分后
果然大家的關注點在圖書館上和借書上。“我”字比較多，看來大多是自我介紹。。。
# 散點圖
library(tm)
ovid <- Corpus(VectorSource(jiebatext))
ovid <- tm_map(ovid, FUN = removeWords,c("圖片", "表情"))
dtm <- DocumentTermMatrix(ovid)
qq.matrix <-as.matrix(dtm)
qq.freq <- apply(qq.matrix,2,sum)
qq.freq.top<-rev(sort(qq.freq))[1:30]
plot(qq.freq);text(c(1:length(qq.freq),qq.freq,names(qq.freq)))
詞匯散點圖
本該看到詞匯的散點圖，沒想到詞匯有點多。
from <-c(); to<-c()
for(i in 1:length(user.text$user.name)){
from <- c(from, rep(user.text$user.name[i],length(jiebatext[[i]])))
to<-c(to,jiebatext[[i]])
}
from[which(from=="")] <- "數據及內無用戶名"
library(igraph)
init.igraph <- function(data,dir=F,rem.multi=T){
labels <- union(unique(data[,1]),unique(data[,2]))
ids <- 1:length(labels);names(ids)<-labels
from <- as.character(data[,1]);to<- as.character(data[,2])
edges <- matrix(c(ids[from],ids[to]),nc=2)
g <- graph.empty(directed=dir)
g <-add.vertices(g,length(labels))
V(g)$labels=labels
g <- add.edges(g,t(edges))
if(rem.multi){
E(g)$weight <- count.multiple(g)
g <- simplify(g, remove.multiple = TRUE, remove.loops = TRUE, edge.attr.comb = 'mean')
}
g
}
g.dir <- init.igraph(data.frame(from=from,to=to), T)
# 核心詞匯網絡圖
std.degree.words=10
words.index <- (degree(g.dir, mode="in") >= std.degree.words)
words <- degree(g.dir, mode="in")[words.index]
names(words) <- V(g.dir)[words.index]$labels
labels=NA
labels[words.index] <- names(words)
V(g.dir)$size=1
max.d <- max(words)
min.d <- min(words)
V(g.dir)[words.index]$size = 2*(words-min.d)/(max.d-min.d)+2
V(g.dir)$color = "white"
V(g.dir)[words.index]$color = "red"
#svg(filename=paste(root,"words.svg",sep=""), width = 40, height =40)
png(filename="sin3.png",width=800,height=800)
par(family='STKaiti')
plot(g.dir,layout=layout.fruchterman.reingold,
vertex.label=labels,
vertex.label.cex=V(g.dir)$size/2,
vertex.color=V(g.dir)$color,
vertex.label.family="STKaiti")
dev.off()
核心詞匯
其中可以看到，除了NA外，借書，保存是常見的詞匯，大家的問題也常集中在這上面。
# 核心用戶網絡圖
std.degree.user=20
user.index <- (degree(g.dir, mode="out") >= std.degree.user)
user <- degree(g.dir, mode="out")[user.index]
names(user) <- V(g.dir)[user.index]$labels
labels=NA
labels[user.index] <- names(user)
V(g.dir)$size=1
max.d <- max(user)
min.d <- min(user)
V(g.dir)[user.index]$size = 2*(user-min.d)/(max.d-min.d)+2
V(g.dir)$color = "white"
V(g.dir)[user.index]$color = "green"
png(filename="sin2.png",width=800,height=800)
par(family='STKaiti')
plot(g.dir,layout=layout.fruchterman.reingold,
vertex.label=labels,
vertex.label.cex=V(g.dir)$size/3,
vertex.color=V(g.dir)$color,
vertex.label.family="STKaiti",
vertex.label.color="blue")
dev.off()
用戶散點圖
總結
通過上述的分析，我們得到了以下結論：
- 最活躍的時間。通過最活躍的時間，我們可以知道群成員的活躍時間在周內的哪一天，在一天的哪個時間段。這樣發布消息的時間就有了參考。
- 最活躍的人和話癆。通過最活躍的人，可以了解群核心成員。
- 活躍的人數。通過了解活躍的人數，可以間接了解群的活躍度。
- 社交網絡。建立起社交網絡，可以知道群中成員的互動關系。
- 詞云。通過詞云可以知道群內主要話題關鍵詞。
- 重點詞條網絡。通過建立關鍵詞網絡，可以知道哪些話題帶動了更多的用戶參與。入度越大，說明該話題帶動的了更多的用戶參與討論。
- 重點用戶網絡。而建立了重點用戶網絡，則可以了解哪些用戶涉及的哪些關鍵話題詞條。出度越大，表示該用戶涉及的話題詞條越多。
參考：
- 《R語言與網站分析》
- 僅用四行代碼就可以挖掘你的QQ聊天記錄
- 使用 R 語言挖掘 QQ 群聊天記錄
- 今天來挖挖你的QQ聊天記錄
