トピックモデルを使ってラブライブの歌を解析したのだが、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