分析nCoV2019資料集中討論者之網路關係

系統設置

安裝需要的packages

packages = c("readr", "dplyr", "jiebaR", "tidyr", "tidytext", "igraph", "topicmodels", "ggplot2", "stringr")
existing = as.character(installed.packages()[,1])
for(pkg in packages[!(packages %in% existing)]) install.packages(pkg)

載入packages

library(readr)
library(dplyr)
library(jiebaR)
library(tidyr)
library(tidytext)
library(igraph)
library(topicmodels)
library(stringr)
library(ggplot2)

讀取資料

資料描述

• 透過中山管院文字分析平台，取得PTT武漢肺炎討論專版2020-01-26 ~ 2020-04-12的資料，以關鍵字為“口罩”，共取得721篇文章，66792筆回覆。

載入PTT武漢肺炎版資料

# 文章資料
posts <- read_csv("./nCoV_2019_mask_articleMetaData.csv")
posts

# 回覆資料
reviews <- read_csv("./nCoV_2019_mask_articleReviews.csv")
reviews

# 選取需要的欄位
reviews <- reviews %>%
      select(artUrl, cmtPoster, cmtStatus, cmtContent)
reviews

資料預覽

posts %>% 
  group_by(artDate) %>%
  summarise(count = n())%>%
  ggplot(aes(artDate,count))+
    geom_line(color="blue", size=1)+
    theme_classic()

發文者數量

length(unique(posts$artPoster))

[1] 361

回覆者數量

length(unique(reviews$cmtPoster))

[1] 8352

總共有參與的人數

allPoster <- c(posts$artPoster, reviews$cmtPoster)
length(unique(allPoster))

[1] 8453

整理所有參與人

# 整理所有出現過得使用者
# 如果它曾發過文的話就標註他爲poster
# 如果沒有發過文的話則標註他爲replyer
userList <- data.frame(user=unique(allPoster)) %>%
              mutate(type=ifelse(user%in%posts$artPoster, "poster", "replyer"))
userList

建立社群網路圖

將原文與回覆Join起來

# 把原文與回覆依據artUrl innerJoin起來
posts_Reviews <- merge(x = posts, y = reviews, by = "artUrl")
posts_Reviews

篩選欄位

# 取出 cmtPoster(回覆者)、artPoster(發文者)、artUrl(文章連結) 三個欄位
link <- posts_Reviews %>%
      select(cmtPoster, artPoster, artUrl)
link

建立網路關係

reviewNetwork <- graph_from_data_frame(d=link, directed=T)
reviewNetwork

IGRAPH 3db0755 DN-- 8452 66792 -- 
+ attr: name (v/c), artUrl (e/c)
+ edges from 3db0755 (vertex names):
 [1] Zarooor    ->Simon951434 Zarooor    ->Simon951434 cwh0105    ->Simon951434 ECZEMA     ->Simon951434 Zarooor    ->Simon951434 Zarooor    ->Simon951434
 [7] ttcml      ->Simon951434 coga4712   ->Simon951434 coga4712   ->Simon951434 LEEWY      ->Simon951434 harry901   ->nashsaka    harry901   ->nashsaka   
[13] cloudyst   ->nashsaka    nashsaka   ->nashsaka    crownblue  ->nashsaka    ttcml      ->nashsaka    Zarooor    ->nashsaka    love462077 ->nashsaka   
[19] nashsaka   ->nashsaka    carmot     ->nashsaka    carmot     ->nashsaka    jimmylily  ->nashsaka    pigdog0305 ->nashsaka    sungel     ->nashsaka   
[25] mcyangtw   ->nashsaka    heavenlyken->nashsaka    ANCEE      ->nashsaka    ardella    ->nashsaka    ardella    ->nashsaka    ardella    ->nashsaka   
[31] gosy1102   ->nashsaka    Lenore     ->nashsaka    Lenore     ->nashsaka    Lenore     ->nashsaka    Lenore     ->nashsaka    Lenore     ->nashsaka   
[37] Lenore     ->nashsaka    oceanfishwu->zxcdewsaq   oceanfishwu->zxcdewsaq   gemini6479 ->zxcdewsaq   gemini6479 ->zxcdewsaq   ilanese    ->zxcdewsaq  
[43] kashi77331 ->ilanese     kashi77331 ->ilanese     BITMajo    ->ilanese     BITMajo    ->ilanese     noyesray   ->ilanese     justin81828->ilanese    
+ ... omitted several edges

