第十四周：社群網路分析贈送疫苗事件－練習

系統參數設定

Sys.setlocale(category = "LC_ALL", locale = "zh_TW.UTF-8") # 避免中文亂碼

## [1] "zh_TW.UTF-8/zh_TW.UTF-8/zh_TW.UTF-8/C/zh_TW.UTF-8/zh_TW.UTF-8"

安裝需要的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)

讀進library

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

資料基本介紹

• 資料來源: 文字平台收集PTT Gossiping/HatePolitics版文章、回覆
• 資料集： ncovid19_articleMetaData.csv、ncovid19_articleReviews.csv
• 關鍵字：贈送疫苗、日本
• 資料時間：2020-05-01 ~ 2021-06-05

這次我們針贈送疫苗事件，討論ptt版上相關討論的發文風向，主要針對以下方向分析：

1.贈送疫苗的討論重點有哪些? 主要分為哪幾種風向?
2.目前風向最偏哪邊?
3.討論關於贈送疫苗社群網路如何分布?
4.贈送疫苗的意見領袖有誰?網友的推噓狀態如何?

1. 資料前處理

在本篇分析中，我們希望建構特定議題的社群網路圖，並分析網路中討論的議題主題

我們需要兩種資料： (1) 每篇文章的主題分類(LDA) (2) 社群網路圖的link和nodes

載入文章和網友回覆資料

posts <- read_csv("../data/ncovid19_articleMetaData.csv") # 文章 1872
reviews <- read_csv("../data/ncovid19_articleReviews.csv") # 回覆 67029

head(posts)

## # A tibble: 6 x 10
##   artTitle   artDate    artTime  artUrl  artPoster artCat commentNum  push   boo
##   <chr>      <date>     <time>   <chr>   <chr>     <chr>       <dbl> <dbl> <dbl>
## 1 [問卦]有…  2021-04-30 16:48:06 https:… sssh5566  Gossi…          8     0     2
## 2 Re:[新聞]… 2021-04-30 20:07:39 https:… realtw    Gossi…        174    19   127
## 3 Re:[問卦]… 2021-04-30 21:22:04 https:… moonshade Gossi…         27     2     4
## 4 Re:[問卦]… 2021-04-30 23:24:49 https:… elfria    Gossi…         11     4     1
## 5 Re:[問卦]… 2021-05-01 00:32:28 https:… myIDis7   Gossi…          8     5     1
## 6 [問卦]亞…  2021-05-01 00:51:26 https:… taiwanne… Gossi…         23     8     2
## # … with 1 more variable: sentence <chr>

head(reviews)

## # A tibble: 6 x 10
##   artTitle    artDate    artTime  artUrl    artPoster artCat cmtPoster cmtStatus
##   <chr>       <date>     <time>   <chr>     <chr>     <chr>  <chr>     <chr>    
## 1 [問卦]有沒… 2021-04-30 16:48:06 https://… sssh5566  Gossi… Kazimir   →        
## 2 [問卦]有沒… 2021-04-30 16:48:06 https://… sssh5566  Gossi… invidia   →        
## 3 [問卦]有沒… 2021-04-30 16:48:06 https://… sssh5566  Gossi… touurtn   噓       
## 4 [問卦]有沒… 2021-04-30 16:48:06 https://… sssh5566  Gossi… invidia   →        
## 5 [問卦]有沒… 2021-04-30 16:48:06 https://… sssh5566  Gossi… r85270607 →        
## 6 [問卦]有沒… 2021-04-30 16:48:06 https://… sssh5566  Gossi… purin88   →        
## # … with 2 more variables: cmtDate <dttm>, cmtContent <chr>

posts %>% 
  mutate(artDate = as.Date(artDate)) %>%
  group_by(artDate) %>%
  summarise(count = n())%>%
  ggplot(aes(artDate,count))+
    geom_line(color="red")+
    geom_point()

2.LDA 主題分類

文章斷句

#  #文章斷句("\n\n"取代成"。")
# 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| )*$")))
#                        #如果有\t或\n就去掉
# 
# mask_sentences$sentence <- as.character(mask_sentences$sentence)
# mask_sentences

文章斷詞

# ## 文章斷詞
# # load mask_lexicon(特定要斷開的詞，像是user_dict)
# mask_lexicon <- scan(file = "../dict/mask_lexicon_19.txt", what=character(),sep='\n',
#                    encoding='utf-8',fileEncoding='utf-8')
# # load stop words
# stop_words <- scan(file = "../dict/stop_words.txt", what=character(),sep='\n',
#                    encoding='utf-8',fileEncoding='utf-8')
# 
# # 使用默認參數初始化一個斷詞引擎
# jieba_tokenizer = worker()
# 
# # 使用口罩字典重新斷詞
 #new_user_word(jieba_tokenizer, c(mask_lexicon_19))

