系統參數設定
Sys.setlocale(category = "LC_ALL", locale = "zh_TW.UTF-8") # 避免中文亂碼## [1] ""安裝需要的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 Gossip/版文章、回覆
- 資料集： KP_articleMetaData.csv、KP_articleReviews.csv
- 關鍵字：柯文哲、科p、柯p
- 資料時間：2021-05-14 ~ 2021-05-27
這次我們針對5/14疫情爆發後，ptt版上討論與柯文哲有關文章的風向，主要針對以下方向分析：
1.討論與柯文哲相關的事件重點有哪些? 2.目前風向最偏哪邊? 3.討論與柯文哲相關的事件的社群網路如何分布?
1. 資料前處理
在本篇分析中，我們希望建構特定議題的社群網路圖，並分析網路中討論的議題主題
我們需要兩種資料： (1) 每篇文章的主題分類(LDA) (2) 社群網路圖的link和nodes
載入文章和網友回覆資料
posts <- read_csv("data/KP_articleMetaData.csv") # 文章 261
reviews <- read_csv("data/KP_articleReviews.csv") # 回覆 62214
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-05-13 16:04:45 https~ humbler Gossi~ 274 177 19
## 2 [新聞]柯文哲~ 2021-05-13 16:06:52 https~ shawnm80 Gossi~ 49 29 3
## 3 Re:[新聞]~ 2021-05-13 16:22:26 https~ devidevi Gossi~ 17 8 1
## 4 [新聞]外勞要~ 2021-05-14 02:09:51 https~ shawnm80 Gossi~ 1218 757 82
## 5 Re:[新聞]~ 2021-05-14 02:45:24 https~ SeaForest Gossi~ 8 2 0
## 6 Re:[新聞]~ 2021-05-14 02:47:02 https~ zxceleph~ Gossi~ 46 34 1
## # ... 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-05-13 16:04:45 https~ humbler Gossi~ amilkami~ →
## 2 [新聞]和平醫~ 2021-05-13 16:04:45 https~ humbler Gossi~ qilar 推
## 3 [新聞]和平醫~ 2021-05-13 16:04:45 https~ humbler Gossi~ audy 推
## 4 [新聞]和平醫~ 2021-05-13 16:04:45 https~ humbler Gossi~ halfmoon6 →
## 5 [新聞]和平醫~ 2021-05-13 16:04:45 https~ humbler Gossi~ headcase 推
## 6 [新聞]和平醫~ 2021-05-13 16:04:45 https~ humbler Gossi~ sion1993 推
## # ... with 2 more variables: cmtDate <dttm>, cmtContent <chr>2.LDA 主題分類
文章斷句 #註釋/取消註釋 當前行/選中區域 Ctrl+Shift+C
# # 文章斷句("\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/new_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 = "data/token_result.rdata")斷詞結果可以先存起來，就不用再重跑一次
load("data/token_result.rdata")## Attempting to load the environment 'package:tmcn'## Warning: package 'tmcn' was built under R version 4.0.4## # tmcn Version: 0.2-13清理斷詞結果
。根據詞頻，選擇只出現3字以上的字 。整理成url,word,n的格式之後，就可以轉dtm
P.S. groupby by之後原本的字詞結構會不見，把詞頻另存在一個reserved_word裡面
freq = 3
# 依據字頻挑字
reserved_word <- tokens %>%
group_by(word) %>%
count() %>%
filter(n > freq)
mask_removed <- tokens %>%
filter(word %in% reserved_word$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: 261 x 3
## # Groups: document [261]
## document topic gamma
## <chr> <int> <dbl>
## 1 https://www.ptt.cc/bbs/Gossiping/M.1620969615.A.9E3.html 1 0.825
## 2 https://www.ptt.cc/bbs/Gossiping/M.1621063978.A.5C7.html 1 0.399
## 3 https://www.ptt.cc/bbs/Gossiping/M.1621416740.A.6FF.html 1 0.998
## 4 https://www.ptt.cc/bbs/Gossiping/M.1621417803.A.6C7.html 1 0.562
## 5 https://www.ptt.cc/bbs/Gossiping/M.1621420974.A.D6A.html 1 0.982
## 6 https://www.ptt.cc/bbs/Gossiping/M.1621422585.A.FB8.html 1 0.461
## 7 https://www.ptt.cc/bbs/Gossiping/M.1621437045.A.9DA.html 1 0.991
## 8 https://www.ptt.cc/bbs/Gossiping/M.1621438054.A.F6D.html 1 0.506
## 9 https://www.ptt.cc/bbs/Gossiping/M.1621499638.A.7D5.html 1 0.999
## 10 https://www.ptt.cc/bbs/Gossiping/M.1621507384.A.A64.html 1 0.564
## # ... with 251 more rows資料內容探索
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(30)## artTitle
## 1 [新聞]快訊／柯文哲不認同「開車2人以上要戴口
## 2 [問卦]是不是欠柯文哲一個道歉
## 3 Re:[新聞]本土3天暴增719例柯文哲：考慮自動自發
## 4 Re:[新聞]校正回歸？柯文哲：檢驗塞車中央要用新
## 5 [新聞]蔡英文稱7月提供國產疫苗柯文哲批：先下
## 6 Re:[問卦]是不是欠柯文哲一個道歉
## 7 [新聞]陳佩琪怒問柯P「聽你話打疫苗是賤人？」
## 8 [新聞]柯文哲不認同「開車2人以上要戴口罩」
## 9 [新聞]國產疫苗7月上路？ 柯文哲吐真心話：我
## 10 Re:[新聞]快、狠、準斬疫病！柯文哲重拾醫師本色
## 11 Re:[問卦]台灣的首長是不是只有柯P敢記者會嗆AIT?
## 12 Re:[新聞]柯文哲再嗆陳時中：沒有戰爭靠防守打贏
## 13 Re:[新聞]響應柯文哲徵召！蔡壁如「願加入第一線」
## 14 [新聞]綠營拉柯打侯？柯文哲：覆巢之下無完卵
## 15 Re:[爆卦]LIVE北市防疫升至三級柯文哲臨時記者會
## 16 [新聞]5/6號挨批笑死人柯文哲：明天再問李秉穎他
## 17 Re:[新聞]專訪／柯文哲：大陸未來可能送疫苗
## 18 Re:[新聞]快訊／「由不得你！」柯文哲：所有醫護人
## 19 Re:[新聞]快訊／柯文哲深夜曝真心話：疫情高峰還沒
## 20 [問卦]如果去年開始防疫指揮官是柯文哲...
## 21 [新聞]陳佩琪喊不打AZ又接種被罵賤 柯文哲心疼：感謝太太支持我
## 22 Re:[新聞]疫情升溫警報響！柯文哲：國九、高三明
## 23 [新聞]柯P:這個狀況要撐到8月撐不下去會死傷慘
## 24 Re:[新聞]北市公布足跡？柯文哲：幾百確診已沒辦
## 25 [新聞]疫情爆發媒體人嘆：柯文哲警語沒人在意
## 26 [新聞]柯文哲：若等到8月打國產疫苗等於「把國
## 27 [新聞]柯文哲防疫遭批蔡峻維怒嗆基進黨
## 28 Re:[爆卦]八卦板x挺柯文哲的x中國網軍
## 29 Re:[新聞]中央應買輝瑞疫苗柯P:台灣撐不到8月會死
## 30 Re:[爆卦]柯文哲：陽性率降、確診不必馬上送醫院posts_topic %>% # 主題四
filter(topic==4) %>%
select(artTitle) %>%
unique() %>%
sample_n(20)## artTitle
## 1 [新聞]PCR結果要2天！柯文哲解密「校正回歸」
## 2 [爆卦]柯文哲:數字密碼、疫情統計與分析
## 3 Re:[新聞]柯P建議改公布快篩陽性梁文傑酸：就像
## 4 [新聞]疫情升溫警報響！柯文哲：國九、高三明
## 5 [新聞]萬華成疫情重災區仍不封？ 柯文哲重申N
## 6 [新聞]「公佈足跡意義不大！」柯文哲解釋原因
## 7 Re:[爆卦]柯p:校正回歸就是流程改變
## 8 [新聞]北市跟進封籃球框？ 柯文哲無奈曝「一句
## 9 Re:[爆卦]LIVE北市防疫升至三級柯文哲臨時記者會
## 10 [新聞]剝皮寮快篩站爆篩劑不夠傳柯文哲震怒
## 11 [新聞]「校正回歸」確診+269 柯文哲：採檢量
## 12 [新聞]萬華不封區理由曝光！柯文哲提「A的N次
## 13 [新聞]「自動自發」封城？柯文哲：用國民素質
## 14 [新聞]柯文哲報喜訊萬華快篩陽性降至4.7％
## 15 [新聞]校正回歸？柯文哲：不要創造新名詞把人民
## 16 [新聞]一表6步驟看懂「400例校正」密碼 柯P幫
## 17 [問卦]今天柯文哲記者會說的英文名詞求解
## 18 [新聞]「不會硬封城」柯P：部分控制中、盡量別
## 19 Re:[爆卦]柯文哲：陽性率降、確診不必馬上送醫院
## 20 [新聞]防堵疫情擴散！柯文哲下令「急診做PCR檢這次我們把討論焦點放在柯文哲上，從主題分布大概可以看到兩類觀點：
- 主題三：
關於疫苗的事件「國產疫苗7月上路？」、「今進40萬疫苗柯文哲開轟:美國沒有賣任何一支給台灣」、「柯文哲認為施打疫苗的第一優先是應該是機組人員列為優先」
- 主題四：
因為疫情升溫，再加上校正回歸的名詞出現，所以網路文章有討論如下，對於「校正回歸就是流程改變」、「雙北停課」、「自動自發」封城？
日期主題分布
畫出每天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()` regrouping output by 'artDate' (override with `.groups` argument)
table(posts_topic$artCat)##
## Gossiping
## 261posts_topic %>%
group_by(artCat,topic) %>%
summarise(sum = n()) %>%
ggplot(aes(x= artCat,y=sum,fill=as.factor(topic))) +
geom_col(position="dodge")## `summarise()` regrouping output by 'artCat' (override with `.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.1620921888.A.780.html
## 2 https://www.ptt.cc/bbs/Gossiping/M.1620921888.A.780.html
## 3 https://www.ptt.cc/bbs/Gossiping/M.1620921888.A.780.html
## artTitle artDate artTime artPoster
## 1 [新聞]和平醫院爆兩例新冠肺炎 柯文哲喊話「 2021-05-13 16:04:45 humbler
## 2 [新聞]和平醫院爆兩例新冠肺炎 柯文哲喊話「 2021-05-13 16:04:45 humbler
## 3 [新聞]和平醫院爆兩例新冠肺炎 柯文哲喊話「 2021-05-13 16:04:45 humbler
## artCat commentNum push boo
## 1 Gossiping 274 177 19
## 2 Gossiping 274 177 19
## 3 Gossiping 274 177 19
## sentence
## 1 1.媒體來源:\n風傳媒\n\n2.記者署名:\n方炳超\n\n3.完整新聞標題:\n和平醫院爆兩例新冠肺炎 柯文哲喊話「不要恐慌」：應變快情況已控制\n\n4.完整新聞內文:\n新冠肺炎疫情急遽升溫，中央流行疫情指揮中心今（13）日接獲醫院通報，2名住院病患\n確診，隨即與相關衛生單位至該院進行調查防治。對於此事件，台北市衛生局也證實，是\n台北市立聯合醫院和平院區。台北市長柯文哲也在臉書證實。\n\n\n今晚有消息傳出，和平醫院有2名住院病患確診，台北市長柯文哲今晚已赴和平醫院視察\n，他強調，此次狀況都在控制中，與當年SARS導狀況不同，目前沒有封院危險，請市民朋\n友不要恐慌。\n柯文哲今夜在臉書發文，柯文哲指出，稍早指揮中心已經宣布，台北市立和平醫院急診收\n治2名病患，住院後幾天出現喘氣、發燒等症狀，胸部X光出現肺炎，採檢後確診，目前與\n確診者有接觸的病患、醫護人員，都已經匡列，依防疫醫師疫調結果，進行後續防疫作為\n，密切接觸者已經完成採檢，病人移至負壓隔離病房繼續治療，其他需要居家隔離的，部\n分已送往劍潭活動中心隔離，部分在醫院隔離，明天轉送防疫旅館；至於需要自主管理的\n，警消醫護休息棧也都準備接受入住。而住院病患只出不進，出院者需先檢驗並做後續追\n蹤關懷，急診環境清消中，暫停營業。（相關報導：注意！從基隆到高雄、從拜廟到「喝\n茶」 萬華茶室群聚案活動史一次看｜更多文章）\n\n柯文哲表示，門診部分已由環保局完成全面清消，並與住院<U+4E36>急診區區隔，原則上只接受\n已經預掛的病患。\n\n柯文哲：明與陳時中開會再向大眾報告\n此外，柯文哲指出，他今晚已與疾管署及指揮官張上淳<U+4E36>台北防疫指揮中心、衛生局等單\n位連夜開會討論所有的防疫措施形成共識，並共同解決所有防疫的問題，晚間他也到和平\n醫院看過，狀況都在控制當中，與SARS狀況不同，這次在確診後應變速度夠快，目前沒有\n封院的危險，仍然維持醫療量能，也明確知道感染來源，請市民朋友不要恐慌，明天他會\n與衛福部陳時中部長開會，再向大家做完整報告。\n\n\n5.完整新聞連結 (或短網址):\nhttps://www.storm.mg/article/3676129\n6.備註:\n台北市民不要恐慌\n應變快已經在掌握之中\n遵守台北市政府公布的防疫措施
## 2 1.媒體來源:\n風傳媒\n\n2.記者署名:\n方炳超\n\n3.完整新聞標題:\n和平醫院爆兩例新冠肺炎 柯文哲喊話「不要恐慌」：應變快情況已控制\n\n4.完整新聞內文:\n新冠肺炎疫情急遽升溫，中央流行疫情指揮中心今（13）日接獲醫院通報，2名住院病患\n確診，隨即與相關衛生單位至該院進行調查防治。對於此事件，台北市衛生局也證實，是\n台北市立聯合醫院和平院區。台北市長柯文哲也在臉書證實。\n\n\n今晚有消息傳出，和平醫院有2名住院病患確診，台北市長柯文哲今晚已赴和平醫院視察\n，他強調，此次狀況都在控制中，與當年SARS導狀況不同，目前沒有封院危險，請市民朋\n友不要恐慌。\n柯文哲今夜在臉書發文，柯文哲指出，稍早指揮中心已經宣布，台北市立和平醫院急診收\n治2名病患，住院後幾天出現喘氣、發燒等症狀，胸部X光出現肺炎，採檢後確診，目前與\n確診者有接觸的病患、醫護人員，都已經匡列，依防疫醫師疫調結果，進行後續防疫作為\n，密切接觸者已經完成採檢，病人移至負壓隔離病房繼續治療，其他需要居家隔離的，部\n分已送往劍潭活動中心隔離，部分在醫院隔離，明天轉送防疫旅館；至於需要自主管理的\n，警消醫護休息棧也都準備接受入住。而住院病患只出不進，出院者需先檢驗並做後續追\n蹤關懷，急診環境清消中，暫停營業。（相關報導：注意！從基隆到高雄、從拜廟到「喝\n茶」 萬華茶室群聚案活動史一次看｜更多文章）\n\n柯文哲表示，門診部分已由環保局完成全面清消，並與住院<U+4E36>急診區區隔，原則上只接受\n已經預掛的病患。\n\n柯文哲：明與陳時中開會再向大眾報告\n此外，柯文哲指出，他今晚已與疾管署及指揮官張上淳<U+4E36>台北防疫指揮中心、衛生局等單\n位連夜開會討論所有的防疫措施形成共識，並共同解決所有防疫的問題，晚間他也到和平\n醫院看過，狀況都在控制當中，與SARS狀況不同，這次在確診後應變速度夠快，目前沒有\n封院的危險，仍然維持醫療量能，也明確知道感染來源，請市民朋友不要恐慌，明天他會\n與衛福部陳時中部長開會，再向大家做完整報告。\n\n\n5.完整新聞連結 (或短網址):\nhttps://www.storm.mg/article/3676129\n6.備註:\n台北市民不要恐慌\n應變快已經在掌握之中\n遵守台北市政府公布的防疫措施
## 3 1.媒體來源:\n風傳媒\n\n2.記者署名:\n方炳超\n\n3.完整新聞標題:\n和平醫院爆兩例新冠肺炎 柯文哲喊話「不要恐慌」：應變快情況已控制\n\n4.完整新聞內文:\n新冠肺炎疫情急遽升溫，中央流行疫情指揮中心今（13）日接獲醫院通報，2名住院病患\n確診，隨即與相關衛生單位至該院進行調查防治。對於此事件，台北市衛生局也證實，是\n台北市立聯合醫院和平院區。台北市長柯文哲也在臉書證實。\n\n\n今晚有消息傳出，和平醫院有2名住院病患確診，台北市長柯文哲今晚已赴和平醫院視察\n，他強調，此次狀況都在控制中，與當年SARS導狀況不同，目前沒有封院危險，請市民朋\n友不要恐慌。\n柯文哲今夜在臉書發文，柯文哲指出，稍早指揮中心已經宣布，台北市立和平醫院急診收\n治2名病患，住院後幾天出現喘氣、發燒等症狀，胸部X光出現肺炎，採檢後確診，目前與\n確診者有接觸的病患、醫護人員，都已經匡列，依防疫醫師疫調結果，進行後續防疫作為\n，密切接觸者已經完成採檢，病人移至負壓隔離病房繼續治療，其他需要居家隔離的，部\n分已送往劍潭活動中心隔離，部分在醫院隔離，明天轉送防疫旅館；至於需要自主管理的\n，警消醫護休息棧也都準備接受入住。而住院病患只出不進，出院者需先檢驗並做後續追\n蹤關懷，急診環境清消中，暫停營業。（相關報導：注意！從基隆到高雄、從拜廟到「喝\n茶」 萬華茶室群聚案活動史一次看｜更多文章）\n\n柯文哲表示，門診部分已由環保局完成全面清消，並與住院<U+4E36>急診區區隔，原則上只接受\n已經預掛的病患。\n\n柯文哲：明與陳時中開會再向大眾報告\n此外，柯文哲指出，他今晚已與疾管署及指揮官張上淳<U+4E36>台北防疫指揮中心、衛生局等單\n位連夜開會討論所有的防疫措施形成共識，並共同解決所有防疫的問題，晚間他也到和平\n醫院看過，狀況都在控制當中，與SARS狀況不同，這次在確診後應變速度夠快，目前沒有\n封院的危險，仍然維持醫療量能，也明確知道感染來源，請市民朋友不要恐慌，明天他會\n與衛福部陳時中部長開會，再向大家做完整報告。\n\n\n5.完整新聞連結 (或短網址):\nhttps://www.storm.mg/article/3676129\n6.備註:\n台北市民不要恐慌\n應變快已經在掌握之中\n遵守台北市政府公布的防疫措施
## cmtPoster cmtStatus cmtContent topic
## 1 amilkamilk → :感謝台北公開透明，不向部桃事件大家被蒙在鼓裡 2
## 2 qilar 推 :明確知道？阿公店生意這麼好？？ 2
## 3 audy 推 :柯P得一分 2
## gamma
## 1 0.9991222
## 2 0.9991222
## 3 0.9991222取出 cmtPoster(回覆者)、artPoster(發文者)、artUrl(文章連結) 三個欄位
link <- posts_Reviews %>% select(cmtPoster, artPoster, artUrl)
head(link,3)## cmtPoster artPoster artUrl
## 1 amilkamilk humbler https://www.ptt.cc/bbs/Gossiping/M.1620921888.A.780.html
## 2 qilar humbler https://www.ptt.cc/bbs/Gossiping/M.1620921888.A.780.html
## 3 audy humbler https://www.ptt.cc/bbs/Gossiping/M.1620921888.A.780.html基本網路圖
建立網路關係
reviewNetwork <- graph_from_data_frame(d=link, directed=T)
reviewNetwork## IGRAPH 109c8d9 DN-- 15385 62214 --
## + attr: name (v/c), artUrl (e/c)
## + edges from 109c8d9 (vertex names):
## [1] amilkamilk ->humbler qilar ->humbler audy ->humbler
## [4] halfmoon6 ->humbler headcase ->humbler sion1993 ->humbler
## [7] kobelan ->humbler jetalpha ->humbler F5 ->humbler
## [10] u8702116 ->humbler XDDDpupu5566->humbler jetalpha ->humbler
## [13] hy23 ->humbler ROCKSAGA ->humbler fatoil27 ->humbler
## [16] userpeter ->humbler jetalpha ->humbler chyou2003 ->humbler
## [19] NaOH268 ->humbler TZUYIC ->humbler aaaaluenaaa ->humbler
## [22] aaaaluenaaa ->humbler mioaria ->humbler TZUYIC ->humbler
## + ... 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`.
posts## # A tibble: 261 x 10
## artTitle artDate artTime artUrl artPoster artCat commentNum push boo
## <chr> <date> <time> <chr> <chr> <chr> <dbl> <dbl> <dbl>
## 1 [新聞]和平醫~ 2021-05-13 16:04:45 https~ humbler Gossi~ 274 177 19
## 2 [新聞]柯文哲~ 2021-05-13 16:06:52 https~ shawnm80 Gossi~ 49 29 3
## 3 Re:[新聞]~ 2021-05-13 16:22:26 https~ devidevi Gossi~ 17 8 1
## 4 [新聞]外勞要~ 2021-05-14 02:09:51 https~ shawnm80 Gossi~ 1218 757 82
## 5 Re:[新聞]~ 2021-05-14 02:45:24 https~ SeaForest Gossi~ 8 2 0
## 6 Re:[新聞]~ 2021-05-14 02:47:02 https~ zxceleph~ Gossi~ 46 34 1
## 7 Re:[新聞]~ 2021-05-14 02:48:04 https~ johnny96~ Gossi~ 15 4 1
## 8 Re:[新聞]~ 2021-05-14 03:00:28 https~ caeasonfb Gossi~ 10 4 1
## 9 Re:[新聞]~ 2021-05-14 03:08:51 https~ pchunters Gossi~ 18 8 0
## 10 [新聞]地方可~ 2021-05-14 05:20:13 https~ welcome Gossi~ 42 20 1
## # ... with 251 more rows, and 1 more variable: sentence <chr>依據發文數或回覆數篩選post和review
# 帳號發文篇數
post_count = posts %>%
group_by(artPoster) %>%
summarise(count = n()) %>%
arrange(desc(count))## `summarise()` ungrouping output (override with `.groups` argument)post_count## # A tibble: 214 x 2
## artPoster count
## <chr> <int>
## 1 caeasonfb 4
## 2 emuless 4
## 3 kcbill 4
## 4 hithaman 3
## 5 humbler 3
## 6 monmo 3
## 7 OhwadaAkira 3
## 8 sunchen0201 3
## 9 xzcb2008 3
## 10 Ahhhhaaaa 2
## # ... with 204 more rows# 帳號回覆總數
review_count = reviews %>%
group_by(cmtPoster) %>%
summarise(count = n()) %>%
arrange(desc(count))## `summarise()` ungrouping output (override with `.groups` argument)review_count## # A tibble: 15,305 x 2
## cmtPoster count
## <chr> <int>
## 1 birdy590 265
## 2 vow70 252
## 3 Tiphareth 212
## 4 s9234032 186
## 5 linkmusic 182
## 6 trywish 178
## 7 Annis812 166
## 8 nike00000000 161
## 9 romber 157
## 10 gibbs1286 149
## # ... with 15,295 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)) # 發文者數量 214## [1] 214length(unique(posts_Reviews$cmtPoster)) # 回覆者數量 15305## [1] 15305allPoster <- c(posts_Reviews$artPoster, posts_Reviews$cmtPoster)
length(unique(allPoster)) # 總參與人數 15385## [1] 15385標記所有出現過得使用者
- poster：只發過文、發過文和留過言
- replyer：只留過言
userList <- data.frame(user=unique(allPoster)) %>%
mutate(type=ifelse(user%in%posts$artPoster, "poster", "replyer"))
head(userList,3)## user type
## 1 humbler poster
## 2 shawnm80 poster
## 3 devidevi replyer以日期篩選社群
b = posts_Reviews %>%
group_by( artUrl) %>% mutate(n=n())
View(b)因為5/22討論度很大，我們挑出當天的文章和回覆看看
link <- posts_Reviews %>%
group_by(cmtPoster, artUrl) %>%
filter(n()>3) %>%
filter(commentNum > 200) %>%
filter(artCat=="Gossiping") %>%
filter(artDate == as.Date('2021-05-22')) %>%
select(cmtPoster, artPoster, artUrl) %>%
unique()
link## # A tibble: 128 x 3
## # Groups: cmtPoster, artUrl [128]
## cmtPoster artPoster artUrl
## <chr> <chr> <chr>
## 1 slimak cleanID https://www.ptt.cc/bbs/Gossiping/M.1621669910.A.670.h~
## 2 horseorange cleanID https://www.ptt.cc/bbs/Gossiping/M.1621669910.A.670.h~
## 3 j9145 cleanID https://www.ptt.cc/bbs/Gossiping/M.1621669910.A.670.h~
## 4 vingfing cleanID https://www.ptt.cc/bbs/Gossiping/M.1621669910.A.670.h~
## 5 Anvec cleanID https://www.ptt.cc/bbs/Gossiping/M.1621669910.A.670.h~
## 6 ga2006221985 cleanID https://www.ptt.cc/bbs/Gossiping/M.1621669910.A.670.h~
## 7 reccalin cleanID https://www.ptt.cc/bbs/Gossiping/M.1621669910.A.670.h~
## 8 basslife cleanID https://www.ptt.cc/bbs/Gossiping/M.1621669910.A.670.h~
## 9 jasonpig cleanID https://www.ptt.cc/bbs/Gossiping/M.1621669910.A.670.h~
## 10 WarIII cleanID https://www.ptt.cc/bbs/Gossiping/M.1621669910.A.670.h~
## # ... with 118 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 devidevi replyer
## 2 seabox replyer
## 3 KZS 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-22當天的文章， 篩選一篇文章回覆3次以上者，且文章留言數多餘200則， 文章主題歸類為3(疫苗)與4(疫情升溫的措施)者， 欄位只取：cmtPoster(評論者), artPoster(發文者), artUrl(文章連結), topic(主題)
link <- posts_Reviews %>%
group_by(cmtPoster, artUrl) %>%
filter(n()>3) %>%
filter(commentNum > 10) %>%
filter(artCat=="Gossiping") %>% #HatePolitics / Gossiping
filter(topic == 3 | topic == 4) %>%
select(cmtPoster, artPoster, artUrl, topic) %>%
unique()
link## # A tibble: 814 x 4
## # Groups: cmtPoster, artUrl [814]
## cmtPoster artPoster artUrl topic
## <chr> <chr> <chr> <int>
## 1 myyalga zxcelephant https://www.ptt.cc/bbs/Gossiping/M.1620960424.A.~ 3
## 2 tudou5566 kcbill https://www.ptt.cc/bbs/Gossiping/M.1620992928.A.~ 4
## 3 hy0106 kcbill https://www.ptt.cc/bbs/Gossiping/M.1620992928.A.~ 4
## 4 npc776 kcbill https://www.ptt.cc/bbs/Gossiping/M.1620992928.A.~ 4
## 5 gibbs1286 kcbill https://www.ptt.cc/bbs/Gossiping/M.1620992928.A.~ 4
## 6 wurenben kcbill https://www.ptt.cc/bbs/Gossiping/M.1620992928.A.~ 4
## 7 greatlong kcbill https://www.ptt.cc/bbs/Gossiping/M.1620992928.A.~ 4
## 8 farnorth emuless https://www.ptt.cc/bbs/Gossiping/M.1620993271.A.~ 4
## 9 Tiphareth emuless https://www.ptt.cc/bbs/Gossiping/M.1620993271.A.~ 4
## 10 demitri emuless https://www.ptt.cc/bbs/Gossiping/M.1620993271.A.~ 4
## # ... with 804 more rows#table(link$topic)- 抓nodes 在所有的使用者裡面，篩選link中有出現的使用者
filtered_user <- userList %>%
filter(user%in%link$cmtPoster | user%in%link$artPoster) %>%
arrange(desc(type))
head(filtered_user,3)## user type
## 1 devidevi replyer
## 2 zxcelephant replyer
## 3 seabox 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 == "3", "palevioletred", "lightgreen")
# 畫出社群網路圖(degree>13的才畫出來)
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)## Warning: package 'networkD3' was built under R version 4.0.5links = 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.總結
討論與柯文哲相關的事件重點有哪些? 對於2021-05-14 ~ 2021-05-27收集的文章，大概可以分成疫苗來源、(防疫旅館、醫護人員)、校正回歸、國產疫苗等四種議題。討論事件有關「國產疫苗7月上路？」、「確診居家隔離猝死」、「雙北停課」、「自動自發」等，大家對自身安全、染疫後果、染疫數量等相關的問題。
目前風向最偏哪邊? 目前大家最這兩周都有持續的在討論或關注疫苗的議題。
討論與柯文哲相關的事件的社群網路如何分布? 從社群網路觀察發現，貼文討論聲量都很高。