からっぽのしょこ

読んだら書く!書いたら読む!同じ事は二度調べ(たく)ない

R言語でツイートテキストのネガポジ分析

はじめに

 ツイートテキストに対して感情分析を行います。
 感情分析とは(ざっくり言うと)、テキストに含まれている単語がそれぞれネガティブな表現なのかポジティブな表現なのかを評価し、テキスト全体がネガ・ポジどちらなのかを判定するものです。

【分析手順】

  1. rtweetパッケージを使ってツイートを拾ってきます
  2. 取得したツイートテキストを、指定した期間(日or月)ごとに区分けして1つのテキストとします
  3. 各(期間の)テキストに対して、MeCabで形態素解を行います
  4. 単語感情極性対応表を利用して、単語ごとにネガポジスコアを付与します
  5. 期間ごとにネガティブスコア・ポジティブスコアを合算してその期間のネガ度・ポジ度とします
  6. その結果をggplot2で可視化します

f:id:anemptyarchive:20200525194502p:plain
完成図

・ツイートのネガポジ分析

## 利用パッケージ
# ツイート収集:get_timeline()
library(rtweet)

# 形態素解析:docDF()
library(RMeCab)

# 時間データの処理:floor_date(), as_date()
library(lubridate)

# データフレーム操作
library(dplyr)
library(tidyr)

#文字列操作:str_remove_all()
library(stringr)

# 作図
library(ggplot2)

 利用するパッケージを読み込みます。

・ツイート収集

 まずはrtweetパッケージを利用して、ツイートを集めます。

# アカウントを指定
screen_name <- "anemptyarchive"

# アカウント指定でツイートを収集
tw_data <- get_timeline(screen_name, n = 10000, include_rts = FALSE)

 get_timeline()にアカウント(@○○○の○○○)を指定して、ツイートを取得します。引数nは収集するツイート数を指定し、include_rts = FALSEで取得ツイートからリツイートを除きます(デフォルトはTRUE)。

 特定の単語を含むツイートを収集するのであれば、search_tweets("検索ワード")を使います。

 取得できるツイートの数に制限があったりします。

 取得したツイートデータの内、ツイート日時(created_at列)とツイートテキスト(text列)を使います。

# ツイート日時の抽出とPOSIXlt型・タイムゾーンの変換
tw_time <- tw_data[["created_at"]] %>% 
  as.POSIXct(tz = "Etc/GMT") %>% 
  as.POSIXlt(tz = "Japan")

 取得したツイート日時はPOSIXct型の世界共通時(UTC)なので、これをas.POSIXlt()でPOSIXlt型の日本標準時(JST)に変換します。引数tzはタイムゾーンのことでJSTに変更するなら"Japan"あるいは"Asia/Tokyo"を指定します(2行目のEtc/GMTはUCTを明示しています。多分なくても動く)

tw_time[1:10]
##  [1] "2020-05-25 00:48:56 JST" "2020-05-24 10:33:57 JST"
##  [3] "2020-05-23 23:55:20 JST" "2020-05-23 23:45:54 JST"
##  [5] "2020-05-23 23:35:50 JST" "2020-05-23 23:15:49 JST"
##  [7] "2020-05-23 23:12:26 JST" "2020-05-23 22:59:04 JST"
##  [9] "2020-05-23 19:33:35 JST" "2020-05-23 19:26:21 JST"

こんな感じになっていればOKです。続いてテキストを抽出します。

# ツイートテキストの抽出と文字列処理
tw_text <- tw_data[["text"]] %>% 
  str_remove_all("^@.*?\\s") %>% # リプライ先の除去
  str_remove_all(("https?://[\\w/:%#\\$&\\?\\(\\)~\\.=\\+\\-]+")) %>% # urlの除去
  str_remove_all("[\U0001F004-\U000207BF]") # 絵文字の除去

 ツイートテキストから、分析に不要な部分をstr_remove_all()で取り除きます。

 これで必要なツイートデータを取得できました。次からは分析のための整形処理を行っていきます。

・前処理

# 単位(期間)を指定
term <- "mon"
term <- "day"

 ツイートテキストをひとまとめにする単位(期間)を指定します。
 「月」単位なら"mon"、「日」単位なら"day"とします。これは主にfloor_date()unit引数に指定するためのものなので、このままの文字列を使用してください。

