BonfireLit

でもソウルシリーズはまだやってないです

SlideShareに"マリオメーカー問題"を分析したスライドを投稿しました

はい、というわけでようやくやりたかった分析ができました。

関連動画でネットワークを構築するというのは結構良いアイデアじゃないかなと思っているのですが、あまりやっている人がいないのを見るとそんなに実は意味がないのでしょうか。。。

まあとにかく、その手法でやってみた次第です。もう少し分析に広がりを持たせたかったのですが時間の関係でこんなもんですね。

動画タグネットワーク分析を用いた ニコニコ動画における萌芽文化発見の試み ~”ゆっくり関連タグ”を例として~

SlideShareに初めて投稿してみました。

忙しい人向けにかいつまんで説明すると

  • "ゆっくり霊夢魔理沙などに関連した動画"につけられるタグの共起関係を用いてネットワークを構築した
  • 時系列分析ではまず東方コミュニティが成長し、その後周辺コミュニティが成長していくがその中の一つであったゲーム実況コミュニティが2012年ごろから急速に成長した
  • 先行研究を用いて機械学習で、"今はまだそんなに有名じゃないが今後文化として定着し得るタグ"を発見できないか試みたものの芳しくなかった
  • ゆっくり関連のタグネットワークは成長が頭打ちになっている感があるので、VOICELOIDに目を向ける方が研究し甲斐があるかもしれない
  • ネットワーク分析の勉強がんばります

といったところです。
Gephiで日本語を扱う時に文字コードにあまり注意を払わなかったせいで、あとで文字化けを手動で治す羽目になったのが一番つらいとこでした。自業自得...

今度は関連動画ネットワークでユーザーの行動予測をしてみたいと思っております。「マリオメーカー問題」とかで辿ったらおもしろそうだなーという感じで夢広がる!

ある日の各政党に関するツイートを集めて分析してみた

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

可視化したものを見てみる

ということで可視化したグラフを見てみようぞ。

f:id:fufufukakaka:20150725205622p:plain

自民党に関してやってみたのがこちら。ふむ。意外とみんなポジティブだったのかな。
まあ相対的な分類になっちゃっているから微妙だけども。

こんな感じで延々円グラフ見るわけにもいかないので、エクセルで各結果をまとめたグラフがこちら。

f:id:fufufukakaka:20150725205850p:plain

維新の党で引っかかったツイートが一番ネガティブという結果に。なんでだろ。

しかし、いちいち各ツイートを分析していくのも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)

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

得られた結果を可視化してみる

ということで得られた結果をエクセルでグラフにしてみました。一気に行くでよ。

f:id:fufufukakaka:20150725211657p:plainf:id:fufufukakaka:20150725211658p:plainf:id:fufufukakaka:20150725211659p:plainf:id:fufufukakaka:20150725211701p:plainf:id:fufufukakaka:20150725211702p:plainf:id:fufufukakaka:20150725211704p:plainf:id:fufufukakaka:20150725211705p:plain

横軸が指数表示のままだったンゴ。。。トピック名は上位語から類推してつけた。

ちなみに維新の党ツイートでの話題はなんだったのかというと、上位語がこんな感じ。

"野党"
"党"
"権"
"自衛"
"議員"
"率"
"支持"
"方"
"内閣"
"個別"

野党が一番上に来て、そこから自衛隊とか支持とか内閣とかそういった話題がきてますね。維新の党は安保法案の対案を出した党ですし、そういったことで盛り上がっていたのでしょうか。
ただその盛り上がり方がネガティブワード多めだったんかなあと。別に他の政党ツイートも同じくらいネガティブがあるので、それに今回の数字は相対的なので、まあ参考程度にって感じですね。

Credoの宣伝

安保を検索クエリにしてここ一週間のネガポジ度の推移をグラフにする。それと一緒にトピックの推移も可視化する。そんな記事を書く予定でごわす。
トピックモデル分析は躓きやすい印象なのでネガポジだけになるかもしれないけど、まあそっちだけでも面白くなると見ております。

credo.asia

こちらは最近出した記事。Gephi使うのが楽しくて少しやりすぎた感ある。