# # 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)
#     }
#   })
# }
# 
# 
# # 用剛剛初始化的斷詞器把sentence斷開
# tokens <- mask_sentences %>%
#     mutate(sentence = gsub("[[:punct:]]", "",sentence)) %>%
#     mutate(sentence = gsub("[0-9a-zA-Z]", "",sentence)) %>%
#     unnest_tokens(word, sentence, token=chi_tokenizer) %>%
#   count(artUrl, word) %>%  # 計算每篇文章出現的字頻
#   rename(count=n)
# tokens
# save.image(file = "../data/token_result_19.rdata")

斷詞結果可以先存起來，就不用再重跑一次

load("../data/token_result_19.rdata")

清理斷詞結果

。根據詞頻，選擇只出現3字以上的字
。整理成url,word,n的格式之後，就可以轉dtm

P.S. groupby by之後原本的字詞結構會不見，把詞頻另存在一個reserved_word裡面

freq = 3
# 依據字頻挑字
reserved_word <- tokens %>% 
  group_by(word) %>% 
  count() %>% 
  filter(n > freq) %>% 
  unlist()

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

#mask_dtm 裡面 nrow:幾篇文章 ; ncol:幾個字
mask_dtm <- mask_removed %>% cast_dtm(artUrl, word, count) 

(2) LDA 主題分析

建立LDA模型

mask_lda <- LDA(mask_dtm, k = 2, control = list(seed = 123))
# lda <- LDA(dtm, k = 2, control = list(seed = 2021,alpha = 2,delta=0.1),method = "Gibbs") #調整alpha即delta
mask_lda

## A LDA_VEM topic model with 2 topics.

利用LDA模型建立phi矩陣

topics_words <- tidy(mask_lda, matrix = "beta") # 注意，在tidy function裡面要使用"beta"來取出Phi矩陣。
colnames(topics_words) <- c("topic", "term", "phi")
topics_words

## # A tibble: 7,996 x 3
##    topic term       phi
##    <int> <chr>    <dbl>
##  1     1 避免  3.94e- 4
##  2     2 避免  3.03e- 4
##  3     1 便宜  2.58e-11
##  4     2 便宜  4.43e- 4
##  5     1 不用  1.63e- 4
##  6     2 不用  1.98e- 3
##  7     1 充滿  9.16e- 5
##  8     2 充滿  1.78e- 4
##  9     1 次數  4.38e- 5
## 10     2 次數  1.44e- 4
## # … with 7,986 more rows

library(showtext)  #安装此包前需要在mac中按照XQuartz，link在下文

## Loading required package: sysfonts

## Loading required package: showtextdb

showtext_auto() 
font_add("PingFangSC-Regular",regular = "/System/Library/Fonts/PingFang.ttc") #第一个参数是根据字体随便取个名字，regular参数是相应字体在电脑中的文件

尋找Topic的代表字

terms依照各主題的phi值由大到小排序，列出前10大

topics_words %>%
  group_by(topic) %>%
  top_n(10, phi) %>%
  ungroup() %>%
  mutate(top_words = reorder_within(term,phi,topic)) %>%
  ggplot(aes(x = top_words, y = phi, fill = as.factor(topic))) +
  geom_col(show.legend = FALSE) +
  facet_wrap(~ topic, scales = "free") +
  coord_flip() +
  scale_x_reordered()

# 尋找最佳主題數

建立更多主題的主題模型

嘗試2、4、6、10、15個主題數，將結果存起來，再做進一步分析。 此部分需要跑一段時間，已經將跑完的檔案存成ldas_result_19.rdata，可以直接載入

# ldas = c()
# topics = c(2,4,6,10,15)
# for(topic in topics){
#   start_time <- Sys.time()
#   mask_lda <- LDA(mask_dtm, k = topic, control = list(seed = 123))
#   ldas =c(ldas,mask_lda)
#   print(paste(topic ,paste("topic(s) and use time is ", Sys.time() -start_time)))
#   save(ldas,file = "ldas_result_19.rdata") # 將模型輸出成檔案
# }

載入每個主題的LDA結果

load("ldas_result_19.rdata")

透過perplexity找到最佳主題數

#topics = c(2,4,6,10,15)
#data_frame(k = topics, perplex = map_dbl(ldas, topicmodels::perplexity)) %>%
#  ggplot(aes(k, perplex)) +
#  geom_point() +
#  geom_line() +
#  labs(title = "Evaluating LDA topic models",
#       subtitle = "Optimal number of topics (smaller is better)",
#       x = "Number of topics",
#       y = "Perplexity")