# 期間ごとにツイートテキストをまとめる
text_df <- data.frame(
  terms = as.Date(floor_date(tw_time, term)), # 指定した期間で丸める
  texts = tw_text
) %>% 
  group_by(terms) %>% # 期間ごとにグループ化
  summarise(texts = paste(texts, collapse = "\n")) # 同一期間のテキストを結合

 floor_date()で指定した期間(単位)に丸めて、as_date()にDate型の日付データに変換します(時刻データを落とします)。

 また丸めて同一期間となったツイートテキストをまとめます。各ツイートの区切りは改行(\n)としておきます。

 データを確認しましょう。

tail(text_df)
## # A tibble: 6 x 2
##   terms      texts                                                              
##   <date>     <chr>                                                              
## 1 2020-05-20 "ゼロつく1終わったー。早速2周目をより丁寧にやってく\n時々こっち向くの凄くかわいい///\n別の本を仕入れて理解したい気持ちもあ~
## 2 2020-05-21 "何の推定もできませんでした!!はてなブログに投稿しました #はてなブログ\n\n【R】3.3.8:LDAの周辺化変分ベイズ法【白ト~
## 3 2020-05-22 "放心ちゅう #おうちでBuono!\nハロプログループの中で一番Buono!が好きなんだけど、嵌まる2か月前に解散しててこれがその~
## 4 2020-05-23 "まぁよく頑張ったと思う。  nやり切ると燃え尽きるので、既に始めた\n次の本をやっていき\n1ページ目を開くのに1年かかることもある~
## 5 2020-05-24 "楽しみにしててください!(これはしっかりやらねば宣言ですね)"       
## 6 2020-05-25 "きょーのところはこれくらいにしといてやる"


 これでデータハンドリングは完了です。次からはネガポジ分析を行っていきます。

・感情分析

 まずはネガポジ度の配点データとなる辞書データを用意します。

# 単語感情極性対応表の取得
np_dic_original <- read.table(
  "http://www.lr.pi.titech.ac.jp/~takamura/pubs/pn_ja.dic", 
  sep = ":", stringsAsFactors = FALSE
)

 東京工業大学高村研究室で公開されている単語感情極性対応表を、単語のネガポジ度を測定するための辞書として利用します。詳しくは「R+RMeCabで感情分析」をご参照ください。

head(np_dic_original)
##         V1       V2     V3       V4
## 1   優れる すぐれる   動詞 1.000000
## 2     良い     よい 形容詞 0.999995
## 3     喜ぶ よろこぶ   動詞 0.999979
## 4   褒める   ほめる   動詞 0.999979
## 5 めでたい めでたい 形容詞 0.999645
## 6     賢い かしこい 形容詞 0.999486

 これをRMeCab::docDF()の出力結果と結合するために形式を揃えます。

# ネガポジ辞書の作成
np_dic <- np_dic_original %>% 
  select(TERM = V1, POS1 = V3, allocation = V4) %>% # 列の選択
  distinct(TERM, .keep_all = TRUE) # 重複の除去
head(np_dic)
##       TERM   POS1 allocation
## 1   優れる   動詞   1.000000
## 2     良い 形容詞   0.999995
## 3     喜ぶ   動詞   0.999979
## 4   褒める   動詞   0.999979
## 5 めでたい 形容詞   0.999645
## 6     賢い 形容詞   0.999486


 これで辞書データを用意できました。続いて、上で作成した日(あるいは月)ごとのテキスト1つずつに対して次の処理を行います。

  1. docDF()で単語に切り分けます。
  2. テキストに含まれる単語一覧とネガポジ辞書の単語をleft_join()で(マッチして)結合することで、配点データを付与します。
  3. 各単語の配点と出現回数を掛けてスコアを計算します。
  4. スコアがマイナスなら「ネガティブ」、プラスなら「ポジティブ」、0(またはNA)なら「ニュートラル」のラベルを付与します。


 テキストをMeCabにかけるには、一時的にtxtファイルとして書き出す必要があります。

# 一時テキストファイルの保存先を指定
folder_name <- "tmp_data"

