疫情封城事件
第一組
系統參數設定
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)
library(purrr)資料基本介紹
- 資料來源: 文字平台收集PTT nCov2019/Gossip版文章、回覆
- 資料集： PTT_articleMetaData.csv、PTT_articleReviews.csv
- 關鍵字：封城
- 資料時間：2021-05-01 ~ 2021-05-28
因為疫情越來越嚴重，許多封城的聲音逐漸浮現，所以我們就藉由PTT版上相關的討論進行分析，看看大家對於封城的看法和風向是如何。
1. 資料前處理
在本篇分析中，我們希望建構特定議題的社群網路圖，並分析網路中討論的議題主題
我們需要兩種資料： (1) 每篇文章的主題分類(LDA) (2) 社群網路圖的link和nodes
載入文章和網友回覆資料
posts <- read_csv("../data/PTT_articleMetaData.csv") # 文章 460
reviews <- read_csv("../data/PTT_articleReviews.csv") # 回覆 24533
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-01 01:34:25 https:~ aBianSuck Gossi~ 17 10 1
## 2 [問卦]是否建議桃~ 2021-05-02 03:45:26 https:~ redsoxor~ Gossi~ 17 6 5
## 3 [問卦]台北會封城~ 2021-05-03 03:06:41 https:~ tigotigo Gossi~ 3 0 1
## 4 [問卦]封城前會先~ 2021-05-03 11:43:00 https:~ TCB006 Gossi~ 17 7 4
## 5 [問卦]WHY台灣~ 2021-05-09 12:20:26 https:~ TCB006 Gossi~ 21 2 8
## 6 [問卦]如果封城了~ 2021-05-11 09:00:29 https:~ dean1990 Gossi~ 28 12 4
## # ... 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 01:34:25 https://w~ aBianSuck Gossi~ RandyOrl~ 推
## 2 [問卦]三重封城的~ 2021-05-01 01:34:25 https://w~ aBianSuck Gossi~ wattswat~ 推
## 3 [問卦]三重封城的~ 2021-05-01 01:34:25 https://w~ aBianSuck Gossi~ GOD5566 →
## 4 [問卦]三重封城的~ 2021-05-01 01:34:25 https://w~ aBianSuck Gossi~ AllenHua~ 推
## 5 [問卦]三重封城的~ 2021-05-01 01:34:25 https://w~ aBianSuck Gossi~ kaodio →
## 6 [問卦]三重封城的~ 2021-05-01 01:34:25 https://w~ aBianSuck Gossi~ mapxu664 推
## # ... with 2 more variables: cmtDate <dttm>, cmtContent <chr>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.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")清理斷詞結果
。根據詞頻，選擇只出現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 主題分析
透過perplexity找到最佳主題數
# ldas = c()
# topics = c(2,4,6,10,15)
# for(topic in topics){
# start_time <- Sys.time()
# lda <- LDA(mask_dtm, k = topic, control = list(seed = 2021))
# ldas =c(ldas,lda)
# print(paste(topic ,paste("topic(s) and use time is ", Sys.time() -start_time)))
# save(ldas,file = "ldas_result.rdata") # 將模型輸出成檔案
# }load("ldas_result.rdata")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")## Warning: `data_frame()` was deprecated in tibble 1.1.0.
## Please use `tibble()` instead.
將剛處理好的dtm放入LDA函式分析
# LDA分成4個主題
mask_lda <- LDA(mask_dtm, k = 3, control = list(seed = 15))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)
每篇文章拿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: 460 x 3
## # Groups: document [460]
## document topic gamma
## <chr> <int> <dbl>
## 1 https://www.ptt.cc/bbs/Gossiping/M.1619927128.A.048.html 1 0.518
## 2 https://www.ptt.cc/bbs/Gossiping/M.1620011203.A.F93.html 1 0.509
## 3 https://www.ptt.cc/bbs/Gossiping/M.1620042182.A.5D5.html 1 0.971
## 4 https://www.ptt.cc/bbs/Gossiping/M.1620736198.A.A2A.html 1 0.780
## 5 https://www.ptt.cc/bbs/Gossiping/M.1620789208.A.9F7.html 1 0.997
## 6 https://www.ptt.cc/bbs/Gossiping/M.1620803105.A.25E.html 1 0.977
## 7 https://www.ptt.cc/bbs/Gossiping/M.1620807561.A.7DA.html 1 0.583
## 8 https://www.ptt.cc/bbs/Gossiping/M.1620807753.A.9C3.html 1 0.997
## 9 https://www.ptt.cc/bbs/Gossiping/M.1620808417.A.7A2.html 1 0.989
## 10 https://www.ptt.cc/bbs/Gossiping/M.1620808781.A.FF7.html 1 0.835
## # ... with 450 more rows資料內容探索
posts_topic <- merge(x = posts, y = mask_topics, by.x = "artUrl", by.y="document")
# 看一下各主題在說甚麼
posts_topic %>% # 主題一
filter(topic==1) %>%
select(artTitle) %>%
unique() %>%
sample_n(10)## artTitle
## 1 Re:[問卦]現在不封城是要等到死了一群人才封嗎?
## 2 [問卦]還沒做好封城準備的都在想什麼？
## 3 [問卦]國外的店家封城會希望政府出手嗎
## 4 Re:[新聞]侯友宜說該封城就封柯文哲:別亂喊
## 5 [新聞]侯友宜談疫情最差情況新北市「該封城就
## 6 [問卦]如果台灣要封城要找誰執行？
## 7 [新聞]自動自發封城5月28日解除？柯文哲：不樂
## 8 [問卦]現在封城，台灣還有救。
## 9 [問卦]封城的話，哪些人會哭？哪些人會偷笑？
## 10 [新聞]雙北封城？備戰準四級警戒posts_topic %>% # 主題二
filter(topic==2) %>%
select(artTitle) %>%
unique() %>%
sample_n(10)## artTitle
## 1 Re:[問卦]全國封城兩個月換疫苗
## 2 [問卦]為何雙北不封城比較快?
## 3 [爆卦]疫情惡化新加坡要封城了
## 4 [問卦]墨爾本封城老闆不會抗議?
## 5 [問卦]這禮拜有可能會封城嗎??(發錢)
## 6 Re:[爆卦]疫情惡化新加坡要封城了
## 7 [問卦]封城時突然斷電快熱死，能出去嗎？
## 8 [問卦]豐臣秀吉會宣布封城嗎
## 9 [問卦]有封城的感覺了嗎！
## 10 [問卦]如果接下來要封城，該準備什麼放在家？這次我們把討論焦點放在封城上，從主題分布大概可以看到兩類觀點：
主題一： > 幾乎都是與封城相關的報導，又因為在新北市的疫情相對來說較嚴重，所以篇幅數會較多。
主題二： > 大多是對於如果真的封城後，生活起居與經濟的問題進行討論，也包含一些有點嘲諷味道的文章。
日期主題分布
畫出每天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.1619832867.A.7BC.html
## 2 https://www.ptt.cc/bbs/Gossiping/M.1619832867.A.7BC.html
## 3 https://www.ptt.cc/bbs/Gossiping/M.1619832867.A.7BC.html
## artTitle artDate artTime artPoster artCat commentNum
## 1 [問卦]三重封城的機率大嗎? 2021-05-01 01:34:25 aBianSuck Gossiping 17
## 2 [問卦]三重封城的機率大嗎? 2021-05-01 01:34:25 aBianSuck Gossiping 17
## 3 [問卦]三重封城的機率大嗎? 2021-05-01 01:34:25 aBianSuck Gossiping 17
## push boo
## 1 10 1
## 2 10 1
## 3 10 1
## sentence
## 1 林北朋友住三重 已經寫好遺書\n\n這事件我是估計到5/14 要是沒事\n\n應該可以安全下庄\n\n他是不是過度恐慌了\n\n三重封城的機率大嗎\n\n各位醫科生 怎麼看阿\n
## 2 林北朋友住三重 已經寫好遺書\n\n這事件我是估計到5/14 要是沒事\n\n應該可以安全下庄\n\n他是不是過度恐慌了\n\n三重封城的機率大嗎\n\n各位醫科生 怎麼看阿\n
## 3 林北朋友住三重 已經寫好遺書\n\n這事件我是估計到5/14 要是沒事\n\n應該可以安全下庄\n\n他是不是過度恐慌了\n\n三重封城的機率大嗎\n\n各位醫科生 怎麼看阿\n
## cmtPoster cmtStatus cmtContent topic gamma
## 1 RandyOrlando 推 :早就來不及了 3 0.9575602
## 2 wattswatts 推 :結界封印不是更快。。。 3 0.9575602
## 3 GOD5566 → :南蠻聚集地三重不封假日回南部淪陷 3 0.9575602取出 cmtPoster(回覆者)、artPoster(發文者)、artUrl(文章連結) 三個欄位
link <- posts_Reviews %>% select(cmtPoster, artPoster, artUrl)
head(link,3)## cmtPoster artPoster
## 1 RandyOrlando aBianSuck
## 2 wattswatts aBianSuck
## 3 GOD5566 aBianSuck
## artUrl
## 1 https://www.ptt.cc/bbs/Gossiping/M.1619832867.A.7BC.html
## 2 https://www.ptt.cc/bbs/Gossiping/M.1619832867.A.7BC.html
## 3 https://www.ptt.cc/bbs/Gossiping/M.1619832867.A.7BC.html基本網路圖
建立網路關係
reviewNetwork <- graph_from_data_frame(d=link, directed=T)
reviewNetwork## IGRAPH 2495efd DN-- 9277 24533 --
## + attr: name (v/c), artUrl (e/c)
## + edges from 2495efd (vertex names):
## [1] RandyOrlando->aBianSuck wattswatts ->aBianSuck
## [3] GOD5566 ->aBianSuck AllenHuang ->aBianSuck
## [5] kaodio ->aBianSuck mapxu664 ->aBianSuck
## [7] shjyug ->aBianSuck fakeoldboy ->aBianSuck
## [9] hw1 ->aBianSuck followmeyo ->aBianSuck
## [11] ornv ->aBianSuck ryan0222 ->aBianSuck
## [13] MrUncle ->aBianSuck alexYu ->aBianSuck
## [15] key123987 ->aBianSuck imApig ->aBianSuck
## + ... omitted several edges直接畫的話，因為點沒有經過篩選，看起來會密密麻麻的
# 畫出網路圖(密集恐懼警告)
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`.
# 檢視參與人數
length(unique(posts_Reviews$artPoster)) # 發文者數量 388## [1] 388length(unique(posts_Reviews$cmtPoster)) # 回覆者數量 9068## [1] 9068allPoster <- c(posts_Reviews$artPoster, posts_Reviews$cmtPoster) # 總參與人數 9277
length(unique(allPoster))## [1] 9277標記所有出現過得使用者
- poster：只發過文、發過文+留過言
- replyer：只留過言
userList <- data.frame(user=unique(allPoster)) %>%
mutate(type=ifelse(user%in%posts$artPoster, "poster", "replyer"))
head(userList,3)## user type
## 1 aBianSuck poster
## 2 redsoxortiz poster
## 3 tigotigo poster以留言數篩選社群
篩選出在5/20以後的文章，並篩選一篇文章回覆3次以上者，且文章留言數多於250則
link <- posts_Reviews %>%
group_by(cmtPoster, artUrl) %>%
filter(artDate > as.Date('2020-05-20')) %>%
filter(n()>3) %>%
filter(commentNum > 250) %>%
select(cmtPoster, artPoster, artUrl) %>%
unique()
link## # A tibble: 275 x 3
## # Groups: cmtPoster, artUrl [275]
## cmtPoster artPoster artUrl
## <chr> <chr> <chr>
## 1 smileboy2016 kbten https://www.ptt.cc/bbs/Gossiping/M.1620807753.A.9C3.h~
## 2 LoveMakeLove kbten https://www.ptt.cc/bbs/Gossiping/M.1620807753.A.9C3.h~
## 3 cccwahaha kbten https://www.ptt.cc/bbs/Gossiping/M.1620807753.A.9C3.h~
## 4 panzerbug kbten https://www.ptt.cc/bbs/Gossiping/M.1620807753.A.9C3.h~
## 5 bart102617 kbten https://www.ptt.cc/bbs/Gossiping/M.1620807753.A.9C3.h~
## 6 bryanwang kbten https://www.ptt.cc/bbs/Gossiping/M.1620807753.A.9C3.h~
## 7 linkmusic kbten https://www.ptt.cc/bbs/Gossiping/M.1620807753.A.9C3.h~
## 8 zainc kbten https://www.ptt.cc/bbs/Gossiping/M.1620807753.A.9C3.h~
## 9 hyuchi0202 mormegil https://www.ptt.cc/bbs/Gossiping/M.1621018120.A.C46.h~
## 10 s9234032 mormegil https://www.ptt.cc/bbs/Gossiping/M.1621018120.A.C46.h~
## # ... with 265 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 LoveMakeLove replyer
## 2 LincolnBoy replyer
## 3 ewjfd replyer加上nodes的顯示資訊
用使用者的身份來區分點的顏色
因爲圖片箭頭有點礙眼，所以這裏我們先把關係的方向性拿掉，減少圖片中的不必要的資訊 set.seed 因為igraph呈現的方向是隨機的
- poster:gold(有發文)
- replyer:lightblue(只有回覆文章)
set.seed(487)
reviewNetwork = degree(reviewNetwork) > 2
reviewNetwork <- graph_from_data_frame(d=link, v=filtered_user, directed=F)
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
篩選出在5/20以後的文章，並篩選一篇文章回覆3次以上者，且文章留言數多於250則， 文章主題歸類為1(報導相關)與2(生活與經濟)者， 欄位只取：cmtPoster(評論者), artPoster(發文者), artUrl(文章連結), topic(主題)
link <- posts_Reviews %>%
group_by(cmtPoster, artUrl) %>%
filter(artDate > as.Date('2020-05-20')) %>%
filter(n()>3) %>%
filter(commentNum > 200) %>%
filter(topic == 1 | topic == 2) %>%
select(cmtPoster, artPoster, artUrl, topic) %>%
unique()
link## # A tibble: 237 x 4
## # Groups: cmtPoster, artUrl [237]
## cmtPoster artPoster artUrl topic
## <chr> <chr> <chr> <int>
## 1 smileboy2016 kbten https://www.ptt.cc/bbs/Gossiping/M.1620807753.A~ 1
## 2 LoveMakeLove kbten https://www.ptt.cc/bbs/Gossiping/M.1620807753.A~ 1
## 3 cccwahaha kbten https://www.ptt.cc/bbs/Gossiping/M.1620807753.A~ 1
## 4 panzerbug kbten https://www.ptt.cc/bbs/Gossiping/M.1620807753.A~ 1
## 5 bart102617 kbten https://www.ptt.cc/bbs/Gossiping/M.1620807753.A~ 1
## 6 bryanwang kbten https://www.ptt.cc/bbs/Gossiping/M.1620807753.A~ 1
## 7 linkmusic kbten https://www.ptt.cc/bbs/Gossiping/M.1620807753.A~ 1
## 8 zainc kbten https://www.ptt.cc/bbs/Gossiping/M.1620807753.A~ 1
## 9 papapapapapa uanniy https://www.ptt.cc/bbs/Gossiping/M.1620827445.A~ 1
## 10 mooncatti uanniy https://www.ptt.cc/bbs/Gossiping/M.1620827445.A~ 1
## # ... with 227 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 LoveMakeLove replyer
## 2 LincolnBoy replyer
## 3 ewjfd replyer使用者經常參與的文章種類
filter_degree = 15
# 建立網路關係
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 = 15 # 使用者degree
# 過濾留言者對發文者的推噓程度
link <- posts_Reviews %>%
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.