將剛處理好的dtm放入LDA函式分析

# LDA分成4個主題
mask_lda <- LDA(mask_dtm, k = 4, control = list(seed = 123))

p.s. 。tidy(mask_lda, matrix = “beta”) # 取字 topic term beta值 。tidy(mask_lda, matrix=“gamma”) # 取主題 document topic gamma

取出代表字詞(term)

removed_word = c("有沒有","好像","八卦","比較","一堆","覺得","看到") 

# 看各群的常用詞彙
tidy(mask_lda, matrix = "beta") %>% # 取出topic term beta值
  filter(! term %in% removed_word) %>% 
  group_by(topic) %>%
  top_n(5, beta) %>% # beta值前10的字
  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()

create LDAvis所需的json function 此function是將前面使用 “LDA function”所建立的model，轉換為“LDAVis”套件的input格式。

topicmodels_json_ldavis <- function(fitted, doc_term){
    require(LDAvis)
    require(slam)
  
    ###以下function 用來解決，主題數多會出現NA的問題
    ### 參考 https://github.com/cpsievert/LDAvis/commit/c7234d71168b1e946a361bc00593bc5c4bf8e57e
    ls_LDA = function (phi){
      jensenShannon <- function(x, y) {
        m <- 0.5 * (x + y)
        lhs <- ifelse(x == 0, 0, x * (log(x) - log(m+1e-16)))
        rhs <- ifelse(y == 0, 0, y * (log(y) - log(m+1e-16)))
        0.5 * sum(lhs) + 0.5 * sum(rhs)
      }
      dist.mat <- proxy::dist(x = phi, method = jensenShannon)
      pca.fit <- stats::cmdscale(dist.mat, k = 2)
      data.frame(x = pca.fit[, 1], y = pca.fit[, 2])
    }
  
      # Find required quantities
      phi <- as.matrix(posterior(fitted)$terms)
      theta <- as.matrix(posterior(fitted)$topics)
      vocab <- colnames(phi)
      term_freq <- slam::col_sums(doc_term)
  
      # Convert to json
      json_lda <- LDAvis::createJSON(phi = phi, theta = theta,
                                     vocab = vocab,
                                     doc.length = as.vector(table(doc_term$i)),
                                     term.frequency = term_freq, mds.method = ls_LDA)
  
      return(json_lda)
}

產生LDAvis結果

the_lda = ldas[[2]]
json_res <- topicmodels_json_ldavis(the_lda,mask_dtm)
serVis(json_res,open.browser = T)

可以歸納出
topic 1 = “日本疫苗提供給台灣的新聞”
topic 2 = “各國家疫苗的報導”
topic 3 = “日本疫情相關報導”
topic 4 = “日本疫苗原廠問題相關”
以下我們挑出第一個主題與第四個主題來做比較。

取出代表主題(topic)

每篇文章拿gamma值最大的topic當該文章的topic

# 在tidy function中使用參數"gamma"來取得 theta矩陣
mask_topics <- tidy(mask_lda, matrix="gamma") %>% # document topic gamma
                  group_by(document) %>%
                  top_n(1, wt=gamma)
mask_topics

## # A tibble: 1,872 x 3
## # Groups:   document [1,872]
##    document                                                 topic gamma
##    <chr>                                                    <int> <dbl>
##  1 https://www.ptt.cc/bbs/Gossiping/M.1620190656.A.158.html     1 0.611
##  2 https://www.ptt.cc/bbs/Gossiping/M.1620211722.A.F2A.html     1 0.425
##  3 https://www.ptt.cc/bbs/Gossiping/M.1620222123.A.518.html     1 0.674
##  4 https://www.ptt.cc/bbs/Gossiping/M.1620548546.A.E8D.html     1 0.524
##  5 https://www.ptt.cc/bbs/Gossiping/M.1621143090.A.C5B.html     1 0.461
##  6 https://www.ptt.cc/bbs/Gossiping/M.1621567167.A.66B.html     1 0.998
##  7 https://www.ptt.cc/bbs/Gossiping/M.1621578117.A.34A.html     1 0.785
##  8 https://www.ptt.cc/bbs/Gossiping/M.1621608244.A.FEF.html     1 0.522
##  9 https://www.ptt.cc/bbs/Gossiping/M.1621823153.A.510.html     1 0.770
## 10 https://www.ptt.cc/bbs/Gossiping/M.1621934216.A.0B7.html     1 0.766
## # … with 1,862 more rows

資料內容探索

posts_topic <- merge(x = posts, y = mask_topics, by.x = "artUrl", by.y="document")

