第十四周：民進黨五月網路聲量
第一組：王萱儒、賴品臻、蔡沛靜、林庭如、陳宥任、紀玥綺、王弘銘
系統參數設定
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/版文章、回覆
- 資料集： articleMetaData.csv、articleReviews.csv
- 關鍵字：民進黨、蔡英文、蔡英魂、陳時中、阿中、蘇貞昌、綠蛆、1450
- 資料時間：2021-05-01 ~ 2021-05-29
本周作業針對五月本土疫情爆發以後執政黨的網路聲量，討論ptt版上相關討論的發文風向，主要針對以下方向分析：
1.有關民進黨的討論重點有哪些? 主要分為哪幾種風向? 2.目前風向最偏哪邊? 3.討論民進黨的社群網路如何分布? 4.討論民進黨的意見領袖有誰?網友的推噓狀態如何?
1. 資料前處理
在本篇分析中，我們希望建構特定議題的社群網路圖，並分析網路中討論的議題主題
我們需要兩種資料： (1) 每篇文章的主題分類(LDA) (2) 社群網路圖的link和nodes
載入文章和網友回覆資料
posts <- read_csv("/Users/user/Desktop/igraph hw/articleMetaData.csv") # 文章 2424
reviews <- read_csv("/Users/user/Desktop/igraph hw/articleReviews.csv") # 回覆 226728
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 17:23:58 https:~ soulfully Gossi~ 0 0 0
## 2 [新聞]華~ 2021-05-01 02:38:01 https:~ hsnugear Gossi~ 146 19 75
## 3 [新聞]首~ 2021-05-01 02:40:23 https:~ benoaico Gossi~ 93 28 32
## 4 Fw:[新聞]~ 2021-05-01 03:01:36 https:~ tachikoma Gossi~ 50 17 6
## 5 Re:[新聞]~ 2021-05-01 03:11:18 https:~ vaiking0~ Gossi~ 2 2 0
## 6 [問卦]民~ 2021-05-01 03:30:53 https:~ yftsai Gossi~ 44 20 7
## # ... 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-01 02:38:01 https://~ hsnugear Gossi~ brianuser →
## 2 [新聞]華航~ 2021-05-01 02:38:01 https://~ hsnugear Gossi~ NTULioner 噓
## 3 [新聞]華航~ 2021-05-01 02:38:01 https://~ hsnugear Gossi~ Borges →
## 4 [新聞]華航~ 2021-05-01 02:38:01 https://~ hsnugear Gossi~ kyozwhie 噓
## 5 [新聞]華航~ 2021-05-01 02:38:01 https://~ hsnugear Gossi~ A6 →
## 6 [新聞]華航~ 2021-05-01 02:38:01 https://~ hsnugear Gossi~ NTULioner →
## # ... with 2 more variables: cmtDate <dttm>, cmtContent <chr>posts <- posts %>%
mutate(sentence=gsub("媒體來源|記者署名|完整新聞標題|完整新聞內文|完整新聞連結|(或短網址)|備註|備註請放最後面|違者新聞文章刪除", "", sentence))
reviews <- reviews %>%
mutate(cmtContent=gsub("媒體來源|記者署名|完整新聞標題|完整新聞內文|完整新聞連結|(或短網址)|備註|備註請放最後面|違者新聞文章刪除", "", cmtContent))2.LDA 主題分類
文章斷句
# #文章斷句("\n\n"取代成"。")
# # dpp_meta <- posts %>%
# # mutate(sentence=gsub("[\n]{2,}", "。", sentence))
#
# #以全形或半形 驚歎號、問號、分號 以及 全形句號 爲依據進行斷句
# # dpp_sentences <- strsplit(dpp_meta$sentence,"[。！；？!?;]")
#
# #將每句句子，與他所屬的文章連結配對起來，整理成一個dataframe
# dpp_sentences <- data.frame(
# artUrl = rep(dpp_meta$artUrl, sapply(dpp_sentences, length)),
# sentence = unlist(dpp_sentences)
# ) %>%
# filter(!str_detect(sentence, regex("^(\t|\n| )*$")))
# # 如果有\t或\n就去掉
#
# dpp_sentences$sentence <- as.character(dpp_sentences$sentence)
# dpp_sentences文章斷詞
## # 文章斷詞
#load dpp_lexicon(特定要斷開的詞，像是user_dict)
# dpp_lexicon <- scan(file = "/Users/user/Desktop/igraph hw/dpp_lexicon.txt", what=character(),sep='\n',
# encoding='utf-8',fileEncoding='utf-8')
#load stop words
# stop_words <- scan(file = "/Users/user/Desktop/igraph hw/stop_words.txt", what=character(),sep='\n',
# encoding='utf-8',fileEncoding='utf-8')
## 使用默認參數初始化一個斷詞引擎
# jieba_tokenizer = worker()
## 使用自訂字典重新斷詞
# new_user_word(jieba_tokenizer, c(dpp_lexicon))
#tokenize function
# dpp_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 <- dpp_sentences %>%
# mutate(sentence = gsub("[[:punct:]]", "",sentence)) %>%
# mutate(sentence = gsub("[0-9a-zA-Z]", "",sentence)) %>%
# unnest_tokens(word, sentence, token=dpp_tokenizer) %>%
# count(artUrl, word) %>% # 計算每篇文章出現的字頻
# rename(count=n)
# tokens
# save.image(file = "/Users/user/Desktop/igraph hw/token_result.rdata")斷詞結果可以先存起來，就不用再重跑一次
load("/Users/user/Desktop/igraph hw/token_result.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()
dpp_removed <- tokens %>%
filter(word %in% reserved_word)
#dpp_dtm 裡面 nrow:幾篇文章 ; ncol:幾個字
dpp_dtm <- dpp_removed %>% cast_dtm(artUrl, word, count) (2) LDA 主題分析
將剛處理好的dtm放入LDA函式分析
# LDA分成4個主題
dpp_lda <- LDA(dpp_dtm, k = 4, control = list(seed = 123))p.s. 。tidy(dpp_lda, matrix = “beta”) # 取字 topic term beta值 。tidy(dpp_lda, matrix=“gamma”) # 取主題 document topic gamma
取出代表字詞(term)
removed_word = c("不是","每天","出來","覺得") #不懂??
# 看各群的常用詞彙
tidy(dpp_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矩陣
dpp_topics <- tidy(dpp_lda, matrix="gamma") %>% # document topic gamma
group_by(document) %>%
top_n(1, wt=gamma)
dpp_topics## # A tibble: 2,424 x 3
## # Groups: document [2,424]
## document topic gamma
## <chr> <int> <dbl>
## 1 https://www.ptt.cc/bbs/Gossiping/M.1620013148.A.214.html 1 0.988
## 2 https://www.ptt.cc/bbs/Gossiping/M.1620029889.A.C96.html 1 0.998
## 3 https://www.ptt.cc/bbs/Gossiping/M.1620033524.A.653.html 1 0.476
## 4 https://www.ptt.cc/bbs/Gossiping/M.1620040199.A.834.html 1 0.994
## 5 https://www.ptt.cc/bbs/Gossiping/M.1620100785.A.A91.html 1 0.563
## 6 https://www.ptt.cc/bbs/Gossiping/M.1620115399.A.384.html 1 0.575
## 7 https://www.ptt.cc/bbs/Gossiping/M.1620274866.A.F00.html 1 0.416
## 8 https://www.ptt.cc/bbs/Gossiping/M.1620355329.A.BBF.html 1 0.999
## 9 https://www.ptt.cc/bbs/Gossiping/M.1620356582.A.41D.html 1 0.999
## 10 https://www.ptt.cc/bbs/Gossiping/M.1620520957.A.F55.html 1 0.780
## # ... with 2,414 more rows資料內容探索
posts_topic <- merge(x = posts, y = dpp_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:[新聞]陳時中首肯地方買疫苗 柯文哲反嗆:買不
## 3 [新聞]蔡英文：七月底前提供國產疫苗、全力偵辦
## 4 Re:[新聞]台獲美疫苗機率小？陳時中：僅AIT個人看
## 5 [討論]韓國買到疫苗美國爸爸給蔡英文了什麼?posts_topic %>% # 主題四
filter(topic==4) %>%
select(artTitle) %>%
unique() %>%
sample_n(5)## artTitle
## 1 Re:[問卦]為什麼民進黨可以搞成這樣?
## 2 [新聞]屏議員潘淑真棄保潛逃民進黨恐被罰上百
## 3 [討論]真的沒人想給民進黨教訓嗎?
## 4 [討論]一人說一個民進黨這二屆執政的貢獻吧
## 5 [討論]蔡英文最擅長的就是收買...這次我們把討論焦點放在執政黨執政作為上，從主題分布大概可以看到兩類觀點：
主題一： > 對於執政黨親美立場卻又遲遲拿不到疫苗，如「蔡英文應對打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") #資料集合併xy意思?
# 把文章和topic
posts_Reviews <- merge(x = posts_Reviews, y = dpp_topics, by.x = "artUrl", by.y="document")
head(posts_Reviews,3)## artUrl
## 1 https://www.ptt.cc/bbs/Gossiping/M.1619836683.A.F72.html
## 2 https://www.ptt.cc/bbs/Gossiping/M.1619836683.A.F72.html
## 3 https://www.ptt.cc/bbs/Gossiping/M.1619836683.A.F72.html
## artTitle artDate artTime artPoster
## 1 [新聞]華航機師疫情未歇蘇貞昌提4如果做得到 2021-05-01 02:38:01 hsnugear
## 2 [新聞]華航機師疫情未歇蘇貞昌提4如果做得到 2021-05-01 02:38:01 hsnugear
## 3 [新聞]華航機師疫情未歇蘇貞昌提4如果做得到 2021-05-01 02:38:01 hsnugear
## artCat commentNum push boo
## 1 Gossiping 146 19 75
## 2 Gossiping 146 19 75
## 3 Gossiping 146 19 75
## sentence
## 1 1.:\n中時\n\n\n2.:\n林周義\n\n\n3.:\n華航機師疫情未歇 蘇貞昌提4如果 做得到防疫會更好\n\n\n4.:\n華航機師疫情延燒，昨日再增3名員工確診。行政院長蘇貞昌今視察中央流行疫情指揮中\n心，提出4個如果，如果主管有狀況早點告訴醫師、如果醫師多一點驚覺、如果清真寺有\n實名制、如果舞廳主管要求戴口罩，防疫一定會做的更好。\n\n蘇貞昌表示，世界疫情比以前嚴重，昨天1天全球有90萬人確診，1萬5000人死亡，日本疫\n情創下新高，韓國現在還在禁止5人以上的集會。台灣雖然做到防疫世界第一，但不能掉\n以輕心。\n\n對於最近的疫情，蘇貞昌表示，1年多下來難免鬆懈，如果房務部主管知道自己會接觸到\n每個房間，可以再有狀況時，早點告訴醫師。第一線的醫師，如果能在看到症狀時多一分\n警覺會更好。\n\n蘇貞昌進一步表示，對於清真寺，集會場所主管如果確實做到實名制、防疫要求，而舞廳\n這種指揮中心要求一定要戴口罩的場所，營業負責人若確實要求民眾戴口罩，保持應有的\n防疫狀況，一定可以做到更好。\n\n對於防疫旅館成溫床一說，蘇貞昌表示，防疫需要全民總動員，指揮中心夜以繼日1年多\n，盡心盡力，難免還是有些場所，有些人員沒有做到位，我們還是多一點鼓勵、加油，也\n呼籲各界多一點警惕小心，這樣一定會做的更好。\n\n蘇貞昌表示，今日視察指揮中心，是為了給指揮中心加油打氣，希望指揮中心進一步要求\n各場所機構、地方政府、中央部會的工作同仁都要提高警覺，也呼籲民眾一定要警覺，如\n今世界疫情比以前嚴峻，不能大意，多一分小心，就能保護自己、保護家人、保護社會。\n\n他也提及，指揮中心一再呼籲大家打疫苗，也放寬了公費對象，希望大家不要因為台灣安\n全就沒有意願。他也特別請指揮官，就打疫苗的幾類人員中，給予合理的放寬，盼提高打\n疫苗的意願，形成鼓勵的作用。\n\n\n5. ():\nhttps://www.chinatimes.com/realtimenews/20210501001353-260405?chdtv
## 2 1.:\n中時\n\n\n2.:\n林周義\n\n\n3.:\n華航機師疫情未歇 蘇貞昌提4如果 做得到防疫會更好\n\n\n4.:\n華航機師疫情延燒，昨日再增3名員工確診。行政院長蘇貞昌今視察中央流行疫情指揮中\n心，提出4個如果，如果主管有狀況早點告訴醫師、如果醫師多一點驚覺、如果清真寺有\n實名制、如果舞廳主管要求戴口罩，防疫一定會做的更好。\n\n蘇貞昌表示，世界疫情比以前嚴重，昨天1天全球有90萬人確診，1萬5000人死亡，日本疫\n情創下新高，韓國現在還在禁止5人以上的集會。台灣雖然做到防疫世界第一，但不能掉\n以輕心。\n\n對於最近的疫情，蘇貞昌表示，1年多下來難免鬆懈，如果房務部主管知道自己會接觸到\n每個房間，可以再有狀況時，早點告訴醫師。第一線的醫師，如果能在看到症狀時多一分\n警覺會更好。\n\n蘇貞昌進一步表示，對於清真寺，集會場所主管如果確實做到實名制、防疫要求，而舞廳\n這種指揮中心要求一定要戴口罩的場所，營業負責人若確實要求民眾戴口罩，保持應有的\n防疫狀況，一定可以做到更好。\n\n對於防疫旅館成溫床一說，蘇貞昌表示，防疫需要全民總動員，指揮中心夜以繼日1年多\n，盡心盡力，難免還是有些場所，有些人員沒有做到位，我們還是多一點鼓勵、加油，也\n呼籲各界多一點警惕小心，這樣一定會做的更好。\n\n蘇貞昌表示，今日視察指揮中心，是為了給指揮中心加油打氣，希望指揮中心進一步要求\n各場所機構、地方政府、中央部會的工作同仁都要提高警覺，也呼籲民眾一定要警覺，如\n今世界疫情比以前嚴峻，不能大意，多一分小心，就能保護自己、保護家人、保護社會。\n\n他也提及，指揮中心一再呼籲大家打疫苗，也放寬了公費對象，希望大家不要因為台灣安\n全就沒有意願。他也特別請指揮官，就打疫苗的幾類人員中，給予合理的放寬，盼提高打\n疫苗的意願，形成鼓勵的作用。\n\n\n5. ():\nhttps://www.chinatimes.com/realtimenews/20210501001353-260405?chdtv
## 3 1.:\n中時\n\n\n2.:\n林周義\n\n\n3.:\n華航機師疫情未歇 蘇貞昌提4如果 做得到防疫會更好\n\n\n4.:\n華航機師疫情延燒，昨日再增3名員工確診。行政院長蘇貞昌今視察中央流行疫情指揮中\n心，提出4個如果，如果主管有狀況早點告訴醫師、如果醫師多一點驚覺、如果清真寺有\n實名制、如果舞廳主管要求戴口罩，防疫一定會做的更好。\n\n蘇貞昌表示，世界疫情比以前嚴重，昨天1天全球有90萬人確診，1萬5000人死亡，日本疫\n情創下新高，韓國現在還在禁止5人以上的集會。台灣雖然做到防疫世界第一，但不能掉\n以輕心。\n\n對於最近的疫情，蘇貞昌表示，1年多下來難免鬆懈，如果房務部主管知道自己會接觸到\n每個房間，可以再有狀況時，早點告訴醫師。第一線的醫師，如果能在看到症狀時多一分\n警覺會更好。\n\n蘇貞昌進一步表示，對於清真寺，集會場所主管如果確實做到實名制、防疫要求，而舞廳\n這種指揮中心要求一定要戴口罩的場所，營業負責人若確實要求民眾戴口罩，保持應有的\n防疫狀況，一定可以做到更好。\n\n對於防疫旅館成溫床一說，蘇貞昌表示，防疫需要全民總動員，指揮中心夜以繼日1年多\n，盡心盡力，難免還是有些場所，有些人員沒有做到位，我們還是多一點鼓勵、加油，也\n呼籲各界多一點警惕小心，這樣一定會做的更好。\n\n蘇貞昌表示，今日視察指揮中心，是為了給指揮中心加油打氣，希望指揮中心進一步要求\n各場所機構、地方政府、中央部會的工作同仁都要提高警覺，也呼籲民眾一定要警覺，如\n今世界疫情比以前嚴峻，不能大意，多一分小心，就能保護自己、保護家人、保護社會。\n\n他也提及，指揮中心一再呼籲大家打疫苗，也放寬了公費對象，希望大家不要因為台灣安\n全就沒有意願。他也特別請指揮官，就打疫苗的幾類人員中，給予合理的放寬，盼提高打\n疫苗的意願，形成鼓勵的作用。\n\n\n5. ():\nhttps://www.chinatimes.com/realtimenews/20210501001353-260405?chdtv
## cmtPoster cmtStatus cmtContent topic gamma
## 1 brianuser → :光頭還沒死啊 3 0.9165764
## 2 NTULioner 噓 :如你媽 3 0.9165764
## 3 Borges → :如果我不是行政院長? 3 0.9165764取出 cmtPoster(回覆者)、artPoster(發文者)、artUrl(文章連結) 三個欄位
link <- posts_Reviews %>% select(cmtPoster, artPoster, artUrl)
head(link,3)## cmtPoster artPoster artUrl
## 1 brianuser hsnugear https://www.ptt.cc/bbs/Gossiping/M.1619836683.A.F72.html
## 2 NTULioner hsnugear https://www.ptt.cc/bbs/Gossiping/M.1619836683.A.F72.html
## 3 Borges hsnugear https://www.ptt.cc/bbs/Gossiping/M.1619836683.A.F72.html基本網路圖
建立網路關係
reviewNetwork <- graph_from_data_frame(d=link, directed=T)
reviewNetwork## IGRAPH 36ba8ce DN-- 26650 226727 --
## + attr: name (v/c), artUrl (e/c)
## + edges from 36ba8ce (vertex names):
## [1] brianuser ->hsnugear NTULioner ->hsnugear Borges ->hsnugear
## [4] kyozwhie ->hsnugear A6 ->hsnugear NTULioner ->hsnugear
## [7] Anvec ->hsnugear ymib ->hsnugear cinther129 ->hsnugear
## [10] soleaching ->hsnugear yangweiisi ->hsnugear Anvec ->hsnugear
## [13] ts01232165 ->hsnugear zxc17893 ->hsnugear A6 ->hsnugear
## [16] ppav0v0v ->hsnugear sugoi5566 ->hsnugear kevinpc ->hsnugear
## [19] shadowdio ->hsnugear shangjay ->hsnugear sunchen0201->hsnugear
## [22] v5270 ->hsnugear live1002 ->hsnugear rustic5566 ->hsnugear
## + ... omitted several edges資料篩選
資料篩選的方式：
- 文章:文章日期、留言數(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,166 x 2
## artPoster count
## <chr> <int>
## 1 iamtony 31
## 2 Pietro 28
## 3 osalucard 26
## 4 EVEA 21
## 5 jason486 19
## 6 chirex 16
## 7 jordanlove 14
## 8 Sinreigensou 14
## 9 B0858B 13
## 10 tontontonni 13
## # ... with 1,156 more rows# 帳號回覆總數
review_count = reviews %>%
group_by(cmtPoster) %>%
summarise(count = n()) %>%
arrange(desc(count))
review_count## # A tibble: 26,304 x 2
## cmtPoster count
## <chr> <int>
## 1 MVPGGYY 598
## 2 aponla 439
## 3 whitenoise 411
## 4 taipoo 377
## 5 Annis812 346
## 6 neoa01 311
## 7 Atkins13 308
## 8 BaRanKa 304
## 9 baboosh 296
## 10 Pietro 295
## # ... with 26,294 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)) # 發文者數量 1162## [1] 1162length(unique(posts_Reviews$cmtPoster)) # 回覆者數量 26304## [1] 26304allPoster <- c(posts_Reviews$artPoster, posts_Reviews$cmtPoster) # 總參與人數 26650
length(unique(allPoster))## [1] 26650標記所有出現過得使用者
- poster：只發過文、發過文+留過言
- replyer：只留過言
userList <- data.frame(user=unique(allPoster)) %>%
mutate(type=ifelse(user%in%posts$artPoster, "poster", "replyer"))
head(userList,3)## user type
## 1 hsnugear poster
## 2 benoaico poster
## 3 tachikoma replyer以日期篩選社群
從前面柱狀圖挑一天主題一和主題四都較高的來做篩選，用5/27來看當天的文章和回覆
link <- posts_Reviews %>%
group_by(cmtPoster, artUrl) %>%
filter(n()>3) %>%
filter(commentNum > 200) %>%
filter(artDate == as.Date('2021-05-27')) %>%
select(cmtPoster, artPoster, artUrl) %>%
unique()
link## # A tibble: 432 x 3
## # Groups: cmtPoster, artUrl [432]
## cmtPoster artPoster artUrl
## <chr> <chr> <chr>
## 1 kauosong sekai https://www.ptt.cc/bbs/Gossiping/M.1622074584.A.7C0.ht~
## 2 sphinx1031 sekai https://www.ptt.cc/bbs/Gossiping/M.1622074584.A.7C0.ht~
## 3 s9234032 sekai https://www.ptt.cc/bbs/Gossiping/M.1622074584.A.7C0.ht~
## 4 vaiking0120 sekai https://www.ptt.cc/bbs/Gossiping/M.1622074584.A.7C0.ht~
## 5 sincere77 sekai https://www.ptt.cc/bbs/Gossiping/M.1622074584.A.7C0.ht~
## 6 grayoasis sekai https://www.ptt.cc/bbs/Gossiping/M.1622074584.A.7C0.ht~
## 7 alan0204 sekai https://www.ptt.cc/bbs/Gossiping/M.1622074584.A.7C0.ht~
## 8 ppnow sekai https://www.ptt.cc/bbs/Gossiping/M.1622074584.A.7C0.ht~
## 9 Howard61313 sekai https://www.ptt.cc/bbs/Gossiping/M.1622074584.A.7C0.ht~
## 10 Crazyfire sekai https://www.ptt.cc/bbs/Gossiping/M.1622074584.A.7C0.ht~
## # ... with 422 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 LeonardoChen replyer
## 2 A80211ab replyer
## 3 s9234032 replyerset.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-27當天的文章， 篩選一篇文章回覆3次以上者，且文章留言數多餘200則， 文章主題歸類為一(疫苗相關討論)與四(執政黨作為的相關討論)者， 欄位只取：cmtPoster(評論者), artPoster(發文者), artUrl(文章連結), topic(主題)
link <- posts_Reviews %>%
group_by(cmtPoster, artUrl) %>%
filter(n()>3) %>%
filter(commentNum > 200) %>%
filter(artDate == as.Date('2021-05-27')) %>%
filter(topic == 1 | topic == 4) %>%
select(cmtPoster, artPoster, artUrl, topic) %>%
unique()
link## # A tibble: 349 x 4
## # Groups: cmtPoster, artUrl [349]
## cmtPoster artPoster artUrl topic
## <chr> <chr> <chr> <int>
## 1 kauosong sekai https://www.ptt.cc/bbs/Gossiping/M.1622074584.A.~ 1
## 2 sphinx1031 sekai https://www.ptt.cc/bbs/Gossiping/M.1622074584.A.~ 1
## 3 s9234032 sekai https://www.ptt.cc/bbs/Gossiping/M.1622074584.A.~ 1
## 4 vaiking0120 sekai https://www.ptt.cc/bbs/Gossiping/M.1622074584.A.~ 1
## 5 sincere77 sekai https://www.ptt.cc/bbs/Gossiping/M.1622074584.A.~ 1
## 6 grayoasis sekai https://www.ptt.cc/bbs/Gossiping/M.1622074584.A.~ 1
## 7 alan0204 sekai https://www.ptt.cc/bbs/Gossiping/M.1622074584.A.~ 1
## 8 ppnow sekai https://www.ptt.cc/bbs/Gossiping/M.1622074584.A.~ 1
## 9 Howard61313 sekai https://www.ptt.cc/bbs/Gossiping/M.1622074584.A.~ 1
## 10 Crazyfire sekai https://www.ptt.cc/bbs/Gossiping/M.1622074584.A.~ 1
## # ... with 339 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 LeonardoChen replyer
## 2 A80211ab replyer
## 3 s9234032 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 == "1", "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(commentNum > 150) %>%
filter(cmtStatus!="→") %>%
group_by(cmtPoster, artUrl) %>%
filter( n() > 3) %>%
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=3,
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.總結
有關民進黨的討論重點有哪些? 主要分為哪幾種風向? 對於22021-05-01 ~ 2021-05-29收集的文章，大概可以分成疫苗相關討論、執政黨作為的相關討論這兩種，其他還有著重討論指揮中心報導或和防疫與疫情討論等四種。討論重點多在於統計「數字」、「公布日期」等案例的計算方式。
目前風向最偏哪邊? 疫苗相關討論可以看得出越來越多網路討論聲量，而執政黨作為的相關討論則是仍舊占比大多數
討論民進黨的社群網路如何分布? 以社群文章數來看，對於執政黨作為的相關討論較多，但從社群網路觀察發現，疫苗相關討論的貼文討論聲量較高。
討論民進黨的意見領袖有誰?網友的推噓狀態如何? 疫苗相關討論為主的意見領袖有 tw689，回覆推噓皆有；執政黨作為的相關討論則有 aletheia。