一梦江湖费六年——QQ群聊天分析

• 一、那些年我们加过的QQ群
  

file_data <- read.table('数据分析1excel spss.txt',


                        stringsAsFactors = F,
                        encoding = "UTF-8",sep='
',
                        quote=NULL)

for(i in 1:dim(file_data)[1]){
  dt_pattern <- regexpr('[0-9]{4}-[0-9]{2}-[0-9]{2} [0-9]+:[0-9]+:[0-9]+',file_data[i,])
  if(dt_pattern == 1) {
    user_begin <- dt_pattern+attr(dt_pattern,'match.length') + 1
    user_end <- nchar(file_data[i,])
    user_name <- substring(file_data[i,],user_begin,user_end)
    
    dt_begin <- dt_pattern
    dt_end <- dt_pattern+attr(dt_pattern,'match.length')-1
    datetime <- substring(file_data[i,],dt_begin,dt_end)
    
    text <- file_data[i+1,]
    
    data <- rbind(data, data.frame(Name = user_name,datetime = datetime,text = text))
  }
}

regexpr returns an integer vector of the same length as 
text giving the starting position of the first match 
or -1 if there is none, 
with attribute "match.length", 
an integer vector giving the length of the matched text (or -1 for no match).


The match positions and lengths are in characters unless useBytes = TRUE 
is used, when they are in bytes. 
If named capture is used 
there are further attributes "capture.start", "capture.length" and "capture.names".

> pattern <- '[0-9]{4}-[0-9]{2}-[0-9]{2}'
> strings <- "我 测试1 2016-07-12 14:13:45 测试2 2016-07-12 "
> regexpr(pattern, strings, 
+         useBytes = FALSE)
[1] 7                            #返回值

attr(,"match.length")            #属性match.length

[1] 10
> length(strings)
[1] 1

user_begin <- dt_pattern+attr(dt_pattern,'match.length') + 1
    user_end <- nchar(file_data[i,])
         user_name <- substring(file_data[i,],user_begin,user_end)

> x <- c("asfef", "qwerty", "yuiop[", "b", "stuff.blah.yech")
> nchar(x)
[1]  5  6  6  1 15
> nchar(deparse(mean))
[1] 18 17
> deparse(mean)
[1] "function (x, ...) "  "UseMethod("mean")"

nchar takes a character vector as an argument and 
returns a vector whose elements contain the sizes of
 the corresponding elements of x.