# 看一下各主題在說甚麼
set.seed(123)
posts_topic %>% # 主題二
  filter(topic==1) %>%
  select(artTitle) %>%
  unique() %>%
  sample_n(5)

##                                      artTitle
## 1       [黑特]日本贈送的AZ疫苗要八大項文件嗎?
## 2     Re:[黑特]日本外相：AZ疫苗將當天送到台灣
## 3          [新聞]日本政府正考慮提供台灣AZ疫苗
## 4     [轉錄]黃偉哲FB#在台南日本人優先施打疫苗
## 5 [新聞]日本研擬提供台灣疫苗傳國會議員盼送100

posts_topic %>% # 主題四
  filter(topic==4) %>%
  select(artTitle) %>%
  unique() %>%
  sample_n(5)

##                                         artTitle
## 1 Re:[問卦]日本大哥哥1.2億劑的AZ疫苗是不是被忘了
## 2                [問卦]日本送疫苗不用8大文件嗎？
## 3              [問卦]如果美國是爸爸，日本是什麼?
## 4   Re:[新聞]日本120萬劑疫苗明抵台灣知情人士曝「
## 5                           [問卦]欸真的學日本了

這次我們把討論焦點放在日本贈送疫苗上，從主題分布大概可以看到兩類觀點：

• 主題一： > 對於日本政府願意贈送疫苗給台灣的新聞，如「日本政府正考慮提供台灣AZ疫苗」、「日本124萬劑疫苗明抵台灣綠委證實」、「日本扛住了！捐贈台灣疫苗」、「日本不要的疫苗被台灣當成寶？ 」

• 主題四： > 大部分是對於日本贈送的討論，對於為何日本可以快速贈送給台灣等等，如「日本疫苗來台，有附原廠授權書嗎？」、「日本送疫苗不用8大文件嗎？」、「為何中共擋不了日本這批AZ疫苗？」

日期主題分布

畫出每天topic的分布，發現隨著時間增加，主題一、四的比例逐漸增加，且主題一的比例大於主題四。

posts_topic %>%
  mutate(artDate = as.Date(artDate)) %>% 
  group_by(artDate,topic) %>%
  summarise(sum =sum(topic)) %>%
  ggplot(aes(x= artDate,y=sum,fill=as.factor(topic))) +
  geom_col(position="fill") 

## `summarise()` has grouped output by 'artDate'. You can override using the `.groups` argument.

posts_topic %>%
  group_by(artCat,topic) %>%
  summarise(sum = n())  %>%
  ggplot(aes(x= artCat,y=sum,fill=as.factor(topic))) +
  geom_col(position="dodge") 

## `summarise()` has grouped output by 'artCat'. You can override using the `.groups` argument.

4. 社群網路圖

資料合併

# 文章和留言
reviews <- reviews %>%
      select(artUrl, cmtPoster, cmtStatus, cmtContent)
posts_Reviews <- merge(x = posts, y = reviews, by = "artUrl")

# 把文章和topic
posts_Reviews <- merge(x = posts_Reviews, y = mask_topics, by.x = "artUrl", by.y="document")
head(posts_Reviews,3)

