社群媒體分析期末報告第十九組-探討ptt八卦板對台灣停電事件的看法

主題

分析PTT八卦版對台灣513停電事件的文字資料和社會網絡資料

一、動機與分析目的

• 背景與動機
  • 五月初臺灣疫情受到華航機師與諾福特酒店事件影響，疫情開始蔓延，加上久旱未雨，各地區面臨了缺水的窘況，就在這疫情與旱象夾擊下的臺灣，5月13日受興達電廠跳機的影響造成全台分區停電、限電的事件。針對這個事件網路媒體是如何看待、是意外事件還是能源政策造成的？
• 研究目的
  1. 台灣513停電的討論重點有哪些? 主要分為哪幾種風向?。
     
  2. 目前風向最偏哪邊?
     
  3. 討論513停電的社群網路如何分布?
     
  4. 513停電的意見領袖有誰?網友的推噓狀態如何?
     

1.資料集描述

• 資料來源：中山大學管理學院文字分析平台收集PTT八卦版文章取得之原始csv檔案。
• 資料集：PPT八卦版。
• 資料日期區間：2021.05.13~2021.05.18。
• 資料的關鍵字:檢索「停電」、「缺電」、「興達」、「電廠」、「興達電廠」五個關鍵字，共搜尋出1113篇文章。

二、前置作業

Sys.setlocale(category = "LC_ALL", locale = "zh_TW.UTF-8") # 避免中文亂碼

[1] ""

安裝需要的packages

packages = c("readr", "dplyr", "jiebaR", "tidyr", "tidytext", "igraph", "topicmodels", "ggplot2", "stringr","text2vec")
existing = as.character(installed.packages()[,1])
for(pkg in packages[!(packages %in% existing)]) install.packages(pkg)

將require及library載入

library(readr)
library(dplyr)
library(jiebaR)
library(tidyr)
library(tidytext)
library(igraph)
library(topicmodels)
library(stringr)
library(ggplot2)
library(reshape2)
library(wordcloud2)
require(text2vec)

載入自平台下載下來的資料

posts <- read_csv("0612-1_articleMetaData.csv") 
reviews <- read_csv("0612-1_articleReviews.csv") 
rd <- read_csv("0612-1_artWordPOSFreq.csv")

資料處理

data <- rd %>% 
  dplyr::select(artDate, artUrl) %>% 
  distinct()
article_count_by_date <- data %>% 
  group_by(artDate) %>% 
  summarise(count = n())
head(article_count_by_date, 20)

文章斷句

# # 文章斷句("\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

文章斷詞

# 加入自定義的字典
jieba_tokenizer <- worker(user="user_dict.txt", stop_word = "stop_words.txt")

# 設定斷詞function
chi_tokenizer <- function(t) {
  lapply(t, function(x) {
    if(nchar(x)>1){
      tokens <- segment(x, jieba_tokenizer)
      # 去掉字串長度爲1的詞彙
      tokens <- tokens[nchar(tokens)>1]
      return(tokens)
    }
  })
}

rd_tokens_all <- posts %>%
  unnest_tokens(word, sentence, token=chi_tokenizer) %>% 
  select(-artTime)

# # 用剛剛初始化的斷詞器把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")

清理斷詞結果

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) 

三、折線圖

1.台灣大停電事件在PTT八卦5/13~5/18各時段的文章討論數量變化

posts %>% 
  mutate(artDate = as.Date(artDate)) %>%
  group_by(artDate) %>%
  summarise(count = n())%>%
  ggplot(aes(artDate,count))+
    geom_line(color="red")+
    geom_point()

四、文字雲

data <- rd %>% 
  group_by(word) %>% 
  summarise(sum = sum(count), .groups = 'drop') %>% 
  arrange(desc(sum))

data %>% filter(sum > 50) %>% wordcloud2()

五、LDA 主題分類

1.LDA 主題分析

嘗試2、4、6、10、15個主題數，將結果存起來，再做進一步分析。

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") # 將模型輸出成檔案
}

[1] "2 topic(s) and use time is  2.0354688167572"
[1] "4 topic(s) and use time is  7.28165197372437"
[1] "6 topic(s) and use time is  16.9567279815674"
[1] "10 topic(s) and use time is  27.2636518478394"
[1] "15 topic(s) and use time is  51.1909809112549"

透過perplexity找到最佳主題數

library(purrr)

Attaching package: 愼㸱愼㸵purrr愼㸱愼㸶

The following objects are masked from 愼㸱愼㸵package:igraph愼㸱愼㸶:

    compose, simplify

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")

`data_frame()` was deprecated in tibble 1.1.0.
Please use `tibble()` instead.

• 主題數越多，複雜度越低，內容的純度越高。
• 可以挑選下降幅度減緩的點。

2.LDAvis 六個主題

library(udpipe)
dtf <- document_term_frequencies(tokens, document = "artUrl", term = "word")
dtm <- document_term_matrix(x = dtf)
dtm_clean <- dtm_remove_lowfreq(dtm, minfreq = 30)
dim(dtm_clean)
set.seed(5432)

