批踢踢韓國瑜聲量分析
文章推薦指數： 80 %
透過中山管院文字分析平台在批踢踢的HatePolitics看板，搜尋關鍵字：[韓國瑜、韓國 ... A.F4B.html WER0930 ## 2 https://www.ptt.cc/bbs/HatePolitics/M.1556044230.
批踢踢韓國瑜聲量分析
讀書會第二組徐湛、張傳銘、李沂倩、郭睿紘、林益祥、徐建德
系統設置
#Sys.setlocale(category="LC_ALL",locale="zh_TW.UTF-8")#Forubuntu
Sys.setlocale("LC_CTYPE","cht")#Forwindows.
##[1]"Chinese(Traditional)_Taiwan.950"
安裝需要的packages
packages=c("readr","tm","data.table","dplyr","stringr","tidyverse","jiebaR","tidytext","ggplot2","tidyr","topicmodels","LDAvis","webshot","purrr","ramify","RColorBrewer","wordcloud2","htmlwidgets","servr","scales")
existing=as.character(installed.packages()[,1])
for(pkginpackages[!(packages%in%existing)])install.packages(pkg)
library(pacman)
require(readr)
require(tm)
require(data.table)
require(dplyr)
require(stringr)
require(jiebaR)
require(udpipe)
require(tidytext)
require(ggplot2)
require(tidyr)
require(topicmodels)
require(LDAvis)
require(wordcloud2)
require(webshot)
require(htmlwidgets)
require(servr)
require(purrr)
require(ramify)
require(RColorBrewer)
mycolors%as.Date("%Y/%m/%d")
資料描述
2019年4月23日，高雄市市長韓國瑜宣布參選2020總統大選。
透過中山管院文字分析平台在批踢踢的HatePolitics看板，搜尋關鍵字：[韓國瑜、韓國魚、霸韓、韓導、韓總]，時間從2019-04-23~2020-04-22，為期一年的資料，總篇數為23735篇。
資料預覽
fish_hatePolitics%>%
mutate(year=year(artDate),month=month(artDate))%>%
group_by(year,month)%>%
summarise(count=n())%>%
ggplot(aes(x=month,y=count))+
geom_bar(stat="identity")+
facet_grid(~year)
1.可以觀察到資料主要分佈去年5-6月以及12月，今年討論聲量則明顯下降。
2.【聲量高點原因推測】(1)2019年5-6月：韓國瑜剛宣布要參選總統，引發諸如“烙跑市長”、“選上總統，高雄上班”等議題。
(2)2020年12月：鄰近一月中的總統大選，正值“競選活動”與“總統辯論會”的高峰期。
Tokenization
初始化斷詞引擎，並加入停用字
jieba_tokenizer=worker(stop_word="stop_words.txt")
jieba_tokenizer1){
tokens1]
return(tokens)
}
})
}
過濾特殊字元
tokens%
mutate(id=c(1:nrow(fish_hatePolitics)))%>%
unnest_tokens(word,sentence,token=fish_tokenizer)%>%
filter(!str_detect(word,regex("[0-9a-zA-Z]")))
把名稱統一
tokens$word[which(tokens$word==c("韓國魚","韓董","韓導","韓總"))]="韓國瑜"
##Warningintokens$word==c("韓國魚","韓董","韓導","韓總"):較長的物件長度並
##非較短物件長度的倍數
tokens$word[which(tokens$word=="郭董")]="郭台銘"
tokens$word[which(tokens$word==c("柯p","柯P"))]="柯文哲"
##Warningintokens$word==c("柯p","柯P"):較長的物件長度並非較短物件長度的倍數
tokens$word[which(tokens$word=="小英")]="蔡英文"
查看前20筆資料
tokens%>%head(20)
##artTitleartDateartTime
##1[討論]還以為韓總是聰明人2019-04-2310:24:28
##2[討論]還以為韓總是聰明人2019-04-2310:24:28
##3[討論]還以為韓總是聰明人2019-04-2310:24:28
##4[討論]還以為韓總是聰明人2019-04-2310:24:28
##5[討論]還以為韓總是聰明人2019-04-2310:24:28
##6[討論]還以為韓總是聰明人2019-04-2310:24:28
##7[討論]還以為韓總是聰明人2019-04-2310:24:28
##8[討論]還以為韓總是聰明人2019-04-2310:24:28
##9[討論]還以為韓總是聰明人2019-04-2310:24:28
##10[討論]還以為韓總是聰明人2019-04-2310:24:28
##11[討論]還以為韓總是聰明人2019-04-2310:24:28
##12[討論]還以為韓總是聰明人2019-04-2310:24:28
##13[討論]還以為韓總是聰明人2019-04-2310:24:28
##14[討論]還以為韓總是聰明人2019-04-2310:24:28
##15[討論]還以為韓總是聰明人2019-04-2310:24:28
##16[討論]還以為韓總是聰明人2019-04-2310:24:28
##17[討論]還以為韓總是聰明人2019-04-2310:24:28
##18[討論]還以為韓總是聰明人2019-04-2310:24:28
##19[討論]還以為韓總是聰明人2019-04-2310:24:28
##20[討論]還以為韓總是聰明人2019-04-2310:24:28
##artUrlartPoster
##1https://www.ptt.cc/bbs/HatePolitics/M.1556044230.A.F4B.htmlWER0930
##2https://www.ptt.cc/bbs/HatePolitics/M.1556044230.A.F4B.htmlWER0930
##3https://www.ptt.cc/bbs/HatePolitics/M.1556044230.A.F4B.htmlWER0930
##4https://www.ptt.cc/bbs/HatePolitics/M.1556044230.A.F4B.htmlWER0930
##5https://www.ptt.cc/bbs/HatePolitics/M.1556044230.A.F4B.htmlWER0930
##6https://www.ptt.cc/bbs/HatePolitics/M.1556044230.A.F4B.htmlWER0930
##7https://www.ptt.cc/bbs/HatePolitics/M.1556044230.A.F4B.htmlWER0930
##8https://www.ptt.cc/bbs/HatePolitics/M.1556044230.A.F4B.htmlWER0930
##9https://www.ptt.cc/bbs/HatePolitics/M.1556044230.A.F4B.htmlWER0930
##10https://www.ptt.cc/bbs/HatePolitics/M.1556044230.A.F4B.htmlWER0930
##11https://www.ptt.cc/bbs/HatePolitics/M.1556044230.A.F4B.htmlWER0930
##12https://www.ptt.cc/bbs/HatePolitics/M.1556044230.A.F4B.htmlWER0930
##13https://www.ptt.cc/bbs/HatePolitics/M.1556044230.A.F4B.htmlWER0930
##14https://www.ptt.cc/bbs/HatePolitics/M.1556044230.A.F4B.htmlWER0930
##15https://www.ptt.cc/bbs/HatePolitics/M.1556044230.A.F4B.htmlWER0930
##16https://www.ptt.cc/bbs/HatePolitics/M.1556044230.A.F4B.htmlWER0930
##17https://www.ptt.cc/bbs/HatePolitics/M.1556044230.A.F4B.htmlWER0930
##18https://www.ptt.cc/bbs/HatePolitics/M.1556044230.A.F4B.htmlWER0930
##19https://www.ptt.cc/bbs/HatePolitics/M.1556044230.A.F4B.htmlWER0930
##20https://www.ptt.cc/bbs/HatePolitics/M.1556044230.A.F4B.htmlWER0930
##artCatcommentNumpushbooidword
##1HatePolitics841831以為
##2HatePolitics841831韓國瑜
##3HatePolitics841831兵法
##4HatePolitics841831高雄
##5HatePolitics841831這局
##6HatePolitics841831棋中
##7HatePolitics841831力挽狂瀾
##8HatePolitics841831我本
##9HatePolitics841831認為
##10HatePolitics841831要選
##11HatePolitics841831總統
##12HatePolitics841831意思
##13HatePolitics841831最好
##14HatePolitics841831時機
##15HatePolitics841831屁股
##16HatePolitics841831還沒
##17HatePolitics841831坐熱
##18HatePolitics841831豈不是
##19HatePolitics841831朱立倫
##20HatePolitics841831前車之鑑
詞頻
計算所有字在“單一文集”中的總詞頻
word_count%
group_by(id,artTitle,artDate,word)%>%
summarise(count=n())%>%
ungroup()
計算所有字在“所有文集”中的總詞頻
tokens_count%
group_by(word)%>%
summarise(count=sum(count))%>%
arrange(desc(count))
tokens%>%
count(word,sort=TRUE)%>%
top_n(10)%>%
mutate(word=reorder(word,n))%>%
ggplot(aes(word,n))+
geom_col()+
xlab(NULL)+
ylab("出現次數")+
coord_flip()
##Selectingbyn
詞頻文字雲
wordcloud2(tokens_count,size=1)
分析總統大選前後討論內容的差異
總統大選前文字雲
word_count%>%
filter(artDate==as.Date('2020-01-11'))%>%
select(word,count)%>%
group_by(word)%>%
summarise(count=sum(count))%>%
filter(count>20)%>%#過濾出現太少次的字
wordcloud2()
wordcloud
總統大選後文字雲
word_count%>%
filter(artDate==as.Date('2020-01-13'))%>%
select(word,count)%>%
group_by(word)%>%
summarise(count=sum(count))%>%
filter(count>20)%>%#過濾出現太少次的字
wordcloud2()
wordcloud
一月十一日總統大選後，“罷免”字眼成為熱門
罷免聲量
word_count%>%
filter(word=="罷免"|word=="下台"|word=="罷韓"|word=="光復高雄")%>%
ggplot(aes(x=artDate,y=count))+
geom_bar(stat="identity")+
scale_x_date(date_breaks="1month",date_labels="%m/%d")
“罷免”達到巔峰的十個日子
word_count%>%
filter(word=="罷免"|word=="下台"|word=="罷韓"|word=="光復高雄")%>%
group_by(artDate=artDate)%>%
summarise(count=sum(count))%>%
arrange(desc(count))%>%
slice(1:10)
###Atibble:10x2
##artDatecount
##
建立LDA模型
fish_lda
尋找Topic的代表字
top_terms%
group_by(topic)%>%
top_n(10,beta)%>%
ungroup()%>%
arrange(topic,-beta)
top_terms%>%
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()
尋找兩個主題差異最大的詞彙
topics%>%
mutate(topic=paste0("topic",topic))%>%#根據主題名稱重新命名欄位
spread(topic,beta)%>%
filter(topic1>.001|topic2>.001)%>%
mutate(log_ratio=log2(topic2/topic1))%>%
filter(abs(log_ratio)>3.95)%>%
mutate(term=reorder(term,log_ratio))%>%#依據log_ratio值(主題類別)排序詞項
ggplot(aes(log_ratio,term))+
geom_col(show.legend=FALSE)
1.上圖中，左側為主題一，右側為主題二。
2.透過上方的兩張圖，感覺兩個主題看起來差不多，沒有明顯的差異，嘗試看看分多一點topics。
更多主題
嘗試2,5,10,15,25主題數，將結果存起來，再做進一步分析
#ldas=c()
#topics=c(2,5,10,15,25)
#for(topicintopics){
#start_time%
ggplot(aes(k,perplex))+
geom_point()+
geom_line()+
labs(title="EvaluatingLDAtopicmodels",
subtitle="Optimalnumberoftopics(smallerisbetter)",
x="Numberoftopics",
y="Perplexity")
##Warning:`data_frame()`isdeprecated,use`tibble()`.
##Thiswarningisdisplayedoncepersession.
perplexity越小越好，但是太小的話，主題數會分太細。
通常會找一個主題數適當，且perplexity比較低的主題。
因此，在後續分析時，本組將分為“10個”主題。
LDA後續分析
根據前面的探索之後，我們對於資料有更加了解，並且看完每個主題數的LDAvis之後，選定主題數10的結果來作後續的分析查看各個主題的單詞組成比率
fish_lda=ldas[[3]]##選定topic為10的結果
topics
#取出每一個Topic中生成概率最高(beta值最高)的10個詞彙
top_terms%
group_by(topic)%>%
top_n(10,beta)%>%
ungroup()%>%
arrange(topic,-beta)
#繪製長條圖
top_terms%>%
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都被一開始所使用的搜尋關鍵字影響看不出每一群的差異。
移除常出現、跨主題共享的詞彙。
remove_word=c("韓國瑜","高雄","總統","市長","韓粉","國民黨","韓導","韓總","一定","完全","比較","還要","表示","新聞","記者","去年","問題")
top_terms%
filter(!term%in%remove_word)%>%
group_by(topic)%>%
top_n(10,beta)%>%
ungroup()%>%
arrange(topic,-beta)
top_terms%>%
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('造勢活動','韓國瑜V.S.郭台銘','民調：韓V.S.蔡、郭、柯','議會質詢','直播狂熱粉','防疫議題','罷韓議題','黨內大佬立場','網軍黑韓','國際局勢')
Document主題分佈
#foreverydocumentwehaveaprobabilitydistributionofitscontainedtopics
tmResult%
arrange(desc(`民調：韓V.S.蔡、郭、柯`))%>%
head(10)
可以看到“民調：韓V.S.蔡、郭、柯”這個主題主要涵蓋了“韓、蔡、郭、柯的各式民調變動”。
了解主題在時間的變化
fish_topic[,c(11:20)]=sapply(fish_topic[,c(11:20)],as.numeric)
fish_topic%>%
group_by(artDate=format(artDate,"%Y%m"))%>%
summarise_if(is.double,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))
由於我們在今年2月-4月的資料太少，所以將這三個月去除。
去除筆數少月份
fish_topic%>%
group_by(artDate=format(artDate,"%Y%m"))%>%
filter(artDate<202002)%>%
summarise_if(is.double,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))
可以看出每個月的聲量，但是不能很清楚出每個月的比例
以比例了解主題時間變化
fish_topic%>%
group_by(artDate=format(artDate,"%Y%m"))%>%
filter(artDate<202002)%>%
summarise_if(is.double,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))
現在我們可以看到每個月主題的佔比了！
延伸文章資訊
- 1Re: [新聞] 說韓國瑜是草包？鋼鐵韓粉狂列18點打臉- Gossiping
PTT網頁版.
- 2[新聞] 韓國瑜：政府過去一年超前部署了什麼？ - 看板Gossiping
不但沒有道歉還繼續作圖做大內宣韓國瑜一堆可笑的言論是小丑沒錯. ... 韓國瑜就是小丑說說謊,草包,髮夾彎讓大家笑笑而已但是DPP是執政黨, 停電(林飛帆 ...
- 3[黑特] 媽的韓國瑜真的草包- HatePolitics - PTT生活政治八卦
ptt 熱門文章、政治八卦. ... [黑特] 媽的韓國瑜真的草包 ... 不說希望人家直接徵召真的垃圾----- Sent from JPTT on my iPhone -- ※ 發信站: 批...
- 4[討論] 連勝文跟韓國瑜誰比較草包？ | PTT 熱門文章Hito
- 5Re: [討論] 韓國瑜就草包啊- HatePolitics板
我就簡單一個理由給你韓國瑜到目前怎麼打選戰的？ 是跑各個節目、上廣播電台、開直播，瘋狂論述自己的政見與理念，並解答各界的疑問韓國瑜把政見講到 ...