##                                                     artUrl
## 1 https://www.ptt.cc/bbs/Gossiping/M.1619801289.A.328.html
## 2 https://www.ptt.cc/bbs/Gossiping/M.1619801289.A.328.html
## 3 https://www.ptt.cc/bbs/Gossiping/M.1619801289.A.328.html
##                                       artTitle    artDate  artTime artPoster
## 1 [問卦]有沒有日本的英語學習網站賺啥的八卦。。 2021-04-30 16:48:06  sssh5566
## 2 [問卦]有沒有日本的英語學習網站賺啥的八卦。。 2021-04-30 16:48:06  sssh5566
## 3 [問卦]有沒有日本的英語學習網站賺啥的八卦。。 2021-04-30 16:48:06  sssh5566
##      artCat commentNum push boo
## 1 Gossiping          8    0   2
## 2 Gossiping          8    0   2
## 3 Gossiping          8    0   2
##                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                sentence
## 1 很久以前用一間日本的英文學習網站T\n\n當時第一個月完全免費，就很疑惑這樣他們這樣要賺什麼\n\n貪財的台灣人八成月一個月免費之後就不用了。。。\n\n不然就是換帳號繼續用免錢的\n\n那時候覺得這樣便宜夠扯了，一小時一對一30~120台幣\n\n根據菲律賓當地物價最地薪資60元，公司才賺三成約0~30元\n\n我去美國前就是這樣練英語的XD...完全上免錢\n\n\n\n最近又發現一個吃到飽的線上英語平台\n\n避免違反版規打廣告代稱N好了 (真要知道還是可以私信我啦Orz..)\n\n也是介紹人後一個月免費試用，總共最多兩個月吃到飽\n\n價格上完全打爆其他線上菲律賓英語平台\n\n無限次數上到飽＋免費試用比扯鈴還扯\n\n\n\n雖然老師大多是菲律賓的，但一堂課25分鐘聽說老師才拿到一美元。。。\n\n歐美母語老師則是可以拿到5美元\n\n\n這個月下來我幾乎上了80小時的免費一對一。。。\n\n每天就跟日本妹、菲律賓妹、歐洲妹免費聊天順便學外語聊免錢的\n\n\n但我用免費的實在都充滿了罪惡感，實在不知道日本公司在想什麼。。。\n\n難道不知道貪財精打細算的台灣人一定會免費用完的就不用嗎。。。？\nhttps://imgur.com/a/3t3T8vT\n隨便找一個年輕的，不過年輕的大多要預約\n\n不用coin預約大多是歐巴桑歐吉桑\n台灣腔居多\n你可以拿它來練日文、土耳其文、阿拉伯語、西班牙語\n\n然後我這年躲台灣
## 2 很久以前用一間日本的英文學習網站T\n\n當時第一個月完全免費，就很疑惑這樣他們這樣要賺什麼\n\n貪財的台灣人八成月一個月免費之後就不用了。。。\n\n不然就是換帳號繼續用免錢的\n\n那時候覺得這樣便宜夠扯了，一小時一對一30~120台幣\n\n根據菲律賓當地物價最地薪資60元，公司才賺三成約0~30元\n\n我去美國前就是這樣練英語的XD...完全上免錢\n\n\n\n最近又發現一個吃到飽的線上英語平台\n\n避免違反版規打廣告代稱N好了 (真要知道還是可以私信我啦Orz..)\n\n也是介紹人後一個月免費試用，總共最多兩個月吃到飽\n\n價格上完全打爆其他線上菲律賓英語平台\n\n無限次數上到飽＋免費試用比扯鈴還扯\n\n\n\n雖然老師大多是菲律賓的，但一堂課25分鐘聽說老師才拿到一美元。。。\n\n歐美母語老師則是可以拿到5美元\n\n\n這個月下來我幾乎上了80小時的免費一對一。。。\n\n每天就跟日本妹、菲律賓妹、歐洲妹免費聊天順便學外語聊免錢的\n\n\n但我用免費的實在都充滿了罪惡感，實在不知道日本公司在想什麼。。。\n\n難道不知道貪財精打細算的台灣人一定會免費用完的就不用嗎。。。？\nhttps://imgur.com/a/3t3T8vT\n隨便找一個年輕的，不過年輕的大多要預約\n\n不用coin預約大多是歐巴桑歐吉桑\n台灣腔居多\n你可以拿它來練日文、土耳其文、阿拉伯語、西班牙語\n\n然後我這年躲台灣
## 3 很久以前用一間日本的英文學習網站T\n\n當時第一個月完全免費，就很疑惑這樣他們這樣要賺什麼\n\n貪財的台灣人八成月一個月免費之後就不用了。。。\n\n不然就是換帳號繼續用免錢的\n\n那時候覺得這樣便宜夠扯了，一小時一對一30~120台幣\n\n根據菲律賓當地物價最地薪資60元，公司才賺三成約0~30元\n\n我去美國前就是這樣練英語的XD...完全上免錢\n\n\n\n最近又發現一個吃到飽的線上英語平台\n\n避免違反版規打廣告代稱N好了 (真要知道還是可以私信我啦Orz..)\n\n也是介紹人後一個月免費試用，總共最多兩個月吃到飽\n\n價格上完全打爆其他線上菲律賓英語平台\n\n無限次數上到飽＋免費試用比扯鈴還扯\n\n\n\n雖然老師大多是菲律賓的，但一堂課25分鐘聽說老師才拿到一美元。。。\n\n歐美母語老師則是可以拿到5美元\n\n\n這個月下來我幾乎上了80小時的免費一對一。。。\n\n每天就跟日本妹、菲律賓妹、歐洲妹免費聊天順便學外語聊免錢的\n\n\n但我用免費的實在都充滿了罪惡感，實在不知道日本公司在想什麼。。。\n\n難道不知道貪財精打細算的台灣人一定會免費用完的就不用嗎。。。？\nhttps://imgur.com/a/3t3T8vT\n隨便找一個年輕的，不過年輕的大多要預約\n\n不用coin預約大多是歐巴桑歐吉桑\n台灣腔居多\n你可以拿它來練日文、土耳其文、阿拉伯語、西班牙語\n\n然後我這年躲台灣
##   cmtPoster cmtStatus                                        cmtContent topic
## 1   Kazimir        → :有人會付錢就夠喇這促銷不就是後台看轉換率決定成效     2
## 2   invidia        →                                     :日本妹可愛ㄇ     2
## 3   touurtn        噓                    :貪小便宜的只有你不是台灣人...     2
##       gamma
## 1 0.8424411
## 2 0.8424411
## 3 0.8424411

