第十四周：社群網路分析有關八卦版持續於疫苗取得等疫情探討
第四組-李欣倪,李昀徽,周郁津,劉沛萱,黃柏凱,葉思卿,邵柏鈞
系統參數設定
Sys.setlocale(category = "LC_ALL", locale = "zh_TW.UTF-8") # 避免中文亂碼## [1] ""安裝需要的packages
packages = c("readr", "data.table", "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
rm(list=ls(all=T))
library(readr)
library(data.table)
library(dplyr)
library(jiebaR)
library(tidyr)
library(tidytext)
library(igraph)
library(topicmodels)
library(stringr)
library(ggplot2)
library(reshape2)
library(wordcloud2)資料基本介紹
- 資料來源: 文字平台收集PTT Gossiping八卦版/文章及回覆
- 資料集： 0529_articleMetaData.csv、0529_articleReviews.csv
- 關鍵字：快篩、確診、疫苗、疫情
- 資料時間：2021-05-24 ~ 2021-05-28
這次我們針對5/24發生的疫苗分配事件，後續討論ptt版上相關討論的發文風向，主要針對以下方向分析：
1.比較八卦版在指揮中心疫苗取得數量及各縣市自行採購疫苗之討論重點為何? 主要有哪幾種風向? 2.目前風向最偏為何? 3.討論取得不同廠牌疫苗或國產疫苗的社群網路如何分布? 4.疫苗各縣分配數量的意見領袖有誰?網友的推噓狀態如何?
1. 資料前處理
在本篇分析中，我們希望建構特定議題的社群網路圖，並分析網路中討論的議題主題
我們需要兩種資料： (1) 每篇文章的主題分類(LDA) (2) 社群網路圖的link和nodes
載入文章和網友回覆資料
posts <- read_csv("C:/Users/user/Desktop/Homework14v2/data/0529_articleMetaData.csv") # 文章 1,326筆
reviews <- read_csv("C:/Users/user/Desktop/Homework14v2/data/0529_articleReviews.csv") # 回覆 113,913筆2.LDA 主題分類
(1) 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.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))
#
## 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 = "/Applications/RStudio.app/Homework14v2/data/token_result.rdata")斷詞結果可以先存起來，就不用再重跑一次
load("C:/Users/user/Desktop/Homework14v2/data/token_result.rdata")## Warning in load("C:/Users/user/Desktop/Homework14v2/data/token_result.rdata"):
## strings not representable in native encoding will be translated to UTF-8清理斷詞結果
。根據詞頻，選擇只出現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 主題分析
將剛處理好的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(10, 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()
> 可以歸納出
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,426 x 3
## # Groups: document [1,426]
## document topic gamma
## <chr> <int> <dbl>
## 1 https://www.ptt.cc/bbs/Gossiping/M.1621880109.A.4D1.html 1 0.980
## 2 https://www.ptt.cc/bbs/Gossiping/M.1621886667.A.062.html 1 0.994
## 3 https://www.ptt.cc/bbs/Gossiping/M.1621893031.A.EA3.html 1 0.965
## 4 https://www.ptt.cc/bbs/Gossiping/M.1621899523.A.69F.html 1 0.779
## 5 https://www.ptt.cc/bbs/Gossiping/M.1621901245.A.EAF.html 1 0.991
## 6 https://www.ptt.cc/bbs/Gossiping/M.1621901916.A.EA1.html 1 0.956
## 7 https://www.ptt.cc/bbs/Gossiping/M.1621902576.A.E5A.html 1 0.557
## 8 https://www.ptt.cc/bbs/Gossiping/M.1621908441.A.AED.html 1 0.826
## 9 https://www.ptt.cc/bbs/Gossiping/M.1621917491.A.41F.html 1 0.858
## 10 https://www.ptt.cc/bbs/Gossiping/M.1621917903.A.E04.html 1 0.587
## # ... with 1,416 more rows3.資料內容探索
posts_topic <- merge(x = posts, y = mask_topics, by.x = "artUrl", by.y="document")
# 看一下各主題在說甚麼
set.seed(123)
posts_topic %>% # 主題三
filter(topic==3) %>%
select(artTitle) %>%
unique() %>%
sample_n(5)## artTitle
## 1 Re:[新聞]日本政府採購的AZ疫苗提供開發中國家
## 2 [問卦]15萬疫苗到台灣時會用什麼陣容護送
## 3 [問卦]誰敢幫台灣牽線買疫苗？
## 4 [問卦]打疫苗可以自己選擇廠牌嗎?
## 5 [問卦]時鐘嘴記者沒打疫苗??posts_topic %>% # 主題四
filter(topic==4) %>%
select(artTitle) %>%
unique() %>%
sample_n(5)## artTitle
## 1 [新聞]組團赴美打疫苗旅遊業者：出團禁令仍在
## 2 [新聞]41萬劑AZ疫苗將配發鄭文燦：爭取桃機人1
## 3 [新聞]北市聯醫昆明院區爆6人染疫！確診員工曾
## 4 [新聞]佛光山喊捐50萬劑「嬌生疫苗」公文送疾
## 5 Re:[新聞]南投縣長想向上海買BNT疫苗指揮中心-這次我們把討論焦點放在疫苗向誰購置及注射疫苗可否自已選擇廠牌上，從主題分布大概可以看到兩類觀點：
主題三： 對於指揮中心公布取得疫苗數量與民眾選擇疫苗廠牌等相關討論，如「日本政府採購的AZ疫苗提議助台」、「15萬疫苗到台灣」、「誰敢幫台灣牽線買疫苗？」、「打疫苗可以自己選擇廠牌嗎?」、「時鐘嘴記者沒打疫苗?」
主題四： 大部分是針對已取得數萬劑疫苗如何分配？各縣市政府自力採購不同疫苗的討論，如「組團赴美打疫苗旅遊業者」、「41萬劑AZ疫苗將配發鄭文燦」、「北市聯醫昆明院區爆6人染疫」、「佛光山喊捐50萬劑「嬌生疫苗」」、「南投縣長想向上海買BNT疫」
日期主題分布
畫出每天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.1621873731.A.A4C.html
## 2 https://www.ptt.cc/bbs/Gossiping/M.1621873731.A.A4C.html
## 3 https://www.ptt.cc/bbs/Gossiping/M.1621873731.A.A4C.html
## artTitle artDate artTime
## 1 Re:[新聞]出人出疫苗 國台辦加碼：願考慮派專家赴 2021-05-24 16:28:49
## 2 Re:[新聞]出人出疫苗 國台辦加碼：願考慮派專家赴 2021-05-24 16:28:49
## 3 Re:[新聞]出人出疫苗 國台辦加碼：願考慮派專家赴 2021-05-24 16:28:49
## artPoster artCat commentNum push boo
## 1 cloud72426 Gossiping 27 7 2
## 2 cloud72426 Gossiping 27 7 2
## 3 cloud72426 Gossiping 27 7 2
## sentence
## 1 這種好處就應該要拿\n\n 汶川大地震台灣捐了70億\n\n 現在拿它一點疫苗怎麼了嗎???\n\n 當然我知道很多人不想打中國製的疫苗\n\n 但是 你不想打 別人想打的話 這是他的權利\n\n 應該沒有人會逼你打中國製的\n\n 你可以等國產 或是 看政府能不能買到美國爸爸的疫苗\n\n 專家來分享抗疫經驗也沒啥不好的\n\n 多一點意見交流\n\n 總比只會校正回歸的中央疫情指揮中心好??\n\n\n 當然最好是拿個一百萬BNT的啦\n\n 至少先讓醫護打完\n\n 你還可以宅在家\n\n 醫護真的太辛苦了\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n
## 2 這種好處就應該要拿\n\n 汶川大地震台灣捐了70億\n\n 現在拿它一點疫苗怎麼了嗎???\n\n 當然我知道很多人不想打中國製的疫苗\n\n 但是 你不想打 別人想打的話 這是他的權利\n\n 應該沒有人會逼你打中國製的\n\n 你可以等國產 或是 看政府能不能買到美國爸爸的疫苗\n\n 專家來分享抗疫經驗也沒啥不好的\n\n 多一點意見交流\n\n 總比只會校正回歸的中央疫情指揮中心好??\n\n\n 當然最好是拿個一百萬BNT的啦\n\n 至少先讓醫護打完\n\n 你還可以宅在家\n\n 醫護真的太辛苦了\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n
## 3 這種好處就應該要拿\n\n 汶川大地震台灣捐了70億\n\n 現在拿它一點疫苗怎麼了嗎???\n\n 當然我知道很多人不想打中國製的疫苗\n\n 但是 你不想打 別人想打的話 這是他的權利\n\n 應該沒有人會逼你打中國製的\n\n 你可以等國產 或是 看政府能不能買到美國爸爸的疫苗\n\n 專家來分享抗疫經驗也沒啥不好的\n\n 多一點意見交流\n\n 總比只會校正回歸的中央疫情指揮中心好??\n\n\n 當然最好是拿個一百萬BNT的啦\n\n 至少先讓醫護打完\n\n 你還可以宅在家\n\n 醫護真的太辛苦了\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n
## cmtPoster cmtStatus cmtContent topic gamma
## 1 ted01234567 噓 :支持。但是畜生不能進來 3 0.7079776
## 2 yamato75310 推 :他們出錢就好，沒人要打科興 3 0.7079776
## 3 gigibouz → :這應該也是吱己人 3 0.7079776取出 cmtPoster(回覆者)、artPoster(發文者)、artUrl(文章連結) 三個欄位
link <- posts_Reviews %>% select(cmtPoster, artPoster, artUrl)
head(link,3)## cmtPoster artPoster
## 1 ted01234567 cloud72426
## 2 yamato75310 cloud72426
## 3 gigibouz cloud72426
## artUrl
## 1 https://www.ptt.cc/bbs/Gossiping/M.1621873731.A.A4C.html
## 2 https://www.ptt.cc/bbs/Gossiping/M.1621873731.A.A4C.html
## 3 https://www.ptt.cc/bbs/Gossiping/M.1621873731.A.A4C.html基本網路圖
建立網路關係
reviewNetwork <- graph_from_data_frame(d=link, directed=T)
reviewNetwork## IGRAPH 0924a6b DN-- 19046 114013 --
## + attr: name (v/c), artUrl (e/c)
## + edges from 0924a6b (vertex names):
## [1] ted01234567 ->cloud72426 yamato75310 ->cloud72426 gigibouz ->cloud72426
## [4] baboosh ->cloud72426 baboosh ->cloud72426 baboosh ->cloud72426
## [7] didi0909 ->cloud72426 kougousei ->cloud72426 duckweedgina->cloud72426
## [10] MyGuitar ->cloud72426 MyGuitar ->cloud72426 MyGuitar ->cloud72426
## [13] kukuso ->cloud72426 coolrock ->cloud72426 ran1124 ->cloud72426
## [16] MyGuitar ->cloud72426 MyGuitar ->cloud72426 MyGuitar ->cloud72426
## [19] MyGuitar ->cloud72426 MyGuitar ->cloud72426 MyGuitar ->cloud72426
## [22] bobosheep ->cloud72426 utuyuy ->cloud72426 utuyuy ->cloud72426
## + ... omitted several edges直接畫的話，因為點沒有經過篩選，看起來會密密麻麻的 還需要經過一次資料篩選
## 畫出網路圖(密集恐懼警告)
#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## # A tibble: 1,050 x 2
## artPoster count
## <chr> <int>
## 1 BleedWang 7
## 2 violetking 6
## 3 xiemark 6
## 4 arace88 5
## 5 CavendishJr 5
## 6 jack125125 5
## 7 lpbrother 5
## 8 nba999999999 5
## 9 tw689 5
## 10 Vendetta 5
## # ... with 1,040 more rows # 帳號回覆總數
review_count = reviews %>%
group_by(cmtPoster) %>%
summarise(count = n()) %>%
arrange(desc(count))
review_count## # A tibble: 18,641 x 2
## cmtPoster count
## <chr> <int>
## 1 s9234032 350
## 2 birdy590 339
## 3 BaRanKa 217
## 4 sincere77 216
## 5 amida959 212
## 6 alan0204 192
## 7 A80211ab 190
## 8 kissa0924307 183
## 9 linkmusic 173
## 10 lesnaree2 171
## # ... with 18,631 more rows # 發文者
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)) # 發文者數量 1,045## [1] 1045length(unique(posts_Reviews$cmtPoster)) # 回覆者數量 18,641## [1] 18641allPoster <- c(posts_Reviews$artPoster, posts_Reviews$cmtPoster) # 總參與人數 19,046
length(unique(allPoster))## [1] 19046標記所有出現過得使用者
。poster：只發過文、發過文+留過言 。replyer：只留過言
userList <- data.frame(user=unique(allPoster)) %>%
mutate(type=ifelse(user%in%posts$artPoster, "poster", "replyer"))
head(userList,3)## user type
## 1 cloud72426 poster
## 2 ilanese poster
## 3 ppon replyer以日期篩選社群
事件是5/28討論最激烈爆發的，我們挑出當天的文章和回覆看看
link <- posts_Reviews %>%
group_by(cmtPoster, artUrl) %>%
filter(n()>3) %>%
filter(commentNum > 200) %>%
filter(artCat=="Gossiping") %>%
filter(artDate == as.Date('2021-05-28')) %>%
select(cmtPoster, artPoster, artUrl) %>%
unique()
link## # A tibble: 409 x 3
## # Groups: cmtPoster, artUrl [409]
## cmtPoster artPoster artUrl
## <chr> <chr> <chr>
## 1 qqq87112 yushenglu https://www.ptt.cc/bbs/Gossiping/M.1622160804.A.56F.html
## 2 Anyotw yushenglu https://www.ptt.cc/bbs/Gossiping/M.1622160804.A.56F.html
## 3 zlatan10 yushenglu https://www.ptt.cc/bbs/Gossiping/M.1622160804.A.56F.html
## 4 wjes30325 yushenglu https://www.ptt.cc/bbs/Gossiping/M.1622160804.A.56F.html
## 5 F5 yushenglu https://www.ptt.cc/bbs/Gossiping/M.1622160804.A.56F.html
## 6 countryair yushenglu https://www.ptt.cc/bbs/Gossiping/M.1622160804.A.56F.html
## 7 zxc1234529 yushenglu https://www.ptt.cc/bbs/Gossiping/M.1622160804.A.56F.html
## 8 menshuei yushenglu https://www.ptt.cc/bbs/Gossiping/M.1622160804.A.56F.html
## 9 chaosic yushenglu https://www.ptt.cc/bbs/Gossiping/M.1622160804.A.56F.html
## 10 keydata yushenglu https://www.ptt.cc/bbs/Gossiping/M.1622160804.A.56F.html
## # ... with 399 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 sincere77 replyer
## 2 mscp replyer
## 3 neos042 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=3,
edge.width=3,
vertex.label.dist=1,
vertex.label=ifelse(degree(reviewNetwork) > filter_degree, V(reviewNetwork)$label, NA),vertex.label.font=2)
我們可以看到基本的使用者關係，但是我們希望能夠將更進階的資訊視覺化。
例如：使用者經常參與的文章種類，或是使用者在該社群網路中是否受到歡迎。
以主題篩選社群
- 抓link
挑選出2021-05-28當天的文章， 篩選一篇文章回覆3次以上者，且文章留言數多餘200則， 文章主題歸類為2(疫苗廠牌及取得來源)與4(確診者及疫苗接種數量等疫情狀況新聞媒體報導)者， 欄位只取：cmtPoster(評論者), artPoster(發文者), artUrl(文章連結), topic(主題)
link <- posts_Reviews %>%
group_by(cmtPoster, artUrl) %>%
filter(n()>3) %>%
filter(commentNum > 200) %>%
filter(artCat=="Gossiping") %>%
filter(artDate == as.Date('2021-05-28')) %>%
filter(topic == 2 | topic == 4) %>%
select(cmtPoster, artPoster, artUrl, topic) %>%
unique()
link## # A tibble: 228 x 4
## # Groups: cmtPoster, artUrl [228]
## cmtPoster artPoster artUrl topic
## <chr> <chr> <chr> <int>
## 1 ev331 leolintw https://www.ptt.cc/bbs/Gossiping/M.1622162244.A.~ 4
## 2 thinkfun leolintw https://www.ptt.cc/bbs/Gossiping/M.1622162244.A.~ 4
## 3 xager leolintw https://www.ptt.cc/bbs/Gossiping/M.1622162244.A.~ 4
## 4 perfect1030 leolintw https://www.ptt.cc/bbs/Gossiping/M.1622162244.A.~ 4
## 5 fulongb210f ben108472 https://www.ptt.cc/bbs/Gossiping/M.1622163733.A.~ 2
## 6 waijr ben108472 https://www.ptt.cc/bbs/Gossiping/M.1622163733.A.~ 2
## 7 yyc210 ben108472 https://www.ptt.cc/bbs/Gossiping/M.1622163733.A.~ 2
## 8 jeffky ben108472 https://www.ptt.cc/bbs/Gossiping/M.1622163733.A.~ 2
## 9 kelven0813 ben108472 https://www.ptt.cc/bbs/Gossiping/M.1622163733.A.~ 2
## 10 kivan00 pm2001 https://www.ptt.cc/bbs/Gossiping/M.1622167499.A.~ 4
## # ... with 218 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 sincere77 replyer
## 2 swommy replyer
## 3 OLDBOY replyer使用者經常參與的文章種類
filter_degree = 7
# 建立網路關係
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("Poster","Reviewer"), 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("poster","reviewer"), pch=21,
col="#777777", pt.bg=c("gold","lightblue"), pt.cex=1, cex=1)
legend("topleft", c("push","boo"),
col=c("lightgreen","palevioletred"), lty=1, cex=1)
可以發現本次的討論中幾乎都是推文居多而噓文較少
總結
1.疫苗數量、品牌的討論重點有哪些? 主要分為哪幾種風向?
對於2021-05-24 ~ 2021-05-28收集的文章，大概可以分成嘲諷疫苗取得數量不足及客觀討論各縣市分配數量這兩種，其他還有著重討論可否自由選擇疫苗接種品牌及國內已完成注射接種者相關的討論等四種。討論重點多在於正確統計「各項數字」與「日期公布」等事項的。
2.目前風向最偏哪邊?
客觀討論計算方式的文章雖已增加不少，但仍以嘲諷、八卦性質的文章居多。
3.討論疫苗獲得及各縣市確診者與疫苗分配數量的社群網路如何分布?
社群聲量高的網友以嘲諷疫苗獲得數量不足的貼文居多，對疫苗分配數量不公多以批評為主。
4.向何處及何種廠牌疫苗的意見領袖有誰?網友的推噓狀態如何?
因為資料選取的時間較短，只要幾篇回覆量高的貼文，就有機會成為社群中心，在八卦版上，以報導討論為主的意見領袖有： sodabing，回覆推噓皆有，以推居多，調侃批評部分則有： KobeNi，網友大多持正面推文為主。