網路圖

# 畫出網路圖
plot(reviewNetwork)

可以發現密密麻麻的東西，完全看不出個所以然。我們試着放少一點的東西來試試。

調整參數

# 把點點的大小和線的粗細調小，並不顯示使用者賬號。
plot(reviewNetwork, vertex.size=2, edge.arrow.size=.2,vertex.label=NA)

還是沒什麼好解釋的，我們試着縮小文章的數量看看。

資料篩選

挑出2020-03-01當天的文章和它的回覆

link <- posts_Reviews %>%
      filter(artDate == as.Date('2020-03-01')) %>%
      select(cmtPoster, artPoster, artUrl) %>% 
      unique()
link

過濾圖中的點(v)

# 這邊要篩選link中有出現的使用者
# 因爲如果userList（igraph中graph_from_data_frame的v參數吃的那個東西）中出現了沒有在link中出現的使用者
# 也會被igraph畫上去，圖片就會變得沒有意義
# 想要看會變怎麼樣的人可以跑一下下面的code
filtered_user <- userList %>%
          filter(user%in%link$cmtPoster | user%in%link$artPoster) %>%
          arrange(desc(type))
filtered_user

未過濾使用者

## 警告！有密集恐懼症的人請小心使用
#reviewNetwork <- graph_from_data_frame(d=link, v=userList, directed=T)
#plot(reviewNetwork, vertex.size=3, edge.arrow.size=0.3,vertex.label=NA)

過濾使用者後

set.seed(487)
# 建立網路關係圖，因爲剛剛看的時候感覺箭頭有點礙眼，
# 所以這裏我們先把關係的方向性拿掉，減少圖片中的不必要的資訊
reviewNetwork <- graph_from_data_frame(d=link, v=filtered_user, directed=F)
plot(reviewNetwork, vertex.size=3, edge.arrow.size=0.3,vertex.label=NA)

可以稍微看出圖中的點(人)之間有一定的關聯，不過目前只有單純圖形我們無法分析其中的內容。
因此以下我們將資料集中的資訊加到我們的圖片中。

加強圖像的顯示資訊(1)

set.seed(487)
# 用使用者的身份來區分點的顏色，如果有發文的話是金色的，只有回覆文章的則用淺藍色表示
V(reviewNetwork)$color <- ifelse(V(reviewNetwork)$type=="poster", "gold", "lightblue")
plot(reviewNetwork, vertex.size=3, edge.arrow.size=0.3,vertex.label=NA)

加強圖像的顯示資訊(2)

set.seed(487)
# 篩選要顯示出的使用者，以免圖形被密密麻麻的文字覆蓋
# 顯示有超過5個關聯的使用者賬號
labels <- degree(reviewNetwork)
V(reviewNetwork)$label <- names(labels)

V(reviewNetwork)$color <- ifelse(V(reviewNetwork)$type=="poster", "gold", "lightblue")
plot(reviewNetwork, vertex.size=3, edge.arrow.size=0.2,
     vertex.label=ifelse(degree(reviewNetwork) > 5, V(reviewNetwork)$label, NA),  vertex.label.font=2)

我們可以看到基本的使用者關係，但是我們希望能夠將更進階的資訊視覺化。
例如：使用者經常參與的文章種類，或是使用者在該社群網路中是否受到歡迎。

主題分類

詳細內容請參考第十週的課程

前處理

# 文章斷句
mask_meta <- posts %>%
              mutate(sentence=gsub("[\n]{2,}", "。", sentence))