取出 cmtPoster(回覆者)、artPoster(發文者)、artUrl(文章連結) 三個欄位

link <- posts_Reviews %>% select(cmtPoster, artPoster, artUrl)
head(link,3)

##   cmtPoster artPoster                                                   artUrl
## 1   Kazimir  sssh5566 https://www.ptt.cc/bbs/Gossiping/M.1619801289.A.328.html
## 2   invidia  sssh5566 https://www.ptt.cc/bbs/Gossiping/M.1619801289.A.328.html
## 3   touurtn  sssh5566 https://www.ptt.cc/bbs/Gossiping/M.1619801289.A.328.html

基本網路圖

建立網路關係

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

## IGRAPH 49e80a8 DN-- 22948 121438 -- 
## + attr: name (v/c), artUrl (e/c)
## + edges from 49e80a8 (vertex names):
##  [1] Kazimir     ->sssh5566 invidia     ->sssh5566 touurtn     ->sssh5566
##  [4] invidia     ->sssh5566 r85270607   ->sssh5566 purin88     ->sssh5566
##  [7] nptrj       ->sssh5566 iampig951753->sssh5566 summer34796 ->realtw  
## [10] chaunen     ->realtw   minifat     ->realtw   Dinenger    ->realtw  
## [13] Xaymaca     ->realtw   XTaiwanAyin ->realtw   Xaymaca     ->realtw  
## [16] XTaiwanAyin ->realtw   poolo       ->realtw   Guoplus     ->realtw  
## [19] ptgeorge2   ->realtw   ptgeorge2   ->realtw   minifat     ->realtw  
## [22] ksjr        ->realtw   CHYYP       ->realtw   Induction   ->realtw  
## + ... omitted several edges

直接畫的話，因為點沒有經過篩選，看起來會密密麻麻的 還需要經過一次資料篩選，有興趣可以跑跑下面的code

# 畫出網路圖(密集恐懼警告)
#plot(reviewNetwork)
#plot(reviewNetwork, vertex.size=2, edge.arrow.size=.2,vertex.label=NA)

資料篩選

資料篩選的方式：

• 文章:文章日期、留言數(commentNum)
  
• link、node:degree

# 看一下留言數大概都多少(方便後面篩選)
posts %>%
#  filter(commentNum<100) %>%
  ggplot(aes(x=commentNum)) + geom_histogram()

## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.

依據發文數或回覆數篩選post和review

# # 帳號發文篇數
# post_count = posts %>%
#   group_by(artPoster) %>%
#   summarise(count = n()) %>%
#   arrange(desc(count)) 
# post_count
# 
# # 帳號回覆總數
# review_count = reviews %>%
#   group_by(cmtPoster) %>%
#   summarise(count = n()) %>%
#   arrange(desc(count)) 
# review_count

# # 發文者
# poster_select <- post_count %>% filter(count >= 2)
# posts <- posts %>%  filter(posts$artPoster %in% poster_select$artPoster)
# 
# # 回覆者
# reviewer_select <- review_count %>%  filter(count >= 20)
# reviews <- reviews %>%  filter(reviews$cmtPoster %in% reviewer_select$cmtPoster)

# 檢視參與人數
length(unique(posts_Reviews$artPoster)) # 發文者數量 1196

## [1] 1196

length(unique(posts_Reviews$cmtPoster)) # 回覆者數量 22534

## [1] 22534

allPoster <- c(posts_Reviews$artPoster, posts_Reviews$cmtPoster) # 總參與人數 22948
length(unique(allPoster))

## [1] 22948

標記所有出現過得使用者

• poster：只發過文、發過文+留過言
• replyer：只留過言

userList <- data.frame(user=unique(allPoster)) %>%
              mutate(type=ifelse(user%in%posts$artPoster, "poster", "replyer"))
head(userList,3)

##        user   type
## 1  sssh5566 poster
## 2    realtw poster
## 3 moonshade poster

以日期篩選社群

事件是6/4爆發的，我們挑出當天的文章和回覆看看