# 分析結果の受け皿を初期化
score_df <- data.frame()
for(i in 1:nrow(text_df)) {
  
  # 一時ファイルパスを作成
  tmp_file_name <- paste(screen_name, "_", text_df[["terms"]][i], ".txt", sep = "")
  tmp_path <- paste(folder_name, tmp_file_name, sep = "/")
  
  # テキストファイルを書き出し
  write(text_df[["texts"]][i], tmp_path)
  
  # MeCabによる形態素解析
  mecab_df <- docDF(tmp_path, type = 1, pos = c("動詞", "形容詞", "副詞", "助動詞"))
  
  if(!is.null(mecab_df)) { ## (NULLでないときのみ)
    
    # ネガポジ配点を結合
    tmp_score_df <- mecab_df %>% 
      left_join(np_dic, by = c("TERM", "POS1")) %>% # 各単語に配点を付与
      mutate(allocation = replace_na(allocation, 0)) %>% # NAを0に置換
      select(TERM, FREQ = tmp_file_name, allocation) # docDF仕様の列名に変更
    
    # ネガポジスコアを計算
    tmp_score_df <- tmp_score_df %>% 
      mutate(terms = text_df[["terms"]][i]) %>% # 日付情報列の追加
      mutate(allocation = replace_na(allocation, 0)) %>% # 配点がNAの場合0に置換
      mutate(score = allocation * FREQ) %>% # (スコア) = (配点) * (語数)
      mutate(
        np_label = case_when(
          score < 0 ~ "negative", # (スコア) < 0ならネガ
          score > 0 ~ "positive", # (スコア) > 0ならポジ
          score == 0 ~ "neutral"  # (スコア) = 0ならニュート
        )
      ) # ネガポジラベルを付与
    
    # 全期間の結果を結合
    score_df <- rbind(score_df, tmp_score_df)
  }
}

 辞書に含まれない単語はデータフレームの結合時に配点がNAとなります。これをreplace_na()で0に置換します。

 単語ごとに配点(allocation列)と(その単語の)語数(FREQ列)を掛けてスコア(score列)とします。

 また単語ごとにスコアの正負によってラベルデータを与えます。case_when()を使ってscore列が、、0未満なら"negative"0より大きければ"positive"、0なら"neutral"とします。

 結果はこのようになります。

tail(score_df)
##      TERM FREQ allocation      terms     score np_label
## 8060   ぬ    1  -0.998545 2020-05-24 -0.998545 negative
## 8061 やる    1   0.000000 2020-05-24  0.000000  neutral
## 8062 くる    1   0.000000 2020-05-25  0.000000  neutral
## 8063 する    1   0.000000 2020-05-25  0.000000  neutral
## 8064 とく    1   0.000000 2020-05-25  0.000000  neutral
## 8065 やる    1   0.000000 2020-05-25  0.000000  neutral

 単語ごとに得点を与えられたので、次は期間ごとに合計します。

# 期間ごとにネガスコア・ポジスコアの合計
result_df <- score_df %>% 
  select(terms, np_label, score, FREQ) %>% 
  group_by(terms, np_label) %>% 
  summarise(score = sum(score), FREQ = sum(FREQ)) # スコアと頻度を合算

 期間ごとにそのまま合計するのでなく、ネガポジラベルの情報も使ってポジティブ・ネガティブ・ニュートラル(0だけど)ごとに合計しておきます(相殺されるのはもったいないので)。

tail(result_df)
## # A tibble: 6 x 4
## # Groups:   terms [3]
##   terms      np_label   score  FREQ
##   <date>     <chr>      <dbl> <dbl>
## 1 2020-05-23 negative -14.3      21
## 2 2020-05-23 neutral    0       103
## 3 2020-05-23 positive   4.82      5
## 4 2020-05-24 negative  -0.999     1
## 5 2020-05-24 neutral    0         6
## 6 2020-05-25 neutral    0         4


 以上でネガポジ評価は完了です。では可視化しましょう。

・可視化

・ネガポジ推移

