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) {
regex <- "(?:(?<!\\w)([@@])((?>\\w+))(?![@@])|[\\s\\S])"
} else {
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) {
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) {
regex <- "(?<!\\w)[@@](?>\\w+)(?![@@])"
} else {
regex <- "[@@]\\w+"
}
gsub(regex, "", text, perl = TRUE)
}
removeHashTag <- function(text, strict = TRUE) {
delimiters <- "\\s,.\u3000-\u3002\uFF01\uFF1F"
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, {
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)
pos <- unique(pndic2$pos)
政党DF<-docDF(re政党,column="cleanText",type=1,pos=pos)
政党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)でツイートのトピックを比較する
これとかすごく分かりやすい。
実際にコードを参考にしたのはこちらのブログ。
d.hatena.ne.jp
僕の中ではアニオタ先輩という愛称で親しまれている。ありがとうありがとう。
ちなみにこっちのqiitaの記事も最初は参考にしてた。
qiita.com
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)
TFIDF <-function(corpus, progress=FALSE){
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)
allfreq <-matrix(unlist(corpus$documents), nr=2)
wordfreq <- tapply(allfreq[2,], allfreq[1,], sum)
count_docs <- sum(sapply(lapply(wordset,"==", v-1), any))
res[v,"freq"]<- count_docs
if(progress){
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]
corpus <-list(documents=lexicalize(sentence, vocab=word0), vocab=word0)
k<-10
result <- lda.collapsed.gibbs.sampler(corpus$documents, k,corpus$vocab,100, 0.1, 0.1,compute.log.likelihood=TRUE)
summary(result)
top.words <- top.topic.words(result$topics, 10, by.score = TRUE)
print(top.words)
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の宣伝
安保を検索クエリにしてここ一週間のネガポジ度の推移をグラフにする。それと一緒にトピックの推移も可視化する。そんな記事を書く予定でごわす。
トピックモデル分析は躓きやすい印象なのでネガポジだけになるかもしれないけど、まあそっちだけでも面白くなると見ております。
credo.asia
こちらは最近出した記事。Gephi使うのが楽しくて少しやりすぎた感ある。