credoでやろうと思ってたけどあまり良い文章構成案が思いつかなかったのでボツにしたデータをせっかくだしブログに残してみる。
ツイートを集めたのは7月22日の21時までの1500ツイート。1500ったーを使った。便利。
本当はtwitteR
CRAN - Package twitteR
で全部R内で完結させたかったんだけど、twitteRってバグ多くてそれで心すり減らすのも嫌だなと思って使ってない。バージョン1.1.8になって少しはましになったんだろうか。
検索クエリは次の通り。
自民党、民主党、共産党、社民党、次世代の党、公明党、維新の党
各政党ごとにツイートを集めてネガポジ判定とLDAによるトピックモデル分析を行ったのである。
ツイートを綺麗にする
まず集めたツイートの整形から。
これの18枚目を参考にした。というか関数を丸々いただいた。
require(lda) require(RMeCab) require(twitteR) require(ggplot2) extractScreenNames <- function(text, strict = TRUE) { if (strict) { # Twitter で screen_name と見なされるものを抽出できるはず regex <- "(?:(?<!\\w)([@@])((?>\\w+))(?![@@])|[\\s\\S])" } else { # 例えば hoge@example.com などメールアドレスにもマッチする regex <- "(?:([@@])(\\w+)|[\\s\\S])" } screenNames <- gsub(regex, "\\1\\2", text, perl = TRUE) unique(unlist(strsplit(substring(screenNames, 2), "[@@]"))) } removeURL <- function(text, strict = TRUE) { if (strict) { # 手前に英数字とかがなくて、間にbasic認証があるかもしれなくて(ちなみにTwitterだとURLとみなされない) # 有効なドメイン名で・・・という文字列を取り除く regex <- "(?<![-.\\w#@=!'\"/])https?://(?:[^:]+:.+@)?(?:[0-9A-Za-z][-0-9A-Za-z]*(?<!-)\\.)+[A-za-z]+(?:/[-\\w#%=+,.?!&~]*)*" } else { regex <- "https?://[-\\w#%=+,.?!&~/]+" } gsub(regex, "", text, perl = TRUE) } removeScreenName <- function(text, strict = TRUE) { if (strict) { # Twitter で screen_name と見なされるものを抽出できるはず regex <- "(?<!\\w)[@@](?>\\w+)(?![@@])" } else { # 例えば hoge@example.com などメールアドレスにもマッチする regex <- "[@@]\\w+" } gsub(regex, "", text, perl = TRUE) } removeHashTag <- function(text, strict = TRUE) { delimiters <- "\\s,.\u3000-\u3002\uFF01\uFF1F" # cf. http://nobu666.com/2011/07/13/914.html validJa <- "\u3041-\u3094\u3099-\u309C\u30A1-\u30FA\u30FC\u3400-\uD7A3\uFF10-\uFF19\uFF21-\uFF3A\uFF41-\uFF5A\uFF66-\uFF9E" if (strict) { regex <- sprintf("(^|[%s])(?:([##](?>[0-9]+)(?!\\w))|[##][\\w%s]+)", delimiters, validJa, validJa) } else { regex <- sprintf("[##][^%s]+", delimiters) } gsub(regex, "\\1\\2", text, perl = TRUE) } removeSpecialStr <- function(text) { removeURL(removeHashTag(removeScreenName(text))) } #ここからツイートの処理。予めディレクトリに移動する jimin<-read.csv("jimin.csv",fileEncoding="utf-8",header=FALSE) statusDF <- twListToDF(jimin) rejimin <- within(statusDF, { # ユーザ名, URL, ハッシュタグを削除 cleanText <- removeSpecialStr(text) })
これで作ったcleanTextという部分を分析の対象にする。実際にはこれだけだとまだ削除しきれていない不要な文字が削除しきれていなかったので、今回はこの後手作業もしたのだけれど。(╹◡╹)とかちゃんと削除しないと!
ネガポジを判定する
ここからツイートのネガティブ、ポジティブを判定する。用いるのは単語感情極性対応表という代物。
# 単語感情極性対応表の取得 pndic <- read.table("http://www.lr.pi.titech.ac.jp/~takamura/pubs/pn_ja.dic", sep = ":", col.names = c("term", "kana", "pos", "value"), colClasses = c("character", "character", "factor", "numeric"), fileEncoding = "Shift_JIS") # 名詞+品詞で複数の候補がある場合は平均値を採用 # 「アイス」の読みとして「アイス」、「アイスホッケー」が割り当てられている例もある pndic2 <- aggregate(value ~ term + pos, pndic, mean) # pndic に登録されている品詞のみ抽出 pos <- unique(pndic2$pos) #政党のところにはjiminとかsyaminとかを入れる 政党DF<-docDF(re政党,column="cleanText",type=1,pos=pos) # pndic に登録されている単語のみ抽出 政党DF<-subset(政党DF,TERM%in%pndic2$term) # 単語極性スコアを付与 政党DF<-merge(政党DF,pndic2,by.x=c("TERM","POS1"),by.y=c("term","pos")) # 単語の出現回数にスコアを掛けて総和を取る score<-colSums(政党DF[4:(ncol(政党DF)-1)]*政党DF$value) #一応原状態を確認する print(sum(score>0)) print(sum(score<0)) print(sum(score==0)) #そもそも単語感情極性対応表はネガティブワードが多いのでネガティブの方が多く出る。なので平均を軸にして相対的な視点で値を出す。 m<-mean(score) tweetType <- factor(ifelse(score > m, "positive", ifelse(score == m, "neutral", "negative")), levels = c("positive", "neutral", "negative")) #確認する print(table(tweetType)) #データフレームに反映させる resyamin$tweetType<-droplevels(tweetType) #可視化する print(qplot(x = factor(1), geom = "bar", fill = tweetType) + coord_polar(theta = "y"))
可視化したものを見てみる
ということで可視化したグラフを見てみようぞ。
自民党に関してやってみたのがこちら。ふむ。意外とみんなポジティブだったのかな。
まあ相対的な分類になっちゃっているから微妙だけども。
こんな感じで延々円グラフ見るわけにもいかないので、エクセルで各結果をまとめたグラフがこちら。
維新の党で引っかかったツイートが一番ネガティブという結果に。なんでだろ。
しかし、いちいち各ツイートを分析していくのも1500こあって面倒だなあ。
ということでLatent Dirichlet Allocation先輩にご登場いただきましょう。
トピックモデル分析(LDA)でツイートのトピックを比較する
これとかすごく分かりやすい。
実際にコードを参考にしたのはこちらのブログ。
僕の中ではアニオタ先輩という愛称で親しまれている。ありがとうありがとう。
ちなみにこっちのqiitaの記事も最初は参考にしてた。
LDAに限らず、日本語をテキストマイニングする時は凄く注意が必要で、分かち書きがその最たるものなのだけれども
この二つの参考先ではその方法が異なっている。
どっちも試してみて、qiitaの方は何だか出力結果としてトピック割合が上手く分かれてくれないので、採用を見送った。ごめんな。さようなら。そしてこんにちはアニオタ先輩。とても感謝しています。
sentence <- NULL word.part <- c("名詞","形容詞") #多分、リムーブワード増やすよりも辞書整備した方が絶対良い(╹◡╹) rm.word <- c("!", "?", "(", ")","という","、","。","は","一","二","〇","0","1","2","の","ため","的","十","たち","3","4","5","6","7","8","9","六","化","0","1","2","3","4","5","6","7","8","9","こと") for(i in seq(7)){ tmp <- read.csv(paste("seit", i, ".txt", sep=""), header=FALSE, fileEncoding="utf-8") lyric0 <- paste(unlist(c(tmp)), sep="", collapse="") rmc <- unlist(RMeCabC(lyric0, mypref=1)) rmc <- rmc[mapply(function(x) x %in% word.part, names(rmc))] rmc <- rmc[mapply(function(x) !x %in% rm.word, rmc)] sentence <- c(sentence, paste(rmc, sep="", collapse=" ")) } corpus <- lexicalize(sentence) #TF-IDFスコアを計算する関数を作っておく TFIDF <-function(corpus, progress=FALSE){# lexicalize した corpus を使用 res <-matrix(0, nr=length(corpus$vocab), nc=4) dimnames(res)<-list(corpus$vocab, c("documents","count","freq","score")) res[,"documents"]<- length(corpus$documents) wordset <- mapply(function(x) x[1,], corpus$documents)# documents中の単語リスト allfreq <-matrix(unlist(corpus$documents), nr=2) wordfreq <- tapply(allfreq[2,], allfreq[1,], sum)# すべての単語の、全documents中の出現頻度for(v in seq(corpus$vocab)){# vocab と i は 1 ずれているので注意 count_docs <- sum(sapply(lapply(wordset,"==", v-1), any))# その単語が出現する文章の数 res[v,"freq"]<- count_docs if(progress){# Linux用。プログレスバーを付ける pb <- txtProgressBar(min=1, max=length(corpus$vocab), style=3) setTxtProgressBar(pb, v)}} res[,"count"]<- wordfreq res[,"score"]<- log(res[,"count"]) * log(res[,"documents"]/res[,"freq"])return(as.data.frame(res))} tf0 <- TFIDF(corpus,TRUE) word0 <- rownames(tf0)[tf0$score > 0]# 1つの文章にしか登場しない単語は除外する corpus <-list(documents=lexicalize(sentence, vocab=word0), vocab=word0)# corpus の作り直し k<-10 #LDAのハイパーパラメータいじってるコード見かけないのでデフォルトにしてるけど、どうなのだろうか result <- lda.collapsed.gibbs.sampler(corpus$documents, k,corpus$vocab,100, 0.1, 0.1,compute.log.likelihood=TRUE) #結果の確認。assignmentが読み込ませたファイルの数と同じなら成功。そうじゃないなら失敗。 summary(result) #各トピックごとの上位語。10個もあればトピックの性質がつかめると思う。 top.words <- top.topic.words(result$topics, 10, by.score = TRUE) #結果の確認 print(top.words) #Nは読み込ませたファイルの数と同じにする N<-7 topic.proportions <- t(result$document_sums)/colSums(result$document_sums) topic.proportions <- topic.proportions[1:N, ] topic.proportions[is.na(topic.proportions)] <- 1/k colnames(topic.proportions) <- apply(top.words, 2, paste, collapse = " ") #可視化 par(mar=c(5, 14, 2, 2)) barplot(topic.proportions, beside = TRUE, horiz = TRUE, las = 1, xlab = "proportion")
得られた結果を可視化してみる
ということで得られた結果をエクセルでグラフにしてみました。一気に行くでよ。
横軸が指数表示のままだったンゴ。。。トピック名は上位語から類推してつけた。
ちなみに維新の党ツイートでの話題はなんだったのかというと、上位語がこんな感じ。
"野党"
"党"
"権"
"自衛"
"議員"
"率"
"支持"
"方"
"内閣"
"個別"
野党が一番上に来て、そこから自衛隊とか支持とか内閣とかそういった話題がきてますね。維新の党は安保法案の対案を出した党ですし、そういったことで盛り上がっていたのでしょうか。
ただその盛り上がり方がネガティブワード多めだったんかなあと。別に他の政党ツイートも同じくらいネガティブがあるので、それに今回の数字は相対的なので、まあ参考程度にって感じですね。
Credoの宣伝
安保を検索クエリにしてここ一週間のネガポジ度の推移をグラフにする。それと一緒にトピックの推移も可視化する。そんな記事を書く予定でごわす。
トピックモデル分析は躓きやすい印象なのでネガポジだけになるかもしれないけど、まあそっちだけでも面白くなると見ております。
こちらは最近出した記事。Gephi使うのが楽しくて少しやりすぎた感ある。