library(sqldf)
# lubridate包是为了方便取日期数据的
library(lubridate)
library(ggplot2)
library(ggthemes)
#######################################################第二部分
#每天的消息都有多少？
time <- data$datetime
p <- paste(year(time),month(time),day(time),sep = "-")
tail(p,50)
Timed <- data.frame(days = p)
mydata1 <- sqldf('select days iddays,count() Freq from 
                 Timed group by days')
#不要加AS 
mydata1 <- mydata1[order(as.Date(mydata1$iddays)),]
head(mydata1)
ggplot(mydata1,aes(x=as.Date(iddays),y=Freq))+
  geom_area(fill='mediumpurple1',alpha=0.5)+
  geom_point(shape="♠",size=3,colour='salmon')+
  xlab("时间")+ylab("消息密集度")+
  theme_solarized_2()

• 三、聊天宏观（2）日月篇
  

# 大家喜欢在星期几聊天呢？
weekdays <- wday(data$datetime)
p3 <-  ggplot(data = NULL, 
               mapping = aes(x = weekdays, 
                             fill = factor(weekdays))) 
labels <- c("周一","周二","周三",
            "周四","周五","周六","周日")
p3+geom_bar(show.legend = F,alpha=0.6)+
  scale_x_continuous(breaks = seq(1,7,by=1),
                     labels = labels)+
  xlab('星期几')+ylab('消息条数')+
  theme_solarized_2()

my.data3 <- sqldf('select hour,count(*) Freq from Time


                  group by month,day')
#取得了小时的频率
#(Freq的意思是计数后的频率存在名为Frequency的列)
head(my.data3)
#查看数据后发现有相同值
#于是我们打算合并之
mydata3 <- my.data3


#需要这一步是因为如果写的是my.data3会识别不了
my.data23 <- sqldf('select hour,SUM(Freq) Freq from mydata3
                  group by hour')
head(my.data3)

#连续聊天的次数
# 连续对话的次数，以五分钟为间隔
data$realtime <- strptime(data$datetime,'%Y-%m-%d %H:%M')
# 时间排序没有问题
# （毕竟我是读取txt后提取的，人家腾讯帮我搞好了）
head(data)
# 将数据按讨论来分组
group <- rep(1,dim(data)[1])
head(group)
for (i in 2:dim(data)[1]) {
  d <- as.numeric(difftime(data$realtime[i],
                           data$realtime[i-1],
                           units='mins'))
  if ( d < 5) {
    group[i] <- group[i-1]
    #小于5分钟的,我们认为是同一组对话
  } 
  else {group[i] <- group[i-1]+1}
  #大于5分钟，就是一组新的对话的看，所以连续对话的组数+1
}
head(group,20)
tcon <- as.data.frame(table(group))
head(tcon)
p4 <-  ggplot(data = tcon, 
              mapping = aes(x =group,y=Freq)
) 
p4 +geom_bar(aes(x = group, y = Freq, 
                 col='red',alpha=0.5),
             show.legend=F,
             stat="identity")+
  xlab('连续聊天次数')+ylab(NULL)+
  theme(axis.text.x = element_blank(),
        axis.ticks.x = element_blank())

#活跃用户前20名
#每个用户的说话频次(取前20名)
mydf <- as.data.frame(table(data$Name))
#前20名活跃的群成员
names(mydf)[1]="Name"
top20 <- mydf[order(mydf$Freq, decreasing = TRUE),][1:20,]
#绘制没有排序后的条形图
p5 <- ggplot(data = top20, 
             mapping = aes(x = Name, 
                           weight = Freq, 
                           fill = Name)) +
  xlab(NULL) + ylab(NULL)
p5 <- p5 +geom_bar(aes(x = reorder(Name, Freq), 
                       y = Freq, fill = Name,
                       alpha=0.5),show.legend=F,
                   stat="identity") + 
  coord_flip()+
  theme_solarized_2()
p5

> head(sum(top20$Freq))/sum(all$Freq)
[1] 0.5213432

> head(sum(top20$Freq[-4]))/sum(all$Freq)
[1] 0.47786

# 前10名之间的关系
data$group <- group
dfName <- as.data.frame(table(data$Name))
#前20名活跃的群成员
names(dfName)[1]="Name"
top10 <- dfName[order(dfName$Freq, decreasing = TRUE),][1:10,]
head(top10)
class(top10$Name)
library(stringr)
library(plyr)
library(reshape2)
library(igraph)
netdata <- dcast(data, Name~group, sum,
                 value.var='group',
                 subset=.(Name %in% as.character(top10$Name)[1:10])
)
#value.var=指定值是来自group
#subset=.指定来自子集
netdata1 <- ifelse(netdata[,-1] > 0, 1, 0)
#newdata1[,-1]就是去掉了ID后的
rownames(netdata1) <- netdata[,1]
relmatrix <- netdata1 %*% t(netdata1)
# 很容易看出哪两个人聊得最多
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 <- (log(E(g)$weight)+1) / max(log(E(g)$weight)+1)
V(g)$label.color <- rgb(79,148,205, 255,max = 255) #字体的颜色
V(g)$label.degree <- pi
V(g)$label.dist <- 1.5
V(g)$frame.color <- 'springgreen4' #圈子的颜色
V(g)$shape <- 'sphere'
V(g)$label.cex <- 0.7
E(g)$width <- egam
E(g)$color <- rgb(255, 181, 205, egam*255,max = 255)#线的颜色
plot(g, layout=layout1,
     vertex.color= rgb(255, 181, 205, 197,max = 255))

#提取用户名部分
dfall <- as.data.frame(table(data$Name))
names(dfall)[1]="Name"
allUserFreq<- dfall[order(dfall$Freq, decreasing = TRUE),]
write.csv(allUserFreq,"Users.csv")

#设计数据框
dataQQ <- data.frame(user_QQ = c(), 
                     nikename = c())
user_QQ <- character()
nikename <- character()
#提取出昵称（群昵称）
pattern2 <- '\([0-9]{5,11}\)'
for(i  in 1:length(allUserFreq$Name)){
  str <- as.character(allUserFreq$Name[i])
  reg <- regexpr(pattern2,str)
  qq_begin <- reg+1
  qq_end <- reg+(attr(reg,'match.length')-1)-1
  user_QQ <- substring(str,qq_begin,qq_end)
  # browser()
  nikename <- substring(str,1,reg-1)
  dataQQ <- rbind(dataQQ, 
                  data.frame(QQ = user_QQ,
                             nikename = nikename))
}
dataQQ 
write.csv(dataQQ,"QQ.csv")#保存一下

#分词
library(Rwordseg)
library(tmcn)
library(tm)
#写出又读入
write.table(dataQQ$nikename,"QQ.txt",row.names = F)
segmentCN("QQ.txt",returnType="tm")
nikename_text=readLines("QQ.segment.txt",encoding = "UTF-8")

word = lapply(X = nikename_text, FUN = strsplit, "\s")
word1=unlist(word)
#统计词频
dfname=table(word1)
dfname=sort(dfname,decreasing = T)
head(dfname)
#把词汇词频存入数据框
namedf = data.frame("word" = names(dfname), 
                    "freq" = as.numeric(dfname))
# 过滤掉1个字和词频小于10的记录 
d <- subset(namedf,
            nchar(as.character(namedf$word))>1 & namedf$freq >= mean(dfname))

#加载包和清洗后的数据
library(wordcloud2)
head(d)
wordcloud2(d, size = 1, shape='star',
           color = 'random-dark',
           backgroundColor = "white",
           fontFamily = "微软雅黑")
write.csv(d,"分词1.csv")

gd <- read.csv("guangdong.csv",header=T)
remapC(data=gd,title='广州群成员分布图',
       maptype = "广东")