ラブライブ スクフェスの楽曲属性をCTMで予測する

MikuHatsune2013-06-18

トピックモデルを使ってラブライブの歌を解析したのだが、LDAの苦手な点として、各トピックを独立に設定してしまうらしい。
CTMはトピック間の関係を考慮しているので、トピック立てすぎて効率が低下、という事態が減るらしい(こちら)。
スクフェスにはスマイルピュアクールの3つの属性が各曲に割り振られているので、CTMから得られるトピック分布確率が属性に影響を与えていると仮定、つまり、歌詞の内容が属性に影響を与えている(楽曲のテンポといった曲調も重要だろうけど、MIDIが取ってこれるわけないのでこれは無視する)と考えて、まだスクフェスに登場していない曲の属性推定を、教師有り機械学習(LASSOの多値判別)によって行う。
 
CTMのトピック数は20、出てくる品詞は名詞・動詞・形容詞に限定した。また、TF-IDFを考慮して、1つの文章、というか歌にしか登場しない単語は除外することにした。

library(RMeCab)
wd <- "/lovelive_song/"
musics <- read.delim(paste(wd, "songlist.txt", sep=""), header=FALSE, fileEncoding="utf-8") # 曲名リスト

lyrics <- NULL
lex <- c("名詞", "動詞", "形容詞") # MeCab辞書をもっと整備したらきれいになるんだろう…
for(i in seq(nrow(musics))){
	tmp <- read.csv(paste(wd, i, ".txt", sep=""), header=FALSE, fileEncoding="utf-8") # エンコーディングにはまって面倒だった
	lyric0 <- paste(unlist(c(tmp)), sep="", collapse="")
	rmc <- unlist(RMeCabC(lyric0, mypref=1))
	rmc <- rmc[names(rmc) %in% lex]
	lyrics <- c(lyrics, paste(rmc, sep="", collapse=" ")) # 分かち書き
}

library(topicmodels)
library(lda)
library(igraph)

corpus <- lexicalize(lyrics) # この段階ではうまく lexicalize されていないっぽい
for(l in seq(length(corpus$documents))){
	wtable <- table(corpus$documents[[l]][1, ])
	wmat <- rbind(as.numeric(names(wtable)), wtable)
	corpus$documents[[l]] <- unname(wmat)
}

# 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(lyrics, vocab=word0), vocab=word0) # corpus の作り直し

# ここから CTM をやる
dtm0 <- ldaformat2dtm(corpus$documents, corpus$vocab)
ctm0 <- CTM(dtm0, 20)

g0 <- build_graph(ctm0, 0.1)
diag(g0) <- 0
g0 <- graph.adjacency(g0, mode="undirected")
E(g0)$width <- 6
plot(g0)

たぶんこれをしたら、トピック間の関係の強さっぽいものが取れそうな予感。
{2, 8, 12, 19}, {4, 5, 20} は関係が強そうな感じ?

トピック内の上位出現単語を確認すると、たしかに、{2, 8, 12, 19} はみんなで頑張れ的な内容で、{4, 5, 20} は泣いたり笑ったりするけど熱い気持ち信じて頑張れ的な内容が重複している。