# 以全形或半形 驚歎號、問號、分號 以及 全形句號 爲依據進行斷句
mask_sentences <- strsplit(mask_meta$sentence,"[。！；？!?;]")
# 將每句句子，與他所屬的文章連結配對起來，整理成一個dataframe
mask_sentences <- data.frame(
                        artUrl = rep(mask_meta$artUrl, sapply(mask_sentences, length)), 
                        sentence = unlist(mask_sentences)
                      ) %>%
                      filter(!str_detect(sentence, regex("^(\t|\n| )*$")))
mask_sentences$sentence <- as.character(mask_sentences$sentence)
mask_sentences

## 文章斷詞
# load mask_lexicon
mask_lexicon <- scan(file = "./dict/mask_lexicon.txt", what=character(),sep='\n', 
                   encoding='utf-8',fileEncoding='utf-8')

Read 30 items

# load stop words
stop_words <- scan(file = "./dict/stop_words.txt", what=character(),sep='\n', 
                   encoding='utf-8',fileEncoding='utf-8')

Read 1225 items

# 使用默認參數初始化一個斷詞引擎
jieba_tokenizer = worker()
# 使用口罩字典重新斷詞
new_user_word(jieba_tokenizer, c(mask_lexicon))

[1] TRUE

# tokenize function
chi_tokenizer <- function(t) {
  lapply(t, function(x) {
    if(nchar(x)>1){
      tokens <- segment(x, jieba_tokenizer)
      tokens <- tokens[!tokens %in% stop_words]
      # 去掉字串長度爲1的詞彙
      tokens <- tokens[nchar(tokens)>1]
      return(tokens)
    }
  })
}
tokens <- mask_sentences %>%
  unnest_tokens(word, sentence, token=chi_tokenizer) %>%
  filter(!str_detect(word, regex("[0-9a-zA-Z]"))) %>%
  count(artUrl, word) %>%
  rename(count=n)
tokens

## 清理斷詞結果
# 挑出總出現次數大於3的字
reserved_word <- tokens %>% 
  group_by(word) %>% 
  count() %>% 
  filter(n > 3) %>% 
  unlist()

mask_removed <- tokens %>% 
  filter(word %in% reserved_word)

mask_dtm <- mask_removed %>% cast_dtm(artUrl, word, count)
mask_dtm

<<DocumentTermMatrix (documents: 721, terms: 2992)>>
Non-/sparse entries: 44471/2112761
Sparsity           : 98%
Maximal term length: 10
Weighting          : term frequency (tf)

LDA 主題分析

# LDA分成4個主題
mask_lda <- LDA(mask_dtm, k = 4, control = list(seed = 1234))
# 看各群的常用詞彙
tidy(mask_lda, matrix = "beta") %>%
  filter(! term %in% c("口罩")) %>% 
  group_by(topic) %>%
  top_n(10, beta) %>%
  ungroup() %>%
  mutate(topic = as.factor(topic),
         term = reorder_within(term, beta, topic)) %>%
  ggplot(aes(term, beta, fill = topic)) +
  geom_col(show.legend = FALSE) +
  facet_wrap(~ topic, scales = "free") +
  coord_flip() +
  scale_x_reordered()

可以歸納出
topic 1 = “口罩預購”
topic 2 還需要再細分
topic 3 = “各國疫情”
topic 4 = “口罩產能”
以下我們挑出第一個主題與第三個主題來做比較。

# 使用LDA分類每篇文章的主題
mask_topics <- tidy(mask_lda, matrix="gamma") %>% # 在tidy function中使用參數"gamma"來取得 theta矩陣。
                  group_by(document) %>%
                  top_n(1, wt=gamma)
mask_topics

LDA主題進行視覺化

# 把文章資訊和主題join起來
posts_Reviews <- merge(x = posts_Reviews, y = mask_topics, by.x = "artUrl", by.y="document")
posts_Reviews