topic_n = 6

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)
lda_model$get_top_words(n = 10, lambda = 0.5)
lda_model$plot()
lda_model$plot(out.dir ="lda_result", open.browser = TRUE)

將剛處理好的dtm放入LDA函式分析

# LDA分成6個主題
mask_lda <- LDA(mask_dtm, k = 6, control = list(seed = 12345))
#  mask_lda <- LDA(mask_dtm, k = 6, control = list(seed = 12345))

取出代表字詞(term)

removed_word = c("一下","不是","停電","有沒有","電廠") 
# 看各群的常用詞彙
tidy(mask_lda, matrix = "beta") %>% # 取出topic term beta值
  filter(! term %in% removed_word) %>% 
  group_by(topic) %>%
  top_n(13, 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 5 = “討論政府的能源政策”
topic 6 = “討論分區停電”
以下我們挑出第1個主題、第3個主題和第4個主題來做比較。

取出代表主題(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

3.資料內容探索

posts_topic <- merge(x = posts, y = mask_topics, by.x = "artUrl", by.y="document")

# 看一下各主題在說甚麼
set.seed(12345)
posts_topic %>% # 主題一
  filter(topic==1) %>%
  select(artTitle) %>%
  unique() %>%
  sample_n(12)

posts_topic %>% # 主題二
  filter(topic==2) %>%
  select(artTitle) %>%
  unique() %>%
  sample_n(12)

posts_topic %>% # 主題三
  filter(topic==3) %>%
  select(artTitle) %>%
  unique() %>%
  sample_n(12)

posts_topic %>% # 主題四
  filter(topic==4) %>%
  select(artTitle) %>%
  unique() %>%
  sample_n(12)

posts_topic %>% # 主題五
  filter(topic==5) %>%
  select(artTitle) %>%
  unique() %>%
  sample_n(12)

posts_topic %>% # 主題六
  filter(topic==6) %>%
  select(artTitle) %>%
  unique() %>%
  sample_n(12)

4.日期主題分布

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.

topic 1 = “討論為何停電”
topic 2 = “各家新聞報導內容”
topic 3 = “抱怨停電”
topic 4 = “討論政府針對缺水、疫情、缺電的政策”
topic 5 = “討論政府的能源政策”
topic 6 = “討論分區停電”

六、社群網路圖

資料合併

# 文章和留言
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)

取出 cmtPoster(回覆者)、artPoster(發文者)、artUrl(文章連結) 三個欄位

link <- posts_Reviews %>% select(cmtPoster, artPoster, artUrl)
head(link,3)

1.基本網路圖

建立網路關係

reviewNetwork <- graph_from_data_frame(d=link, directed=T)
reviewNetwork

IGRAPH 342d22d DN-- 165 184 -- 
+ attr: name (v/c), artUrl (e/c), cmtStatus (e/c)
+ edges from 342d22d (vertex names):
 [1] Annis812    ->thelittleone pttyu       ->GoogleTaiwan a0952864901 ->lolic        onejune     ->lolic        w1230319    ->lolic        bangjia     ->lolic       
 [7] garyyang36  ->lolic        Annis812    ->lolic        garyyang36  ->lolic        Paulsic     ->lolic        shidaeun    ->lolic        Aonian      ->lolic       
[13] catvsdog    ->lolic        catvsdog    ->lolic        zanarland   ->lolic        Aonian      ->lolic        S0031104    ->lolic        S0031104    ->lolic       
[19] aiam        ->dark45662    aiam        ->dark45662    lml99       ->Gunbuster    ffruecek    ->Gunbuster    aikensh     ->Gunbuster    baboosh     ->Gunbuster   
[25] rainbow321  ->Gunbuster    lml99       ->Gunbuster    baboosh     ->Gunbuster    nicky51     ->Gunbuster    HGT7473     ->Gunbuster    baseken     ->Gunbuster   
[31] LukeSkywaker->Minegun      TZUYIC      ->Minegun      howerd11    ->Minegun      howerd11    ->Minegun      other9343   ->Minegun      CruiseTom   ->Minegun     
[37] tokuchi2013 ->Minegun      tokuchi2013 ->Minegun      danwhei     ->kenbo        Senga41     ->kenbo        lml99       ->kenbo        ray88076    ->kenbo       
[43] a8330028    ->kenbo        Senga41     ->kenbo        a8330028    ->kenbo        GhostFather ->currykukuo   mi324       ->currykukuo   EdenEden    ->Aliensoul   
+ ... omitted several edges

2.文章留言數

# 看一下留言數大概都多少(方便後面篩選)
posts %>%
  #filter(commentNum<200) %>%
  ggplot(aes(x=commentNum)) + geom_histogram()

依據發文數或回覆數篩選post和review

## 帳號發文篇數
post_count = posts %>%
  group_by(artPoster) %>%
  summarise(count = n()) %>%
  arrange(desc(count)) 
post_count

## 帳號回覆總數
review_count = reviews %>%
  group_by(cmtPoster) %>%
  summarise(count = n()) %>%
  arrange(desc(count)) 
review_count

## 發文者
poster_select <- post_count %>% filter(count >= 2)
posts <- posts %>%  filter(posts$artPoster %in% poster_select$artPoster)

## 回覆者
reviewer_select <- review_count %>%  filter(count >= 5)
reviews <- reviews %>%  filter(reviews$cmtPoster %in% reviewer_select$cmtPoster)

# 檢視參與人數
length(unique(posts_Reviews$artPoster)) # 發文者數量 911

[1] 911

length(unique(posts_Reviews$cmtPoster)) # 回覆者數量 15224

[1] 15224

allPoster <- c(posts_Reviews$artPoster, posts_Reviews$cmtPoster) # 總參與人數 15641
length(unique(allPoster))

[1] 15641

標記所有出現過得使用者

• poster：只發過文、發過文+留過言
• replyer：只留過言

userList <- data.frame(user=unique(allPoster)) %>%
              mutate(type=ifelse(user%in%posts$artPoster, "poster", "replyer"))
head(userList,3)

3.以日期篩選社群

link <- posts_Reviews %>%
      group_by(cmtPoster, artUrl) %>% 
      filter(n()>3) %>% 
      filter(commentNum > 200) %>%
      filter(artCat=="Gossiping") %>% 
      filter(artDate == as.Date('2021-05-13')) %>%
      select(cmtPoster, artPoster, artUrl) %>% 
      unique()
link

篩選在link裡面有出現的使用者

filtered_user <- userList %>%
          filter(user%in%link$cmtPoster | user%in%link$artPoster) %>%
          arrange(desc(type))
head(filtered_user,3)

因爲圖片箭頭有點礙眼，所以這裏我們先把關係的方向性拿掉，減少圖片中的不必要的資訊 set.seed 因為igraph呈現的方向是隨機的

set.seed(12345)
# 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(12345)
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 = 5
set.seed(12345)
# 設定 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)

我們可以看到基本的使用者關係，但是我們希望能夠將更進階的資訊視覺化。
例如：使用者經常參與的文章種類，或是使用者在該社群網路中是否受到歡迎。

4.以主題篩選社群

• 抓link

挑選出2021-05-13當天的文章， 篩選一篇文章回覆3次以上者，且文章留言數多餘60則， 文章主題歸類為1、3與4者， 欄位只取：cmtPoster(評論者), artPoster(發文者), artUrl(文章連結), topic(主題)

link <- posts_Reviews %>%
      group_by(cmtPoster, artUrl) %>% 
      filter(n()>3) %>% 
      filter(commentNum > 60) %>%
      filter(artCat=="Gossiping") %>% #HatePolitics / Gossiping
      filter(artDate == as.Date('2021-05-13')) %>%
      filter( topic == 1 | topic == 3 | topic == 4) %>% 
      dplyr::select(cmtPoster, artPoster, artUrl, topic) %>% 
      unique()
link

+抓nodes 在所有的使用者裡面，篩選link中有出現的使用者

filtered_user <- userList %>%
          filter(user%in%link$cmtPoster | user%in%link$artPoster) %>%
          arrange(desc(type))
head(filtered_user,3)

5.使用者經常參與的文章種類

filter_degree = 2

# 建立網路關係
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",ifelse((E(reviewNetwork)$topic =="3"),"lightgreen","deepskyblue" ))

# 畫出社群網路圖
set.seed(12345)
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","deepskyblue"), lty=1, cex=1)

6.使用者是否受到歡迎

PTT的回覆有三種，推文、噓文、箭頭，我們只要看推噓就好，因此把箭頭清掉，這樣資料筆數較少，所以我們把篩選的條件放寬一些。

filter_degree = 1 # 使用者degree

# 過濾留言者對發文者的推噓程度
link <- posts_Reviews %>%
      filter(artCat=="Gossiping") %>% 
      filter(commentNum > 40) %>%
      filter(cmtStatus!="→") %>%
      group_by(cmtPoster, artUrl) %>%
      filter( n() > 2) %>%
      ungroup() %>% 
      dplyr::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(12345)
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)

可以發現本次的討論中幾乎都是推文、噓文較少

七、總結

1.513停電事件的討論重點有哪些? 主要分為哪幾種風向?
對於2021-05-13 ~ 2021-05-18收集的文章，大概可以分成討論政府的討論為何停電、抱怨停電和討論政府針對缺水、疫情、缺電的政策這三個主題，其他還有各家新聞報導內容、討論政府的能源政策以及討論分區停電等三個主題。

2.目前風向最偏哪邊?
針對停電事件PTT上主要以討論為何停電與抱怨停電的文章居多。

3.討論513停電事件的社群網路如何分布?
以社群文章數來看，討論為何停電的網友較多。

4.513停電事件的意見領袖有誰?網友的推噓狀態如何?
因為資料選取的時間較短，只要幾篇回覆量高的貼文，就有機會成為社群中心，在八卦版上，以報導討論為主的意見領袖有:
- 討論為何停電的意見領袖為logyin，大多都是正面推文。
- 抱怨停電的意見領袖lolic ，推文多、噓文少。
- 討論政府針對缺水、疫情、缺電的政策的意見領袖computerqqq，也是推文多、噓文少。