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

主題

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

一、動機與分析目的

• 背景與動機
  • 清明連假正是大家準備開心祭祖或是出遊的日子，大眾交通工具成為提供大家往返的工具，尤其是台鐵鐵路運輸的環島交通網，更是往來西岸與東岸最便利的方式，連假的第一天是交通最繁忙的一天，台鐵的太魯閣號卻因為施工單位的疏忽發生了嚴重的出軌意外，造成247輕重傷、49人死亡的悲劇；這場意外究竟是單純外包施工廠商，抑或是積習已久的台灣鐵路公司監督不周所造成的。
• 研究目的
  1. 了解民眾對於太魯閣號事件的態度。
     
  2. 網民認為太魯閣號的責任歸屬。
     
  3. 太魯閣號出軌事件後該做的事。
     

1.資料集描述

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

二、前置作業

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

[1] ""

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)

2.將require及library載入

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

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

posts <- read_csv("0612-1_articleMetaData.csv") # 文章 
reviews <- read_csv("0612-1_articleReviews.csv") # 回覆 
rd <- read_csv("0612-1_artWordPOSFreq.csv")
head(posts)

head(reviews)

head(rd)

4.文章斷句

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

5.文章斷詞

# ## 文章斷詞
# # 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")

清理斷詞結果

。根據詞頻，選擇只出現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) 

三、折線圖

1.資料處理

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

2.初始化斷詞引擎

# 加入自定義的字典
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)

3.台灣大停電事件在PTT八卦5/13~5/19聲量折線圖

plot_date <- 
  # data
  article_count_by_date %>% 
  # aesthetics
  ggplot(aes(x = artDate, y = count)) +
  # geometrics
  geom_line(color = "#00AFBB", size = 1) + 
  # 2021-01-20 紅線
  geom_vline(xintercept = as.numeric(as.Date("2021-05-13")), col='red', size = 1) + 
  # 2021-02-23 紅線
  geom_vline(xintercept = as.numeric(as.Date("2021-05-17")), col='red', size = 1) + 
  # coordinates

  ggtitle("Dcard 股票看板 討論文章數") + 
  xlab("日期") + 
  ylab("數量") + 
  # theme
  theme(text = element_text(family = "Heiti TC Light")) #加入中文字型設定，避免中文字顯示錯誤。

plot_date

四、文字雲

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

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

五、情緒分析

1.載入情緒分析字典

# 正向字典txt檔
# 以,將字分隔
P <- read_file("positive.txt")

# 負向字典txt檔
N <- read_file("negative.txt")

#將字串依,分割
#strsplit回傳list , 我們取出list中的第一個元素
P = strsplit(P, ",")[[1]]
N = strsplit(N, ",")[[1]]

# 建立dataframe 有兩個欄位word,sentiments，word欄位內容是字典向量
P = data.frame(word = P, sentiment = "positive")
N = data.frame(word = N, sentiment = "negative")
LIWC = rbind(P, N)

rd_tokens <- rd %>%
  select(-artTime, -artUrl)
head(rd_tokens)

rd_tokens_by_date <- rd_tokens %>% 
  count(artDate, word, sort = TRUE) %>%
  filter(n > 5)
rd_tokens_by_date

rd_tokens_by_date %>%
  inner_join(LIWC) %>%
  select(word) %>%
  inner_join(LIWC) 

Joining, by = "word"
Joining, by = "word"

sentiment_count = rd_tokens_by_date %>%
  select(artDate,word,n) %>%
  inner_join(LIWC) %>% 
  group_by(artDate,sentiment) %>%
  summarise(count=sum(n))

Joining, by = "word"
`summarise()` has grouped output by 'artDate'. You can override using the `.groups` argument.

2.台灣停電事件在PTT八卦版5/13~5/18正負面情緒聲量折線圖

sentiment_count %>%
  ggplot() +
  geom_line(aes(x=artDate,y=count,colour=sentiment)) +
  labs(x=NULL,y="數量")

NA

