LDA 主題分析草稿
第15組：龔雪燕、鄭宇翔、鄭子婷、余任濤
2020/06
系統設置
## [1] ""安裝 Packages
packages = c("readr", "tm", "data.table", "dplyr", "stringr", "jiebaR", "tidytext", "ggplot2", "tidyr", "topicmodels", "LDAvis", "igraph","knitr", "webshot", "purrr", "ramify", "RColorBrewer", "htmlwidgets", "servr")
existing = as.character(installed.packages()[,1])
for(pkg in packages[!(packages %in% existing)]) install.packages(pkg)# 載入packages
library(readr)
library(tm)
library(dplyr)
library(jiebaR)
library(tidyr)
library(tidytext)
library(igraph)
library(topicmodels)
library(stringr)
library(ggplot2)
library(knitr)
library(RColorBrewer)
require(data.table)
require(wordcloud2)
mycolors <- colorRampPalette(brewer.pal(8, "Set3"))(20)讀取資料
載入資料
# 文章資料
HongKong <- fread("HongKong_articleMetaData.csv", encoding = "UTF-8")
HongKong$artDate = HongKong$artDate %>% as.Date("%Y/%m/%d") # 將日期欄位格式由chr轉為date
#回覆資料
HongKong_review <- fread("HongKong_articleReviews.csv", encoding = "UTF-8")
# 選取需要的欄位
HongKong_review <- HongKong_review %>%
select(artUrl, cmtPoster, cmtStatus, cmtContent)資料預覽
發文者數量
length(unique(HongKong$artPoster))## [1] 3537回覆者數量
length(unique(HongKong_review$cmtPoster))## [1] 45674總參與人數量
allPoster <- c(HongKong$artPoster, HongKong_review$cmtPoster)
length(unique(allPoster))## [1] 46709整理參與人
# 整理所有出現過的使用者：
# 若曾發過文則標註爲：Poster；不曾發過文則標註爲：Replyer
userList <- data.frame(user = unique(allPoster)) %>%
mutate(type = ifelse(user%in%HongKong$artPoster, "poster", "replyer"))建立網路社群圖
Join文章與回覆
posts_Reviews <- merge(x = HongKong, y = HongKong_review, by = "artUrl")篩選欄位
# 取出 cmtPoster（回覆者）、artPoster（發文者）、artUrl（文章連結）三個欄位
link <- posts_Reviews %>%
select(cmtPoster, artPoster, artUrl)建立網路關係
reviewNetwork <- graph_from_data_frame(d=link, directed=T)資料篩選
由於人數眾多，我們設定一些條件來篩選資料
1. 篩選發文數 > 5：代表發文者是否高度關注該主題並熱於分享
2. 篩選回文數 > 100：代表發文者的文章是否能一定引起共鳴
HongKong_poster = table(HongKong$artPoster) %>% sort %>% as.data.frame
colnames(HongKong_poster) = c("artPoster","freq")
HongKong_poster = HongKong_poster %>% filter(freq >= 5) # 發文次數 > 5
link <- posts_Reviews %>%
filter(commentNum >= 100) %>% # 回覆數 > 100
filter(artPoster==HongKong_poster$artPoster) %>%
select(cmtPoster, artPoster, artUrl) %>%
unique()## Warning in `==.default`(artPoster, HongKong_poster$artPoster): 較長的物件長度並
## 非較短物件長度的倍數## Warning in is.na(e1) | is.na(e2): 較長的物件長度並非較短物件長度的倍數過濾圖中的Vertex
# 篩選 link 中有出現的使用者
filtered_user <- userList %>%
filter(user%in%link$cmtPoster | user%in%link$artPoster) %>%
arrange(desc(type))建立網路關係圖
set.seed(487)
# 先把關係的方向性拿掉，減少圖片中的不必要的資訊
reviewNetwork <- graph_from_data_frame(d=link, v=filtered_user, directed=F)
plot(reviewNetwork, vertex.size=3, edge.arrow.size=.2, vertex.label=NA)
加強圖像的顯示資訊
set.seed(487)
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")
# 顯示超過 5 個關聯的使用者帳號
plot(reviewNetwork, vertex.size = 3, edge.arrow.size=.2,
vertex.label=ifelse(degree(reviewNetwork) > 5, V(reviewNetwork)$label, NA), vertex.label.font = 2)
LDA 主題分析
資料前處理
# 斷句
HongKong_meta <- HongKong %>%
mutate(sentence=gsub("[\n]{2,}", "。", sentence))
# 以全形或半形驚歎號、問號、分號以及全形句號進行斷句
HongKong_sentences <- strsplit(HongKong_meta$sentence,"[。！；？!?;]")
# 將每句句子與他所屬的文章連結配對起來，整理成一個dataframe
HongKong_sentences <- data.frame(
artUrl = rep(HongKong_meta$artUrl, sapply(HongKong_sentences, length)),
sentence = unlist(HongKong_sentences)
) %>%
filter(!str_detect(sentence, regex("^(\t|\n| )*$")))
HongKong_sentences$sentence <- as.character(HongKong_sentences$sentence)
# 斷詞
# 使用斷詞引擎，放入要用的詞典和停用字
jieba_tokenizer = worker(user="HongKong_lexicon.txt", stop_word = "stop_words.txt", write = "NOFILE")
HongKong_tokenizer <- function(t) {
lapply(t, function(x) {
if(nchar(x)>1){
tokens <- segment(x, jieba_tokenizer)
# 去掉字串長度爲1的詞彙
tokens <- tokens[nchar(tokens)>1]
return(tokens)
}
})
}
HongKong_tokens <- HongKong_sentences %>%
unnest_tokens(word, sentence, token = HongKong_tokenizer) %>%
filter(!str_detect(word, regex("[0-9a-zA-Z]"))) %>%
count(artUrl, word, sort = TRUE) %>%
rename(count=n)
# 清理斷詞結果：挑出總出現次數大於3的字
reserved_word <- HongKong_tokens %>%
group_by(word) %>%
count() %>%
filter(n > 3) %>%
unlist()
HongKong_removed <- HongKong_tokens %>%
filter(word %in% reserved_word)
# 將資料轉換為 Document Term Matrix (DTM)
HongKong_dtm <- HongKong_removed %>% cast_dtm(artUrl, word, count)
HongKong_dtm## <<DocumentTermMatrix (documents: 9168, terms: 19924)>>
## Non-/sparse entries: 619333/182043899
## Sparsity : 100%
## Maximal term length: 14
## Weighting : term frequency (tf)主題分析
# LDA分成 10 個主題
#HongKong_lda <- LDA(HongKong_dtm, k = 10, control = list(seed = 1234))
#save(HongKong_lda, file = "HongKong_lda_result")
load("HongKong_lda_result")
# 看各群的常用詞彙
tidy(HongKong_lda, matrix = "beta") %>%
filter(!term %in% c("台灣","中國")) %>%
group_by(topic) %>%
top_n(10, beta) %>%
ungroup() %>%
mutate(topic = as.factor(topic), term = reorder_within(term, beta, topic)) %>%
ggplot(aes(term, beta, fill = topic)) +
geom_col(show.legend = FALSE) +
facet_wrap(~ topic, scales = "free") +
coord_flip() +
scale_x_reordered()
主題命名
topic_name = c("武漢肺炎", "美國法案", "港警鎮壓", "民主自由", "none", "none2", "國安法", "移民", "遊行示威", "香港政府")cbind Document主題分佈
# 主題分布
tmResult <- posterior(HongKong_lda)
doc_pro <- tmResult$topics
dim(doc_pro)## [1] 9168 10# get document topic proportions
document_topics <- doc_pro[HongKong$artUrl,]
document_topics_df =data.frame(document_topics)
colnames(document_topics_df) = topic_name
rownames(document_topics_df) = NULL
news_topic = cbind(HongKong,document_topics_df)主題隨時間的變化
news_topic %>%
dplyr::select(-commentNum,-push,-boo) %>%
group_by(artDate = format(artDate,'%Y%m')) %>%
summarise_if(is.numeric, sum, na.rm = TRUE) %>%
melt(id.vars = "artDate") %>%
ggplot( aes(x=artDate, y=value, fill=variable)) +
geom_bar(stat = "identity") + ylab("value") +
scale_fill_manual(values=mycolors) +
theme(axis.text.x = element_text(angle = 90, hjust = 1))
去除 none 主題和資料較少的月份
news_topic %>%
filter( !format(artDate,'%Y%m') %in% c(201912,202001,202002,202003,202004)) %>%
dplyr::select(-none, -none2, -commentNum, -push, -boo) %>%
group_by(artDate = format(artDate,'%Y%m')) %>%
summarise_if(is.numeric, sum, na.rm = TRUE) %>%
melt(id.vars = "artDate")%>%
ggplot( aes(x=artDate, y=value, fill=variable)) +
geom_bar(stat = "identity") + ylab("value") +
scale_fill_manual(values=mycolors) +
theme(axis.text.x = element_text(angle = 90, hjust = 1))
將上圖以比例方式比較
news_topic %>%
filter( !format(artDate,'%Y%m') %in% c(201912,202001,202002,202003,202004)) %>%
dplyr::select(-none, -none2, -commentNum, -push, -boo) %>%
group_by(artDate = format(artDate,'%Y%m')) %>%
summarise_if(is.numeric, sum, na.rm = TRUE) %>%
melt(id.vars = "artDate")%>%
group_by(artDate) %>%
mutate(total_value =sum(value))%>%
ggplot( aes(x=artDate, y=value/total_value, fill=variable)) +
geom_bar(stat = "identity") + ylab("proportion") +
scale_fill_manual(values=mycolors) +
theme(axis.text.x = element_text(angle = 90, hjust = 1))
根據上圖可以初步得知：
－ 去年7月，警民衝突加劇並發生「元朗事件」，讓「港警鎮壓」、「移民」、「遊行示威」成為主要討論。
－ 去年10月，《禁蒙面法》正式生效且港府允許陳同佳出獄，對於「香港政府」與林鄭月娥的作為成為主要討論。
－ 去年11月，美國參議會通過《香港人權民主法案》，「美國法案」這個主題在此時獲得反送中期間中最多的討論聲量。
－ 去年11月，香港中文大學、理工大學遭港警攻入，「港警鎮壓」這個主題在此時獲得反送中期間中最多的討論聲量。
－ 今年5月，香港《國安法》正式生效，引發香港人恐慌與移民潮，「移民」2字成為香港地區的熱門搜索詞。
LDA 視覺化
# 使用LDA預測每篇文章的主題
HongKong_topics <- tidy(HongKong_lda, matrix = "gamma") %>% # 在tidy function中使用參數"gamma"來取得 theta矩陣。
group_by(document) %>%
top_n(1, wt=gamma)
# 把文章資訊和主題join起來
posts_Reviews_LDA <- merge(x = posts_Reviews, y = HongKong_topics, by.x = "artUrl", by.y = "document")
posts_Reviews_LDA## artUrl
## 1: https://www.ptt.cc/bbs/Gossiping/M.1562883620.A.B88.html
## 2: https://www.ptt.cc/bbs/Gossiping/M.1562883620.A.B88.html
## 3: https://www.ptt.cc/bbs/Gossiping/M.1562883620.A.B88.html
## 4: https://www.ptt.cc/bbs/Gossiping/M.1562883620.A.B88.html
## 5: https://www.ptt.cc/bbs/Gossiping/M.1562883620.A.B88.html
## ---
## 661522: https://www.ptt.cc/bbs/Gossiping/M.1590648394.A.2B5.html
## 661523: https://www.ptt.cc/bbs/Gossiping/M.1590648394.A.2B5.html
## 661524: https://www.ptt.cc/bbs/Gossiping/M.1590648394.A.2B5.html
## 661525: https://www.ptt.cc/bbs/Gossiping/M.1590648394.A.2B5.html
## 661526: https://www.ptt.cc/bbs/Gossiping/M.1590648394.A.2B5.html
## artTitle artDate artTime
## 1: [新聞]寶礦力挺反送中？陸偶像女團GNZ48終止合 2019-07-11 14:14:16
## 2: [新聞]寶礦力挺反送中？陸偶像女團GNZ48終止合 2019-07-11 14:14:16
## 3: [新聞]寶礦力挺反送中？陸偶像女團GNZ48終止合 2019-07-11 14:14:16
## 4: [新聞]寶礦力挺反送中？陸偶像女團GNZ48終止合 2019-07-11 14:14:16
## 5: [新聞]寶礦力挺反送中？陸偶像女團GNZ48終止合 2019-07-11 14:14:16
## ---
## 661522: Re:[新聞]香港女吐心聲「不想移民台灣」！196字淚 2020-05-28 06:46:32
## 661523: Re:[新聞]香港女吐心聲「不想移民台灣」！196字淚 2020-05-28 06:46:32
## 661524: Re:[新聞]香港女吐心聲「不想移民台灣」！196字淚 2020-05-28 06:46:32
## 661525: Re:[新聞]香港女吐心聲「不想移民台灣」！196字淚 2020-05-28 06:46:32
## 661526: Re:[新聞]香港女吐心聲「不想移民台灣」！196字淚 2020-05-28 06:46:32
## artPoster artCat commentNum push boo
## 1: ebsd Gossiping 37 22 2
## 2: ebsd Gossiping 37 22 2
## 3: ebsd Gossiping 37 22 2
## 4: ebsd Gossiping 37 22 2
## 5: ebsd Gossiping 37 22 2
## ---
## 661522: i2taiwan Gossiping 8 0 3
## 661523: i2taiwan Gossiping 8 0 3
## 661524: i2taiwan Gossiping 8 0 3
## 661525: i2taiwan Gossiping 8 0 3
## 661526: i2taiwan Gossiping 8 0 3
## sentence
## 1: 媒體來源:\n聯合\n\n記者署名\n林庭瑤\n\n完整新聞標題:\n寶礦力挺反送中？陸偶像女團GNZ48終止合作\n\n\n\n\n完整新聞內文:\n\n香港反送中在7月1日發生占領香港立法會大樓事件。香港無線電視台TVB因「報導偏向警\n方」而引起社會爭議。傳日本飲料商寶礦力水特從TVB撤除了所有廣告。對此，梁振英發\n聲批評寶礦力水特公司，中國大陸流行樂偶像女子團體GNZ48也宣布終止與寶礦力水特公\n司的全部合作。\n\n據觀察者網和星島日報綜合報導，大陸全國政協副主席、前特首梁振英評論稱，「寶礦力\n黑白不分，我呼籲全國消費者，全面抵制寶礦力。」\n\n中國大陸女團GNZ48隨即在昨天（10日）下午宣布終止與寶礦力的合作。\n\n寶礦力水特昨晚在臉書發表聲明，稱對7月9日的回應引來的不便真誠道歉，但無明確提及\n是否撤回廣告。網上流傳截圖顯示，寶礦力水特的專頁回覆客戶查詢稱，鑑於當前形勢，\n上周已決定撤回廣告。\n\n環球網就該截圖聯繫到了大塚製藥日本本部，負責公關事務的一位女士表示，撤回廣告的\n決定，完全由香港大塚製藥基於商業原因自行做出，不摻雜政治因素，日本總部未給予任\n何指示。至於撤銷廣告為暫時性撤銷還是永久性，她稱目前尚未做出決定。\n\n\n完整新聞連結 (或短網址):\nhttps://udn.com/news/story/7331/3922328\n備註:\n
## 2: 媒體來源:\n聯合\n\n記者署名\n林庭瑤\n\n完整新聞標題:\n寶礦力挺反送中？陸偶像女團GNZ48終止合作\n\n\n\n\n完整新聞內文:\n\n香港反送中在7月1日發生占領香港立法會大樓事件。香港無線電視台TVB因「報導偏向警\n方」而引起社會爭議。傳日本飲料商寶礦力水特從TVB撤除了所有廣告。對此，梁振英發\n聲批評寶礦力水特公司，中國大陸流行樂偶像女子團體GNZ48也宣布終止與寶礦力水特公\n司的全部合作。\n\n據觀察者網和星島日報綜合報導，大陸全國政協副主席、前特首梁振英評論稱，「寶礦力\n黑白不分，我呼籲全國消費者，全面抵制寶礦力。」\n\n中國大陸女團GNZ48隨即在昨天（10日）下午宣布終止與寶礦力的合作。\n\n寶礦力水特昨晚在臉書發表聲明，稱對7月9日的回應引來的不便真誠道歉，但無明確提及\n是否撤回廣告。網上流傳截圖顯示，寶礦力水特的專頁回覆客戶查詢稱，鑑於當前形勢，\n上周已決定撤回廣告。\n\n環球網就該截圖聯繫到了大塚製藥日本本部，負責公關事務的一位女士表示，撤回廣告的\n決定，完全由香港大塚製藥基於商業原因自行做出，不摻雜政治因素，日本總部未給予任\n何指示。至於撤銷廣告為暫時性撤銷還是永久性，她稱目前尚未做出決定。\n\n\n完整新聞連結 (或短網址):\nhttps://udn.com/news/story/7331/3922328\n備註:\n
## 3: 媒體來源:\n聯合\n\n記者署名\n林庭瑤\n\n完整新聞標題:\n寶礦力挺反送中？陸偶像女團GNZ48終止合作\n\n\n\n\n完整新聞內文:\n\n香港反送中在7月1日發生占領香港立法會大樓事件。香港無線電視台TVB因「報導偏向警\n方」而引起社會爭議。傳日本飲料商寶礦力水特從TVB撤除了所有廣告。對此，梁振英發\n聲批評寶礦力水特公司，中國大陸流行樂偶像女子團體GNZ48也宣布終止與寶礦力水特公\n司的全部合作。\n\n據觀察者網和星島日報綜合報導，大陸全國政協副主席、前特首梁振英評論稱，「寶礦力\n黑白不分，我呼籲全國消費者，全面抵制寶礦力。」\n\n中國大陸女團GNZ48隨即在昨天（10日）下午宣布終止與寶礦力的合作。\n\n寶礦力水特昨晚在臉書發表聲明，稱對7月9日的回應引來的不便真誠道歉，但無明確提及\n是否撤回廣告。網上流傳截圖顯示，寶礦力水特的專頁回覆客戶查詢稱，鑑於當前形勢，\n上周已決定撤回廣告。\n\n環球網就該截圖聯繫到了大塚製藥日本本部，負責公關事務的一位女士表示，撤回廣告的\n決定，完全由香港大塚製藥基於商業原因自行做出，不摻雜政治因素，日本總部未給予任\n何指示。至於撤銷廣告為暫時性撤銷還是永久性，她稱目前尚未做出決定。\n\n\n完整新聞連結 (或短網址):\nhttps://udn.com/news/story/7331/3922328\n備註:\n
## 4: 媒體來源:\n聯合\n\n記者署名\n林庭瑤\n\n完整新聞標題:\n寶礦力挺反送中？陸偶像女團GNZ48終止合作\n\n\n\n\n完整新聞內文:\n\n香港反送中在7月1日發生占領香港立法會大樓事件。香港無線電視台TVB因「報導偏向警\n方」而引起社會爭議。傳日本飲料商寶礦力水特從TVB撤除了所有廣告。對此，梁振英發\n聲批評寶礦力水特公司，中國大陸流行樂偶像女子團體GNZ48也宣布終止與寶礦力水特公\n司的全部合作。\n\n據觀察者網和星島日報綜合報導，大陸全國政協副主席、前特首梁振英評論稱，「寶礦力\n黑白不分，我呼籲全國消費者，全面抵制寶礦力。」\n\n中國大陸女團GNZ48隨即在昨天（10日）下午宣布終止與寶礦力的合作。\n\n寶礦力水特昨晚在臉書發表聲明，稱對7月9日的回應引來的不便真誠道歉，但無明確提及\n是否撤回廣告。網上流傳截圖顯示，寶礦力水特的專頁回覆客戶查詢稱，鑑於當前形勢，\n上周已決定撤回廣告。\n\n環球網就該截圖聯繫到了大塚製藥日本本部，負責公關事務的一位女士表示，撤回廣告的\n決定，完全由香港大塚製藥基於商業原因自行做出，不摻雜政治因素，日本總部未給予任\n何指示。至於撤銷廣告為暫時性撤銷還是永久性，她稱目前尚未做出決定。\n\n\n完整新聞連結 (或短網址):\nhttps://udn.com/news/story/7331/3922328\n備註:\n
## 5: 媒體來源:\n聯合\n\n記者署名\n林庭瑤\n\n完整新聞標題:\n寶礦力挺反送中？陸偶像女團GNZ48終止合作\n\n\n\n\n完整新聞內文:\n\n香港反送中在7月1日發生占領香港立法會大樓事件。香港無線電視台TVB因「報導偏向警\n方」而引起社會爭議。傳日本飲料商寶礦力水特從TVB撤除了所有廣告。對此，梁振英發\n聲批評寶礦力水特公司，中國大陸流行樂偶像女子團體GNZ48也宣布終止與寶礦力水特公\n司的全部合作。\n\n據觀察者網和星島日報綜合報導，大陸全國政協副主席、前特首梁振英評論稱，「寶礦力\n黑白不分，我呼籲全國消費者，全面抵制寶礦力。」\n\n中國大陸女團GNZ48隨即在昨天（10日）下午宣布終止與寶礦力的合作。\n\n寶礦力水特昨晚在臉書發表聲明，稱對7月9日的回應引來的不便真誠道歉，但無明確提及\n是否撤回廣告。網上流傳截圖顯示，寶礦力水特的專頁回覆客戶查詢稱，鑑於當前形勢，\n上周已決定撤回廣告。\n\n環球網就該截圖聯繫到了大塚製藥日本本部，負責公關事務的一位女士表示，撤回廣告的\n決定，完全由香港大塚製藥基於商業原因自行做出，不摻雜政治因素，日本總部未給予任\n何指示。至於撤銷廣告為暫時性撤銷還是永久性，她稱目前尚未做出決定。\n\n\n完整新聞連結 (或短網址):\nhttps://udn.com/news/story/7331/3922328\n備註:\n
## ---
## 661522: 哈哈哈哈哈哈哈哈哈\n港女不愧是港女\n不要把台灣跟香港混為一談\n香港已經回歸中國\n你們就是中國香港人\n我們這邊是台灣\n台灣歡迎友善的港人移民台灣\n慢走不送啊
## 661523: 哈哈哈哈哈哈哈哈哈\n港女不愧是港女\n不要把台灣跟香港混為一談\n香港已經回歸中國\n你們就是中國香港人\n我們這邊是台灣\n台灣歡迎友善的港人移民台灣\n慢走不送啊
## 661524: 哈哈哈哈哈哈哈哈哈\n港女不愧是港女\n不要把台灣跟香港混為一談\n香港已經回歸中國\n你們就是中國香港人\n我們這邊是台灣\n台灣歡迎友善的港人移民台灣\n慢走不送啊
## 661525: 哈哈哈哈哈哈哈哈哈\n港女不愧是港女\n不要把台灣跟香港混為一談\n香港已經回歸中國\n你們就是中國香港人\n我們這邊是台灣\n台灣歡迎友善的港人移民台灣\n慢走不送啊
## 661526: 哈哈哈哈哈哈哈哈哈\n港女不愧是港女\n不要把台灣跟香港混為一談\n香港已經回歸中國\n你們就是中國香港人\n我們這邊是台灣\n台灣歡迎友善的港人移民台灣\n慢走不送啊
## cmtPoster cmtStatus cmtContent topic
## 1: BOOS0103 推 :賀，終止的好！差點就玷汙歷年寶礦力女 4
## 2: BOOS0103 → :神。 4
## 3: BOOS0103 → :拜託寶礦力廣告不要用支那女 4
## 4: RLAPH 推 :攘夷志士最愛的飲料 4
## 5: AUwalker 推 :幸好你們出來終止不然真的沒聽過廣州48 4
## ---
## 661522: Anvec → :如果不能真的拿到實質的利益只是嘴巴上挺 8
## 661523: Anvec → :那今日的香港就是明日的台灣 8
## 661524: Void956 噓 :偽裝真差一看就知道是支那人 8
## 661525: Anvec → :是可以被交易的 8
## 661526: leophior 噓 :你說不會推文哦？ 8
## gamma
## 1: 0.3567502
## 2: 0.3567502
## 3: 0.3567502
## 4: 0.3567502
## 5: 0.3567502
## ---
## 661522: 0.6820008
## 661523: 0.6820008
## 661524: 0.6820008
## 661525: 0.6820008
## 661526: 0.6820008元朗事件
# 篩選條件：
# 1. 2019/07/01至2019/10/01的文章
# 2. 有在10篇以上文章回覆者，
# 3. 文章主題歸類為3與9者，
# 4. 欄位只取：cmtPoster(評論者), artPoster(發文者), artUrl(文章連結), topic(主題)
link <- posts_Reviews_LDA %>%
filter(artDate > as.Date('2019-07-01')) %>%
filter(artDate < as.Date('2019-10-01')) %>%
group_by(cmtPoster, artUrl) %>%
filter(n()>10) %>%
ungroup() %>%
filter(topic == 3 | topic == 9) %>%
select(cmtPoster, artPoster, artUrl, topic) %>%
unique()
link## # A tibble: 130 x 4
## cmtPoster artPoster artUrl topic
## <chr> <chr> <chr> <int>
## 1 daemonshadow Barcarolle https://www.ptt.cc/bbs/Gossiping/M.1563102674.~ 9
## 2 Strokes LWong https://www.ptt.cc/bbs/Gossiping/M.1563144183.~ 3
## 3 hTCU11 LWong https://www.ptt.cc/bbs/Gossiping/M.1563144183.~ 3
## 4 mudee sakaba https://www.ptt.cc/bbs/Gossiping/M.1563279461.~ 9
## 5 armorblocks Retangle https://www.ptt.cc/bbs/Gossiping/M.1563721157.~ 3
## 6 ymuit Retangle https://www.ptt.cc/bbs/Gossiping/M.1563721157.~ 3
## 7 lost0816 Rossini https://www.ptt.cc/bbs/Gossiping/M.1563733562.~ 3
## 8 mudee Rossini https://www.ptt.cc/bbs/Gossiping/M.1563733562.~ 3
## 9 winnie759281 okah https://www.ptt.cc/bbs/Gossiping/M.1563775744.~ 3
## 10 myyalga Moogle https://www.ptt.cc/bbs/Gossiping/M.1563780974.~ 3
## # ... with 120 more rows# 篩選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)$topic == "3", "coral3", "cyan3")
# 畫出社群網路圖
set.seed(5000)
plot(reviewNetwork, vertex.size=6, edge.arrow.size=.2, edge.width=2,
vertex.label=ifelse(degree(reviewNetwork) > 5, V(reviewNetwork)$label, NA),vertex.label.font=2)
# 加入標示
legend("bottomright", c("發文者","回文者"), pch=21, col="#777777", pt.bg=c("gold","lightblue"), pt.cex=1, cex=1)
legend("topleft", c("港警鎮壓", "遊行示威"), col=c("coral3","cyan3"), lty=1, cex=1)
禁蒙面法
# 篩選條件：
# 1. 2019/10/01至2020/01/01的文章
# 2. 有在10篇以上文章回覆者，
# 3. 文章主題歸類為8與10者，
# 4. 欄位只取：cmtPoster(評論者), artPoster(發文者), artUrl(文章連結), topic(主題)
link <- posts_Reviews_LDA %>%
filter(artDate > as.Date('2019-10-01')) %>%
filter(artDate < as.Date('2020-01-01')) %>%
group_by(cmtPoster, artUrl) %>%
filter(n()>10) %>%
ungroup() %>%
filter(topic == 8 | topic == 10) %>%
select(cmtPoster, artPoster, artUrl, topic) %>%
unique()
link## # A tibble: 404 x 4
## cmtPoster artPoster artUrl topic
## <chr> <chr> <chr> <int>
## 1 EeePC901 Diaw19 https://www.ptt.cc/bbs/Gossiping/M.1570072730.A~ 8
## 2 kbten Diaw19 https://www.ptt.cc/bbs/Gossiping/M.1570072730.A~ 8
## 3 phoinixa Diaw19 https://www.ptt.cc/bbs/Gossiping/M.1570072730.A~ 8
## 4 lasekoutkast Diaw19 https://www.ptt.cc/bbs/Gossiping/M.1570072730.A~ 8
## 5 slimfat0202 Diaw19 https://www.ptt.cc/bbs/Gossiping/M.1570072730.A~ 8
## 6 happybad Diaw19 https://www.ptt.cc/bbs/Gossiping/M.1570072730.A~ 8
## 7 offstage Diaw19 https://www.ptt.cc/bbs/Gossiping/M.1570072730.A~ 8
## 8 mukuro Diaw19 https://www.ptt.cc/bbs/Gossiping/M.1570072730.A~ 8
## 9 ahaha777 Diaw19 https://www.ptt.cc/bbs/Gossiping/M.1570072730.A~ 8
## 10 neverfly ununnihao https://www.ptt.cc/bbs/Gossiping/M.1570076993.A~ 8
## # ... with 394 more rows# 篩選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)$topic == "8", "coral3", "cyan3")
# 畫出社群網路圖
set.seed(5000)
plot(reviewNetwork, vertex.size=6, edge.arrow.size=.2, edge.width=2,
vertex.label=ifelse(degree(reviewNetwork) > 15, 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("coral3","cyan3"), lty=1, cex=1)
國安法
# 篩選條件：
# 1. 2020/05/01後的文章
# 2. 有在10篇以上文章回覆者，
# 3. 文章主題歸類為7與8者，
# 4. 欄位只取：cmtPoster(評論者), artPoster(發文者), artUrl(文章連結), topic(主題)
link <- posts_Reviews_LDA %>%
filter(artDate > as.Date('2020-05-01')) %>%
group_by(cmtPoster, artUrl) %>%
filter(n()>10) %>%
ungroup() %>%
filter(topic == 7 | topic == 8) %>%
select(cmtPoster, artPoster, artUrl, topic) %>%
unique()
link## # A tibble: 139 x 4
## cmtPoster artPoster artUrl topic
## <chr> <chr> <chr> <int>
## 1 slimfat0202 blue999 https://www.ptt.cc/bbs/Gossiping/M.1589985536~ 8
## 2 gordan123 blue999 https://www.ptt.cc/bbs/Gossiping/M.1589985536~ 8
## 3 gaddafi blue999 https://www.ptt.cc/bbs/Gossiping/M.1589985536~ 8
## 4 edc3 blue999 https://www.ptt.cc/bbs/Gossiping/M.1589985536~ 8
## 5 KillerMoDo alicevvn https://www.ptt.cc/bbs/Gossiping/M.1590007049~ 8
## 6 fleetindark alicevvn https://www.ptt.cc/bbs/Gossiping/M.1590007049~ 8
## 7 watashiD DengXiaoPing https://www.ptt.cc/bbs/Gossiping/M.1590072754~ 8
## 8 KillerMoDo DengXiaoPing https://www.ptt.cc/bbs/Gossiping/M.1590072754~ 8
## 9 kinmengon DengXiaoPing https://www.ptt.cc/bbs/Gossiping/M.1590072754~ 8
## 10 aaronfv DengXiaoPing https://www.ptt.cc/bbs/Gossiping/M.1590072754~ 8
## # ... with 129 more rows# 篩選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)$topic == "7", "coral3", "cyan3")
# 畫出社群網路圖
set.seed(5000)
plot(reviewNetwork, vertex.size=6, edge.arrow.size=.2, edge.width=2,
vertex.label=ifelse(degree(reviewNetwork) > 5, V(reviewNetwork)$label, NA),vertex.label.font=2)
# 加入標示
legend("bottomright", c("發文者","回文者"), pch=21, col="#777777", pt.bg=c("gold","lightblue"), pt.cex=1, cex=1)
legend("topleft", c("國安法", "移民"), col=c("coral3","cyan3"), lty=1, cex=1)
推噓文
# 把回覆類型為箭頭的回覆移除
link <- posts_Reviews %>%
filter(cmtStatus!="→") %>%
group_by(cmtPoster, artUrl) %>%
filter(n()>12) %>%
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(487)
plot(reviewNetwork, vertex.size=5, edge.arrow.size=.2, edge.width=3,
vertex.label=ifelse(degree(reviewNetwork) > 3, 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)