final_project
第 11 組-糠維軒 李胤豪
2021/05/17
資料收集管道：中山管院文字分析平台
資料來源：PTT 八卦版、武漢肺炎版、政黑板
搜尋關鍵字：疫苗
資料時間：2021-04-18 ～ 2021-06-04
文章數量：11784
研究動機：近期疫情再度爆發，全國進入第三級警戒，疫苗的議題討論量急速上升，因此我們想藉由搜尋ptt疫苗相關的資料來探索現在鄉民們討論的主題，接著再挑選有趣、討論度高的主題進行深入探索。
套件
# library(data.table)
# library(ggplot2)
# library(dplyr)
# library(jiebaR)
# library(tidytext)
# library(stringr)
# library(tm)
# library(servr)
# library(topicmodels)
# library(purrr)
# require(RColorBrewer)
# require(tidyr)
# require(servr)
# library(tidyr)
# library(igraph)
# library(reshape2)
# library(wordcloud2)
# mycolors <- colorRampPalette(brewer.pal(8, "Set3"))(20)資料描述
主要應用資料欄位：
metadata(文章)：artUrl, artDate, artTitle, artPoster, sentence
reviews(留言)：artUrl, cmtStatus, cmtPoster, cmtContent
# # 文章
# metadata <- fread("kl_fp_articleMetaData.csv", encoding = "UTF-8")
# # 留言
# reviews <- fread("kl_fp_articleReviews.csv", encoding = "UTF-8")日期走勢圖
# metadata %>%
# mutate(artDate = as.Date(artDate)) %>%
# group_by(artDate) %>%
# summarise(count = n())%>%
# ggplot(aes(artDate,count))+
# geom_line(color="red")+
# geom_point()
觀察：5月中旬討論量快速上漲
可能原因：5/15 台北宣布進入3級
可能原因：5/24 全國疫情警戒第三級延長
資料前處理
移除PTT貼新聞時會出現的格式用字
# metadata <- metadata %>%
# mutate(sentence=gsub("媒體來源|記者署名|完整新聞標題|完整新聞內文|完整新聞連結|(或短網址)|備註|備註請放最後面|違者新聞文章刪除|張貼問卦請注意|充實文章內容|是否有專板|本板並非萬能問板|一天只能張貼|自刪及被刪也算兩篇之內|超貼者將被水桶|本看板嚴格禁止政治問卦|發文問卦前請先仔細閱讀相關板規|未滿30繁體中文字水桶3個月|嚴重者以鬧板論|完整新聞內容|新聞網址|撰稿者|附註、心得、想法|發稿時間|中央社|台北即時報導|陳婕翎|張茗喧|江慧珺|轉錄網址|轉錄內容|轉錄來源|更新撰稿|記者張茗喧|稿者譯者|新聞來源|請勿討論他板|翻攝自|報導原文連結|陳政偉|更新撰稿|", "", sentence))利用 bigram、trigram、fourgram 來建立斷詞字典
# jieba_tokenizer = worker(user="word.txt",stop_word="stop_words.txt")
# jieba_trigram <- function(t) {
# lapply(t, function(x) {
# if(nchar(x)>1){
# tokens <- segment(x, jieba_tokenizer)
# ngram<- ngrams(unlist(tokens), 4)
# ngram <- lapply(ngram, paste, collapse = " ")
# unlist(ngram)
# }
# })
# }
#
# metadata_trigram <- metadata %>%
# unnest_tokens(ngrams, sentence, token = jieba_trigram) %>%
# #filter((!str_detect(ngrams, regex("[0-9a-zA-Z]"))) | str_detect(ngrams, regex("[Aa][Zz]"))| str_detect(ngrams, regex("[Bb][Nn][Tt]"))) %>%
# filter(!str_detect(ngrams, regex("[0-9a-zァ-ヾ]"))) %>%
# count(ngrams, sort = TRUE)
#
# metadata_trigram使用自建字典及停用字字典
# jieba_tokenizer = worker(user="word.txt",stop_word="stop_words.txt")
# news_tokenizer <- function(t) {
# lapply(t, function(x) {
# if(nchar(x)>1){
# tokens <- segment(x, jieba_tokenizer)
# # 去掉字串長度爲1的詞彙
# tokens <- tokens[nchar(tokens)>1]
# return(tokens)
# }
# })
# }將文章斷詞，同時將數個重要的英文字詞保留下來
# tokens <- metadata %>%
# unnest_tokens(word, sentence, token=news_tokenizer) %>%
# filter((!str_detect(word, regex("[0-9a-zA-Z]"))) | str_detect(word, regex("^[Aa][Zz]$"))
# | str_detect(word, regex("covax"))| str_detect(word, regex("who"))| str_detect(word, regex("biontech"))| str_detect(word, regex("sputnik"))| str_detect(word, regex("mrna"))| str_detect(word, regex("fda"))| str_detect(word, regex("cdc"))| str_detect(word, regex("vaccine"))| str_detect(word, regex("^311$"))| str_detect(word, regex("^[Bb][Nn][Tt]$"))) %>%
# filter(! word %in% c("更新撰稿","撰稿連結","撰稿譯者","完整標題","楊昭彥","楊明珠","發稿單位","中央廣播電台","更新","最新更新")) %>%
# count(artUrl, word) %>%
# rename(count=n)將資料轉換為Document Term Matrix (DTM)
# dtm <- tokens %>% cast_dtm(artUrl, word, count)
# dtm
# inspect(dtm[1:10,1:10])建立LDA模型
嘗試 2、3、4、5、6 個主題數，將結果存起來，再做進一步分析。
# ldas = c()
# topics = c(2,3,4,5,6,8,10)
# for(topic in topics){
# start_time <- Sys.time()
# lda <- LDA(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") # 將模型輸出成檔案
}載入每個主題的LDA結果
# load("ldas_result.rdata")透過perplexity找到最佳主題數
# topics = c(2,3,4,5,6,8,10)
# 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")
## 選定6個主題數的主題模型
# the_lda = ldas[[5]] ## 選定topic 為 6 的結果取出代表字詞(term)
# removed_word = c("疫苗","表示","疫情","台灣","一個","政府","相關","一堆","一定","這種","知道","透過","希望","看到","以下")
#
# # 看各群的常用詞彙
# tidy(the_lda, matrix = "beta") %>% # 取出topic term beta值
# filter(! term %in% removed_word) %>%
# group_by(topic) %>%
# top_n(15, beta) %>% # beta值前15的字
# 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 5:上海復星BNT疫苗相關事件
topic 6:疫苗施打心得_AZ為大宗
取出代表主題(topic)
每篇文章拿gamma值最大的topic當該文章的topic
# 在tidy function中使用參數"gamma"來取得 theta矩陣
# mask_topics <- tidy(the_lda, matrix="gamma") %>% # document topic gamma
# group_by(document) %>%
# top_n(1, wt=gamma)
# mask_topics每一篇的文章分佈
查看特定主題的文章
透過找到特定文章的分佈進行排序之後，可以看到此主題的比重高的文章在討論什麼。
# posts_topic <- merge(x = metadata, y = mask_topics, by.x = "artUrl", by.y="document")
# reviews_topic <- merge(x = reviews, y = mask_topics, by.x = "artUrl", by.y="document")
# 看一下各主題在說甚麼
# set.seed(123)
# posts_topic %>% # 主題一
# filter(topic==1) %>%
# select(artTitle) %>%
# unique() %>%
# sample_n(100)
#
# posts_topic %>% # 主題二
# filter(topic==2) %>%
# select(artTitle) %>%
# unique() %>%
# sample_n(100)
#
# posts_topic %>% # 主題三
# filter(topic==3) %>%
# select(artTitle) %>%
# unique() %>%
# sample_n(100)
#
# posts_topic %>% # 主題四
# filter(topic==4) %>%
# select(artTitle) %>%
# unique() %>%
# sample_n(100)
#
# posts_topic %>% # 主題五
# filter(topic==5) %>%
# select(artTitle) %>%
# unique() %>%
# sample_n(100)
#
# posts_topic %>% # 主題六
# filter(topic==6) %>%
# select(artTitle) %>%
# unique() %>%
# sample_n(500)topic 1:國外:施打狀況以及獎勵制度/國內:政治人物施打以及插隊情況
topic 2:我國政府與民間企業採購疫苗之情況
topic 3:國產疫苗與採購進口疫苗之討論
topic 4:疫苗背後的全球性政治外交鬥爭
topic 5:上海復星BNT疫苗相關事件
topic 6:疫苗施打心得與AZ疫苗相關事件
日期主題分布
# 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="dodge") +
# theme(axis.text.x = element_text(angle = 90, hjust = 1))
> 依比例顯示
# 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") +
# theme(axis.text.x = element_text(angle = 90, hjust = 1))
> 檢視資料來源數量多寡
# posts_topic %>%
# group_by(artCat,topic) %>%
# summarise(sum = n()) %>%
# ggplot(aes(x= artCat,y=sum,fill=as.factor(topic))) +
# geom_col(position="dodge") 
從原先的文章取出 group3 的文章
資料合併
# 文章和留言
# reviews <- reviews %>%
# select(artUrl, cmtPoster, cmtStatus, cmtContent)
# posts_Reviews <- merge(x = metadata, y = reviews, by = "artUrl")
#
# # 把文章和topic
# posts_Reviews <- merge(x = posts_Reviews, y = mask_topics, by.x = "artUrl", by.y="document")
#
# group3_posts_Reviews <- subset(posts_Reviews, topic == 3)取出 cmtPoster(回覆者)、artPoster(發文者)、artUrl(文章連結) 三個欄位
# group3_link <- group3_posts_Reviews %>% select(cmtPoster, artPoster, artUrl)
# head(group3_link,3)基本網路圖
建立網路關係
# reviewNetwork <- graph_from_data_frame(d=group3_link, directed=T)
# reviewNetwork資料篩選
資料篩選的方式：
- 文章:文章日期、留言數(commentNum)
- link、node:degree
# 看一下主題三留言數大概都多少(方便後面篩選)
# group3_posts_Reviews %>%
# ggplot(aes(x=commentNum)) + geom_histogram()
> 依據發文數或回覆數篩選post和review
# # 帳號發文篇數
# post_count = posts_topic %>%
# filter(topic == 3) %>%
# group_by(artPoster) %>%
# summarise(count = n()) %>%
# arrange(desc(count))
#
# # 帳號回覆總數
# review_count = reviews_topic %>%
# filter(topic == 3) %>%
# group_by(cmtPoster) %>%
# summarise(count = n()) %>%
# arrange(desc(count))
#
# # 發文者
# poster_select <- post_count %>% filter(count >= 1)
# posts_topic <- posts_topic %>% filter(posts_topic$artPoster %in% poster_select$artPoster)
#
# # 回覆者
# reviewer_select <- review_count %>% filter(count >= 1)
# reviews_topic <- reviews_topic %>% filter(reviews_topic$cmtPoster %in% reviewer_select$cmtPoster)# # 檢視參與人數
# length(unique(posts_Reviews$artPoster)) # 發文者數量 1143
#
# length(unique(posts_Reviews$cmtPoster)) # 回覆者數量 14856
#
# allPoster <- c(posts_Reviews$artPoster, posts_Reviews$cmtPoster) # 總參與人數 15375
# length(unique(allPoster))標記所有出現過得使用者
- poster：只發過文、發過文+留過言
- replyer：只留過言
# group3_post_topics <- posts_topic %>% filter(topic == 3)
#
# userList <- data.frame(user=unique(allPoster)) %>%
# mutate(type=ifelse(user%in%group3_post_topics$artPoster, "poster", "replyer"))
# head(userList,3)使用者是否受到歡迎
PTT的回覆有三種，推文、噓文、箭頭，我們只要看推噓就好，因此把箭頭清掉。
# filter_degree = 6 # 使用者degree
#
# # 過濾留言者對發文者的推噓程度
# link <- posts_Reviews %>%
# filter(topic == 3) %>%
# filter(commentNum > 250) %>%
# 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", "yellow", "blue")
#
#
# # 依據回覆發生的文章所對應的主題，對他們的關聯線進行上色
# E(reviewNetwork)$color <- ifelse(E(reviewNetwork)$cmtStatus == "推", "green", "red")
#
# # 畫出社群網路圖 #5432
# set.seed(5432)
# plot(reviewNetwork, vertex.size=3.5, edge.width=2, 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("yellow","blue"), pt.cex=1, cex=1)
# legend("topleft", c("推","噓"),
# col=c("green","red"), lty=1, cex=1)
> 大部分都是推文，少數兩三篇文是虛文較多。
關鍵人物文章分析
分析：yoche2000
# group3_posts_Reviews %>%
# filter(artPoster == "yoche2000") %>%
# group_by(artTitle) %>%
# summarise(count = n())貼文：[問卦]如果不得已你會打高端疫苗嗎
日期：5/29
連結：https://www.ptt.cc/bbs/Gossiping/M.1622268451.A.F8B.html
反應：大部分都是噓
爭議：作者做了一份問卷調查想測試大家會不會想打高端疫苗，但問卷的設計方式讓大部分鄉民覺得其問卷在帶風向。
分析：HANDSOMELEO
# group3_posts_Reviews %>%
# filter(artPoster == "HANDSOMELEO") %>%
# group_by(artTitle) %>%
# summarise(count = n())貼文：[爆卦]Sabrina對疫苗的見解幫大家解惑
日期：5/29
連結：https://www.ptt.cc/bbs/Gossiping/M.1622267493.A.852.html
內文：作者先描述自己的高學歷及本科相關經驗，再以支持國產疫苗的觀點撰寫文章
反應：噓爆
爭議：在鄉民調查其背景後，噓的人認為其實質上無專業經驗同時也是民進黨的擁護者(側翼粉專、綠狗自導自演、大內宣)
分析：benjy0218
# group3_posts_Reviews %>%
# filter(artPoster == "benjy0218") %>%
# group_by(artTitle) %>%
# summarise(count = n())貼文：[問卦] 有人能說出國產疫苗的一個好處嗎？
日期：5/28
連結：https://www.ptt.cc/bbs/Gossiping/M.1622151614.A.8AF.html
內文：作者列了5點他認為國產疫苗的壞處，希望大家說說看國產疫苗的好處，一個就好。
反應：多數推少數噓
推：嘴撈股票賺錢
噓：(1)其實同意作者觀點，但不知為什麼要噓(2)覺得作者某個點有問題，予以反擊。
貼文：[爆卦] 指揮官：我們買疫苗都不知道價格？
日期：5/31
連結：https://www.ptt.cc/bbs/Gossiping/M.1622442332.A.863.html
內文：質疑時中買疫苗不知道價格
反應：推噓各半
推：嘴時中
噓：嘴時中
分析：anthony2088
# group3_posts_Reviews %>%
# filter(artPoster == "anthony2088") %>%
# group_by(artTitle) %>%
# summarise(count = n())貼文：[問卦] 進來推一個表示希望上海BNT疫苗進口台灣
日期：5/22
連結：https://www.ptt.cc/bbs/Gossiping/M.1621688555.A.E09.html
內文：作者希望民進黨不要再為了面子及意識形態而不進 BNT 疫苗。
反應：多數推少數噓
推：推，說自己想打 BNT 疫苗。
噓：嘴其他人是五毛帳號。
分析：dogayo
# group3_posts_Reviews %>%
# filter(artPoster == "dogayo") %>%
# group_by(artTitle) %>%
# summarise(count = n())貼文：[爆卦] 柯：高端疫苗一跌停剛好蔡總統就出來開記者會
日期：6/1
連結：https://www.ptt.cc/bbs/Gossiping/M.1622534980.A.E79.html
內文：柯文哲在記者會的談話。
反應：多數推
推：覺得阿伯講話很老實。
貼文：[爆卦] 蔻訊來了！ 疫苗五月底、六月中分批來台
日期：5/18
連結：https://www.ptt.cc/bbs/Gossiping/M.1621305802.A.48C.html
內文：周玉蔻提前洩漏一些疫苗重要消息，股價也隨之起伏。
反應：多數推少數噓
推：(1)好奇周玉蔻有沒有違法(2)謝謝周玉蔻帶他飛。
噓：(1)質疑周玉蔻的合法性
結論
透過LDA分群，我們可以看到ptt疫苗相關的資料被分為以下六個主題：
全球接種疫苗之情況
我國政府與民間企業採購疫苗之情況
支持國產疫苗與支持採購進口疫苗之兩派說法
疫苗背後的全球性政治外交鬥爭
上海復星BNT疫苗相關事件
疫苗施打心得_AZ為大宗
針對第三個主題，我們將其留言擷取出來後畫成社群網路圖，從中我們可以找出幾位與他人互動性較高的帳號，接著我們再實際找出該帳號的發文及底下的留言來觀察發文者與留言者的立場，我們可以發現主要有：
支持國產疫苗方：(1)不想打中國疫苗(二期疫苗、兩岸問題) (2)對台灣生技技術有信心 (3)對美國爸爸有信心
不支持國產疫苗方：(1)認為執政黨將賭注下在台灣生技業 (2)炒股 (3)認為執政黨因兩岸問題不引進 BNT 疫苗
從這幾篇高討論度的文章觀察 -> 不支持國產疫苗的比例較高
補充 - 不同訓練LDA模型套件
參考 http://text2vec.org/topic_modeling.html#latent_dirichlet_allocation
# library(text2vec)
# library(udpipe)
#
# new_tokens <- metadata %>%
# unnest_tokens(word, sentence, token=news_tokenizer) %>%
# filter((!str_detect(word, regex("[0-9a-zA-Zァ-ヾ]"))) | str_detect(word, regex("^[Aa][Zz]$"))
# | str_detect(word, regex("covax"))| str_detect(word, regex("who"))| str_detect(word, regex("biontech"))| str_detect(word, regex("sputnik"))| str_detect(word, regex("mrna"))| str_detect(word, regex("fda"))| str_detect(word, regex("cdc"))| str_detect(word, regex("vaccine"))| str_detect(word, regex("^311$"))| str_detect(word, regex("^[Bb][Nn][Tt]$"))) %>%
# filter(! word %in% c("更新撰稿","撰稿連結","撰稿譯者","完整標題","楊昭彥","楊明珠","發稿單位","中央廣播電台","更新","最新更新"))建立DTM matrix
# dtf <- document_term_frequencies(new_tokens, document = "artUrl", term = "word")
# new_dtm <- document_term_matrix(x = dtf)
# dtm_clean <- dtm_remove_lowfreq(new_dtm, minfreq = 30)
# dim(dtm_clean)LDA 模型
# set.seed(2019)
#
# topic_n = 7
#
# lda_model =text2vec::LDA$new(n_topics = topic_n,doc_topic_prior = 0.1, topic_word_prior = 0.001)
# doc_topic_distr =lda_model$fit_transform(dtm_clean, n_iter = 1000, convergence_tol = 1e-5,check_convergence_every_n = 100)LDAvis
# lda_model$get_top_words(n = 10, lambda = 0.5) ## 查看 前10主題字
# lda_model$plot()
# lda_model$plot(out.dir ="lda_result", open.browser = TRUE)