3.台灣停電事件在PTT八卦版5/13~5/8正負情緒長條圖

rd_tokens_all %>%
  filter(artDate == as.Date("2021-05-13") |
         artDate == as.Date("2021-05-14") | 
         artDate == as.Date("2021-05-15") | 
         artDate == as.Date("2021-05-16") |
         artDate == as.Date("2021-05-17") |
         artDate == as.Date("2021-05-18") ) %>% 
  inner_join(LIWC) %>%
  group_by(word,sentiment) %>%
  summarise(
    count = n()
  ) %>% data.frame() %>% 
  top_n(30,wt = count) %>%
  ungroup() %>% 
  mutate(word = reorder(word, count)) %>%
  ggplot(aes(word, count, fill = sentiment)) +
  geom_col(show.legend = FALSE) +
  labs(x= "文字", y="數量") +
  facet_wrap(~sentiment, scales = "free_y") +
  theme(text=element_text(size=14))+
  coord_flip()

Joining, by = "word"
`summarise()` has grouped output by 'word'. You can override using the `.groups` argument.

六、LDA 主題分類

1.LDA 主題分析

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

2.取出代表字詞(term)

#removed_word = c("不是","每天","出來","覺得") 
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()

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

4.資料內容探索

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(10)

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

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

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

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

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

5.日期主題分布

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.

七、社群網路圖

1.資料合併

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

Error in as.data.frame(y) : 找不到物件 'mask_topics'

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

Error in select(., cmtPoster, artPoster, artUrl) : 
  找不到物件 'posts_Reviews'

2.基本網路圖

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

Error in as.data.frame(d) : 找不到物件 'link'

3.資料篩選

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

4.依據發文數或回覆數篩選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 >= 20)
reviews <- reviews %>%  filter(reviews$cmtPoster %in% reviewer_select$cmtPoster)

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

[1] 911

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

[1] 15224

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

[1] 15641

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

5.以日期篩選社群

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

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

set.seed(487)
# 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)

set.seed(487)
V(reviewNetwork)$color <- ifelse(V(reviewNetwork)$type=="poster", "gold", "lightblue")
plot(reviewNetwork, vertex.size=3, edge.arrow.size=0.3,vertex.label=NA)

filter_degree = 4
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 <- posts_Reviews %>%
      group_by(cmtPoster, artUrl) %>% 
      filter(n()>3) %>% 
      filter(commentNum > 200) %>%
      filter(artCat=="Gossiping") %>% #HatePolitics / Gossiping
      filter(artDate == as.Date('2021-05-13')) %>%
      filter(topic == 2 | topic == 4) %>% 
      select(cmtPoster, artPoster, artUrl, topic) %>% 
      unique()
link

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

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

filter_degree = 13

# 建立網路關係
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 == "2", "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)

7.使用者是否受到歡迎

filter_degree = 7 # 使用者degree

# 過濾留言者對發文者的推噓程度
link <- posts_Reviews %>%
      filter(artCat=="Gossiping") %>% 
      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)

八、總結

1. 台灣停電事件的討論重點有哪些? 主要分為哪幾種風向?
   對於2021-05-21 ~ 2021-05-23收集的文章，大概可以分成嘲諷校正回歸、客觀討論校正回歸這兩種，其他還有著重討論確診個案足跡或和疫苗相關的討論等四種。討論重點多在於統計「數字」、「公布日期」等案例的計算方式。

2. 目前風向最偏哪邊?
   客觀討論計算方式的文章不少，但嘲諷、八卦性質的文章居多。

3. 討論校正回歸的社群網路如何分布?
   以社群文章數來看，批評嘲諷的網友較多，但從社群網路觀察發現，兩邊的貼文討論聲量都很高。

4. 校正回歸的意見領袖有誰?網友的推噓狀態如何?
   因為資料選取的時間較短，只要幾篇回覆量高的貼文，就有機會成為社群中心，在八卦版上，以報導討論為主的意見領袖有 centre0130，回覆推噓皆有，調侃批評部分則有 hstf，網友大多正面推文。