# 挑選出2020/03/01後的文章，
# 篩選有在15篇以上文章回覆者，
# 文章主題歸類為1(口罩預購)與3(各國疫情)者，
# 欄位只取：cmtPoster(評論者), artPoster(發文者), artUrl(文章連結), topic(主題)
link <- posts_Reviews %>%
      filter(artDate > as.Date('2020-03-01')) %>%
      group_by(cmtPoster, artUrl) %>% 
      filter(n()>15) %>% 
      ungroup() %>% 
      filter(topic == 1 | topic == 3) %>% 
      select(cmtPoster, artPoster, artUrl, topic) %>% 
      unique()
link

# 篩選link中有出現的使用者
filtered_user <- userList %>%
          filter(user%in%link$cmtPoster | user%in%link$artPoster) %>%
          arrange(desc(type))
filtered_user

使用者經常參與的文章種類

# 建立網路關係
reviewNetwork <- graph_from_data_frame(d=link, v=filtered_user, directed=F)

# 依據使用者身份對點進行上色
labels <- degree(reviewNetwork)
V(reviewNetwork)$label <- names(labels)
V(reviewNetwork)$color <- ifelse(V(reviewNetwork)$type=="poster", "gold", "lightblue")

# 依據回覆發生的文章所對應的主題，對他們的關聯線進行上色
E(reviewNetwork)$color <- ifelse(E(reviewNetwork)$topic == "1", "lightgreen", "palevioletred")

# 畫出社群網路圖
set.seed(5432)
plot(reviewNetwork, vertex.size=3, edge.width=3, vertex.label.dist=1,
     vertex.label=ifelse(degree(reviewNetwork) > 7, V(reviewNetwork)$label, NA),vertex.label.font=2)

# 加入標示
legend("bottomright", c("發文者","回文者"), pch=21, 
  col="#777777", pt.bg=c("gold","lightblue"), pt.cex=1, cex=1)

legend("topleft", c("口罩預購","各國疫情"), 
       col=c("lightgreen","palevioletred"), lty=1, cex=1)

可以看出帳號“OverInfinity”和“ptt8592”所發的文多在討論口罩預購的主題，
帳號“nightwing”和“kuma660224”等所發的玟多在討論各國疫情的主題。

使用者是否受到歡迎

# PTT的回覆有三種，推文、噓文、箭頭
# 我們只要看推噓就好，因此把箭頭清掉
link <- posts_Reviews %>%
      filter(cmtStatus!="→") %>%
      group_by(cmtPoster, artUrl) %>% 
      filter(n()>5) %>% 
      ungroup() %>% 
      select(cmtPoster, artPoster, artUrl, cmtStatus) %>% 
      unique()

# 接下來把網路圖畫出來，跟前面做的事都一樣，因此不再細述

# 篩選link中有出現的使用者
filtered_user <- userList %>%
          filter(user%in%link$cmtPoster | user%in%link$artPoster) %>%
          arrange(desc(type))

# 建立網路關係
reviewNetwork <- graph_from_data_frame(d=link, v=filtered_user, directed=F)

# 依據使用者身份對點進行上色
labels <- degree(reviewNetwork)
V(reviewNetwork)$label <- names(labels)
V(reviewNetwork)$color <- ifelse(V(reviewNetwork)$type=="poster", "gold", "lightblue")


# 依據回覆發生的文章所對應的主題，對他們的關聯線進行上色
E(reviewNetwork)$color <- ifelse(E(reviewNetwork)$cmtStatus == "推", "lightgreen", "palevioletred")

# 畫出社群網路圖
set.seed(5432)
plot(reviewNetwork, vertex.size=2, edge.width=3, vertex.label.dist=1,
     vertex.label=ifelse(degree(reviewNetwork) > 5, V(reviewNetwork)$label, NA),vertex.label.font=2)

# 加入標示
legend("bottomright", c("發文者","回文者"), pch=21,
  col="#777777", pt.bg=c("gold","lightblue"), pt.cex=1, cex=1)

legend("topleft", c("推","噓"), 
       col=c("lightgreen","palevioletred"), lty=1, cex=1)

因nCoV2019看板中幾乎沒有噓文，因此所有的連線幾乎都為綠色。

結語：
使用network的視覺化可以讓我們對於網路中的使用者及他們在這個網路中可能扮演的角色有更多地瞭解。