link <- posts_Reviews %>%
      group_by(cmtPoster, artUrl) %>% 
      filter(n()>3) %>% 
      filter(commentNum > 200) %>%
      filter(artCat=="Gossiping") %>% 
      filter(artDate == as.Date('2021-06-04')) %>%
      select(cmtPoster, artPoster, artUrl) %>% 
      unique()
link

## # A tibble: 278 x 3
## # Groups:   cmtPoster, artUrl [278]
##    cmtPoster   artPoster  artUrl                                                
##    <chr>       <chr>      <chr>                                                 
##  1 cliffcliff  AllenHuang https://www.ptt.cc/bbs/Gossiping/M.1622769664.A.697.h…
##  2 alan0204    AllenHuang https://www.ptt.cc/bbs/Gossiping/M.1622769664.A.697.h…
##  3 RELIFE168   AllenHuang https://www.ptt.cc/bbs/Gossiping/M.1622769664.A.697.h…
##  4 mnhyuiop    roads      https://www.ptt.cc/bbs/Gossiping/M.1622771988.A.4BB.h…
##  5 dk1986      roads      https://www.ptt.cc/bbs/Gossiping/M.1622771988.A.4BB.h…
##  6 khuntoria   roads      https://www.ptt.cc/bbs/Gossiping/M.1622771988.A.4BB.h…
##  7 clala       roads      https://www.ptt.cc/bbs/Gossiping/M.1622771988.A.4BB.h…
##  8 Yakei       roads      https://www.ptt.cc/bbs/Gossiping/M.1622771988.A.4BB.h…
##  9 smilesunday roads      https://www.ptt.cc/bbs/Gossiping/M.1622771988.A.4BB.h…
## 10 Ghostgreen  roads      https://www.ptt.cc/bbs/Gossiping/M.1622771988.A.4BB.h…
## # … with 268 more rows

篩選在link裡面有出現的使用者

filtered_user <- userList %>%
          filter(user%in%link$cmtPoster | user%in%link$artPoster) %>%
          arrange(desc(type))
head(filtered_user,3)

##        user    type
## 1 espresso1 replyer
## 2 jessicali replyer
## 3  ifyoutry replyer

這邊要篩選link中有出現的使用者，如果用沒篩過的userList（igraph中graph_from_data_frame的v參數吃的那個東西），圖上就會出現沒有在link裡面的nodes，圖片就會變得沒有意義

p.s.想要看會變怎麼樣的人可以跑下面的code

## 警告！有密集恐懼症的人請小心使用
# v = userList
#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 因為igraph呈現的方向是隨機的

set.seed(487)
# v=filtered_user

reviewNetwork = degree(reviewNetwork) > 2
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)

加上nodes的顯示資訊

用使用者的身份來區分點的顏色

• poster:gold(有發文)
  
• replyer:lightblue(只有回覆文章)

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)

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

為點加上帳號名字，用degree篩選要顯示出的使用者，以免圖形被密密麻麻的文字覆蓋

filter_degree = 20
set.seed(123)

# 設定 node 的 label/ color
labels <- degree(reviewNetwork) # 算出每個點的degree
V(reviewNetwork)$label <- names(labels)
V(reviewNetwork)$color <- ifelse(V(reviewNetwork)$type=="poster", "gold", "lightblue")

plot(
  reviewNetwork, 
  vertex.size=5, 
  edge.width=5, 
  vertex.label.dist=3,
  vertex.label=ifelse(degree(reviewNetwork) > filter_degree, V(reviewNetwork)$label, NA),vertex.label.font=2)

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

以主題篩選社群

• 抓link

挑選出2021-06-04當天的文章， 篩選一篇文章回覆3次以上者，且文章留言數多餘200則， 文章主題歸類為2(批評調侃)與4(報導相關)者， 欄位只取：cmtPoster(評論者), artPoster(發文者), artUrl(文章連結), topic(主題)

link <- posts_Reviews %>%
      group_by(cmtPoster, artUrl) %>% 
      filter(n()>3) %>% 
      filter(commentNum > 200) %>%
      filter(artCat=="Gossiping") %>% #HatePolitics / Gossiping
      filter(artDate == as.Date('2021-06-04')) %>%
      filter(topic == 2 | topic == 4) %>% 
      select(cmtPoster, artPoster, artUrl, topic) %>% 
      unique()
link