# ネガポジ推移
ggplot(result_df, aes(x = terms, y = score)) + 
  geom_bar(mapping = aes(fill = np_label, color = np_label), stat = "identity") + # 棒グラフ
  scale_fill_manual(values = c("#00A968", "yellow", "orange")) + # 塗りつぶしの色
  scale_color_manual(values = c("#00A968", "yellow", "orange")) + # 枠の色
  geom_line(stat = "summary", fun = "sum", color = "blue") + # 折れ線グラフ
  scale_x_date(date_breaks = "2 weeks") + # x軸目盛(day)
  #scale_x_date(date_breaks = "1 month", date_labels = "%Y-%m") + # x軸目盛(mon)
  theme(axis.text.x = element_text(angle = 90)) + # x軸目盛の傾き
  labs(title = paste0("@", screen_name, "のネガポジ推移"), 
       x = term) # ラベル

 積み上げ棒グラフで、ポジティブスコアとネガティブスコアを表します。
   またポジ・ネガスコアの合計を折れ線グラフで描き、その期間のポジ・ネガを表します。

 ツイート期間が多いと、x軸目盛が潰れてしまうので、scale_x_date()date_breaks引数に表示する位置をしていして間引きます。(日別か月別でかなり変わるので、両方用意して片方をコメントアウトしています。)

f:id:anemptyarchive:20200525194502p:plain
ネガポジ推移:日別


 このグラフだと主にニュートラル単語の情報が欠けているので、総単語数におけるネガポジ語数の割合も見ておきましょう。

・ネガポジ割合の推移

# ネガポジ割合の推移
ggplot(result_df, aes(x = terms, y = FREQ, fill = np_label, color = np_label)) + 
  geom_bar(stat = "identity", position = "fill") + # 棒グラフ
  scale_fill_manual(values = c("#00A968", "yellow", "orange")) + # 塗りつぶしの色
  scale_color_manual(values = c("#00A968", "yellow", "orange")) + # 枠の色
  scale_x_date(date_breaks = "2 weeks") + # x軸目盛(day)
  #scale_x_date(date_breaks = "1 month", date_labels = "%Y-%m") + # x軸目盛(mon)
  theme(axis.text.x = element_text(angle = 90)) + # x軸目盛の傾き
  labs(title = paste0("@", screen_name, "のネガポジ割合(語数)の推移"), 
       x = term) # ラベル

f:id:anemptyarchive:20200525194536p:plain
ネガポジ割合(語数):日別

・月別の場合

f:id:anemptyarchive:20200525194618p:plain
ネガポジ推移:月別

f:id:anemptyarchive:20200525194747p:plain
ネガポジ割合(語数):月別

 ニュートラルな(ネガポジどちらでもない)単語というよりも、得点が与えられて(ネガポジが判定されて)いないが単語多すぎますね。ネガ・ポジ判定のできた単語だけ見てもいくら何でもネガティブが過ぎますね、これは使い物になら・・・

以上!

主な参考文献


おわりに

 この分析には、いくつか課題があります。

  • 課題点1:ネガポジスコアがイマイチ日常ツイートに対するスコアリングに適していない気がします。ネガティブにかなり振れてしまう模様。ポジティブツイートばかりするbotアカのテキストでもネガティブ一色な結果でした。
  • 課題点2:「○○しない」という文は、「○○」-「する」-「ない」 に分割されます。この3語に対してスコアが与えられ、合算することでテキスト全体のネガ・ポジを判断します。そのためテキスト全体ではその単語を否定しているにもかかわらず、○○の部分に当たる単語のネガ・ポジが反映されてしまいます。
  • 課題点3:私がggplot2をうまく扱えない。x軸の目盛をうまく表示できていません。

 それぞれ、

  1. 他の表現辞書を使ってみる
  2. N-gramを利用して否定で使われる単語を判断し、その語を取り除く処理を加える
  3. 勉強する

で対応することを考えています。

 この辺りを回避できれば、評判分析や口コミ分析として活用してみたいのですが。今のままでは、複数の分析対象の結果を比較して相対的に判断するとかなら使えそうでしょうか。

 まだまだTwitter APIを使って挑戦したいことがあるのですが、勉強不足を多々感じるので暫くインプット期間に移行します。また更新したらよろしくお願いします。最後まで読んでいただきありがとうございました。

2020.05.25:全面刷新しました。

 課題点1・2(つまり分析的なこと)は特に変わってないですねぇ、、、mutate()を使えるようになったので処理全般がいい感じになったのと、日時データの扱い方が少し上手くなったことでggplot2の力を引き出せたのが大きな変化です。