terms(ctm0, 20)
Topic 1	Topic 2	Topic 3	Topic 4	Topic 5	Topic 6	Topic 7	Topic 8	Topic 9	Topic 10	Topic 11	Topic 12	Topic 13	Topic 14	Topic 15	Topic 16	Topic 17	Topic 18	Topic 19	Topic 20
dan	!	!	てる	君	)	(	の	くるう	!	'	)	!	(	hi	する	私	happy	(	いる
(	君	いる	!	てる	(	)	あなた	くらう	hi	t	(	私	)	(	(	たち	holiday	)	!
!	.	ー	感じる	いる	?	!	隠す	?	i	worry	熱い	の	られる	!	夢	咲く	(	く	感じる
-	いい	ざ	く	夢	!	?	私	そう	do	don	てる	前	ー	oh	!	赤い	holidayhappy	開く	てる
hi	場所	てる	君	熱い	く	私	なる	私	'	!	の	おいで	ちゃう	yeah	くる	さ	i	ズルイ	夢
wonderful	探す	今	熱い	ん	summer	なる	開ける	じん	s	go	聞こえる	踊る	なる	)	?	巡り合う	say	ー	君
ん	一緒	ここ	いい	く	私	love	今	君	(	?	さ	?	く	?	wonder	君	know	!	変わる
!!	まま	私	いる	信じる	いい	君	れる	見る	let	(	heaven	てる	れる	する	)	れる	)	ん	いい
君	k	大好き	胸	胸	my	いる	友達	られる	go	ton	私	する	好き	rin	てる	くる	dancing	コワイ	ん
!)	o	たち	泣く	!	day	!!	てる	の	!)	you	君	こと	恋	!)	の	風	are	こと	?
?)	いる	ばん	する	泣く	of	ちゃう	未来	とまる	live	are	青春	聞く	私	もの	なる	よう	everyday	恋	する
&	どこ	みんな	夢	いい	する	の	見る	変わる	笑顔	する	わかる	れる	しょう	なる	なれる	優しい	ん	跳ぶ	く
peace	勇気	木	信じる	感じる	love	する	好き	ありふれる	ある	!!)	する	夜	がんばる	no	いっしょ	の	楽しい	みんな	胸
s	今	夢	いま	どこ	達	く	願い	痛み	てる	ready	?	恋	みる	の	feeling	?	!)	今	れる
let	抱きしめる	さ	こと	こころ	wing	恋	きれる	言う	元気	no	!	晴れる	泣く	私	さ	時	心	真剣	私
go	こころ	ある	なる	場所	12	てる	言える	激しい	)	pa	いる	輝	まれ	いる	先	忘れる	みんな	いる	熱い
'	嬉しい	明日	?	今	楽しい	それ	こわい	する	く	迷う	みる	城	実る	自分	がんばる	道	!!	する	場所
jump	いま	時	私	変わる	in	見る	透明	悲しみ	楽しい	to	あなた	奇跡	ねばねば	ん	強い	変わる	はじける	てる	どこ
super	そう	よい	ん	いま	the	泣く	変わる	こと	可能	信じる	見つめる	目	ぎぶあぷな	rlng	はじまる	いつか	さ	なか	なる
rush	こと	向く	ある	行く	べり	夢	誰	燃える	性	あなた	恋	明日	こっち	a	よい	輝き	time	動く	)

 
推定にうつろう。各曲のトピック分布は

ctm0@gamma

で得られる。

library(glmnet)
idx <- which(nchar(as.character(musics$V3)) > 0) # 既にスクフェスに登場してラベルがある曲

glmnet1 <- glmnet(ctm0@gamma[idx,], as.character(musics$V3[idx]), family="multinomial")
cv.glmnet1 <- cv.glmnet(ctm0@gamma[idx,], as.character(musics$V3[idx]), family="multinomial")
pred1 <- predict(glmnet1, ctm0@gamma[idx,], s=cv.glmnet1$lambda.min, type="class")

予測精度は

   pred1
    C P S
  C 5 0 2
  P 5 2 0
  S 1 0 6

ピュア(P)の曲の推定精度が非常に悪い。スマイル(S)クール(C)はなかなか健闘しているのではないか。
既存曲のラベルは

cbind(musics[idx, c(1, 3)], pred1)
                                  V1 V3 1
1              僕らのLIVE 君とのLIFE  S S
2                愛してるばんざーい!  S S
6                     Oh,Love&Peace!  S S
7                   乙女式れんあい塾  P C
9                    告白日和、です!  P C
12           知らないLove*教えてLove  C C
14               sweet&sweet holiday  P C
15                     Snow halation  C S
17                      soldier game  C C
20             夏色えがおで1,2,Jump!  S S
22             baby maybe 恋のボタン  P P
23               Mermaid festa vol.1  C C
24 Mermaid festa vol.2〜Passionate〜  S S
27       もぎゅっと“love”で接近中!  P C
29                  友情ノーチェンジ  P C
30                      ラブノベルス  S S
33                    Wonderful Rush  C S
34                  僕らは今のなかで  S C
35                輝夜の城で踊りたい  C C
36              きっと青春が聞こえる  P P
37                        WILD STARS  C C

本題の未登場曲の推定は

pred2 <- predict(glmnet1, ctm0@gamma[-idx,], s=cv.glmnet1$lambda.min, type="class")
data.frame(as.character(musics[-idx, 1]), pred2)
1              愛は太陽じゃない?  C
2    あ・の・ね・が・ん・ば・れ!  C
3         ありふれた悲しみの果て  S
4       恋のシグナルRin rin rin!  C
5                   孤独なHeaven  P
6             Someday of my life  S
7                     純愛レンズ  S
8                 スピカテリブル  C
9                      Darling!!  S
10  ダイヤモンドプリンセスの憂鬱  P
11        ぶる〜べりぃ▽とれいん  C
12     まほうつかいはじめました!  S
13          もうひとりじゃないよ  C
14                  勇気のReason  C
15                 Love marginal  C
16              私たちは未来の花  S
17             これからのSomeday  C
18            ススメ→トゥモロウ  S
19                  START:DASH!!  C
20                No brand girls  C
21                   Wonder zone  C