## # A tibble: 156 x 4
## # Groups:   cmtPoster, artUrl [156]
##    cmtPoster    artPoster artUrl                                           topic
##    <chr>        <chr>     <chr>                                            <int>
##  1 mnhyuiop     roads     https://www.ptt.cc/bbs/Gossiping/M.1622771988.A…     2
##  2 dk1986       roads     https://www.ptt.cc/bbs/Gossiping/M.1622771988.A…     2
##  3 khuntoria    roads     https://www.ptt.cc/bbs/Gossiping/M.1622771988.A…     2
##  4 clala        roads     https://www.ptt.cc/bbs/Gossiping/M.1622771988.A…     2
##  5 Yakei        roads     https://www.ptt.cc/bbs/Gossiping/M.1622771988.A…     2
##  6 smilesunday  roads     https://www.ptt.cc/bbs/Gossiping/M.1622771988.A…     2
##  7 Ghostgreen   roads     https://www.ptt.cc/bbs/Gossiping/M.1622771988.A…     2
##  8 doomsday1234 roads     https://www.ptt.cc/bbs/Gossiping/M.1622771988.A…     2
##  9 zeroBB       roads     https://www.ptt.cc/bbs/Gossiping/M.1622771988.A…     2
## 10 nalthax      roads     https://www.ptt.cc/bbs/Gossiping/M.1622771988.A…     2
## # … with 146 more rows

• 抓nodes 在所有的使用者裡面，篩選link中有出現的使用者

filtered_user <- userList %>%
          filter(user%in%link$cmtPoster | user%in%link$artPoster) %>%
          arrange(desc(type))
head(filtered_user,3)

##           user    type
## 1    espresso1 replyer
## 2 starfishfish replyer
## 3     inshadow replyer

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

filter_degree = 13

# 建立網路關係
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 == "2", "palevioletred", "lightgreen")

# 畫出社群網路圖(degree>7的才畫出來)
set.seed(5432)
plot(reviewNetwork, vertex.size=3, edge.width=3, vertex.label.dist=1,
     vertex.label=ifelse(degree(reviewNetwork) > filter_degree, 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("palevioletred", "lightgreen"), lty=1, cex=1)

使用者是否受到歡迎

PTT的回覆有三種，推文、噓文、箭頭，我們只要看推噓就好，因此把箭頭清掉，這樣資料筆數較少，所以我們把篩選的條件放寬一些。

filter_degree = 7 # 使用者degree

# 過濾留言者對發文者的推噓程度
link <- posts_Reviews %>%
      filter(artCat=="Gossiping") %>% 
      filter(commentNum > 100) %>%
      filter(cmtStatus!="→") %>%
      group_by(cmtPoster, artUrl) %>%
      filter( n() > 2) %>%
      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) > filter_degree, 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)

可以發現本次的討論中幾乎都是推文、噓文較少

補充：networkD3

需要設定每個節點的id，記得要從0開始

library(networkD3)
links = link
nodes = filtered_user
nodes$id = 0:(length(nodes$user) - 1)

# 整理資料格式
nodes_complete <- data.frame(nodeID = unique(c(links$cmtPoster, links$artPoster)))
nodes_complete$group <- nodes$type[match(nodes_complete$nodeID, nodes$user)]
links$source <- match(links$cmtPoster, nodes_complete$nodeID) - 1
links$target <- match(links$artPoster, nodes_complete$nodeID) - 1

# 畫圖
library(networkD3)
forceNetwork(Links = links, Nodes = nodes_complete, Source = "source", 
             Target = "target", NodeID = "nodeID", Group = "group", 
             opacity = 0.8, fontSize = 10, zoom = TRUE,legend = TRUE, opacityNoHover = TRUE,
             
             colourScale = "d3.scaleOrdinal(d3.schemeCategory10);",
             linkColour = ifelse(links$cmtStatus == "推", "palegreen","lightcoral")  # 設定推噓顏色
             )

## Links is a tbl_df. Converting to a plain data frame.

總結

1. 贈送疫苗的討論重點有哪些? 主要分為哪幾種風向?
   對於2021-05-01 ~ 2021-06-05收集的文章，大概可以分成討論日本疫苗提供給台灣的新聞、日本疫苗原廠問題相關這兩種，其他還有著重討論日本疫情相關報導或和各國家疫苗的報導的討論等四種。討論重點多在於「日本疫苗提供原因」、「速度」、「證明文件」等流程的探討。

2. 目前風向最偏哪邊?
   客觀討論計算方式的文章不少，但嘲諷、八卦性質的文章也有。

3. 討論贈送疫苗的社群網路如何分布?
   以社群文章數來看，報導相關新聞較多，但從社群網路觀察發現，正面貼文討論聲量較高。

4. 贈送疫苗的意見領袖有誰?網友的推噓狀態如何?
   因為資料選取的時間較短，只要幾篇回覆量高的貼文，就有機會成為社群中心，在八卦版上，以報導討論為主的意見領袖及回覆推噓皆有，調侃批評部分也有，網友大多正面推文。