昔、声優統計でDTMをしたのだが、その下準備に初音ミクでDTMをしようとしてしたはいいけど結果を書いてなかったので書く。
結果としてはよくわからんがこんな感じのトピックを抽出した。
Topic 6: 元気な歌?
タ,意味,とか,かご,分かる,穴,気がつく,se,なんか,control,大切,度,考える,それでも,たり,や,死ぬ,鼓動,すぎる,ちゃう,気分,くらい,カナ,☆),じゃう,聞く,嫌,呼吸,気づく,こす,かも,ノ,能力,違う,捨てる,し,閉じる,文字,ミックス,醒める,)」,だけど,仲間,ぼる,痛み,ちゃ,キライ,冗談,強い,欲しい
Topic 8： 切ない想いを伝える別れの歌?
伝える,!!!!,一緒,男,とき,会う,幼い,燃える,会える,通り過ぎる,絶対,素敵,舟,さようなら,朝焼け,願う,悲しい,出会う,言える,...?,思い,町,呟く,度,そろそろ,過ぎる,奥,彼,見つめる,続く,季節,切ない,歩む,癒す,関係,これから,届け,どんな,濡らす,願い,幾つ,楽しい,おしゃれ,♯,旅立つ,溢れる,仕草,約束,人形,♪
Topic 13： また元気な歌?
うま,瞳,震わせる,求める,重なる,庭,入り込む,燃やす,肩,映る,溶かす,!!!,夕焼け,無限,揺れる,見つめる,草原,ヒトリ,語りかける,凍える,カラ,森,帰る,近づく,雫,叫ぶ,動ける,ドリル,高鳴る,溢れる,願う,重ねる,おいしい,定め,ほど,沈む,お願い,濡らす,姿,目と,窓,決める,オレ,震える,波,かご,悲しみ,一つ,白い,意味
Topic 9： みんなでドンチャンな歌?
なぁ,みんな,わ,ちゃう,ちょっと,タ,クマ,ぼる,夏,動画,とか,たのしい,下手,し,寝る,光景,全然,飲む,こける,大切,ニコニコ,涼しい,ちゃ,展開,子,いったい,たどり着く,だけど,書く,戻る,右,キライ,とても,刻み付ける,なんか,たり,大根,ちゃんと,兄ちゃん,マンガ,過ぎ行く,居場所,酒,や,でる,儚い,朝,すぎる,水,じゃう
Topic 18： ボーカロイドの運命的な歌?
ー,~,ら,ボーカロイド,オチ,ハーモニー,!!,り,ふる,リン,誰か,またがる,うまい,!」,じ,j,ちゃう,うた,るり,すぎ,たれる,儚い,歩,!(,タ,ブレーキ,き,仲良く,強引,+,はるか,あんた,わ,アイドル,す,よる,:,いう,w,大根,~♪,クール,様,えっ,f,カラダ,押入る,兄ちゃん,みんな,混ぜる
Topic 11： 中二病的な歌?
幾,妊娠,革命,ちょい,教え,一度,もしかして,シマ,塗る,千,何もかも,人気,七,記載,脳,感,冗談,香港,愛す,見飽きる,☆),使徒,遅れる,履く,内,卒,臨界,ステレオ,三,スキ,六,沢,実体,タイムリミット,テーブル,いびつ,jealousy,超絶,点く,まもる,り,転載,吹き荒れる,十,壁,賭ける,ぎゅっと,ふらり,プルプル,からくり
Topic 2： 大自然でオシャレな歌?
輝く,...?,高い,元,描く,濡らす,雲,日差し,進む,ふわふわ,続く,草原,おしゃれ,向こう,浮く,バラ,作れる,見上げる,っていう,希望,目指す,限り,影,届ける,新しい,ファン,麦わら帽子,もうすぐ,歩む,叫べる,燃やす,ささやか,きらきら,満ちる,見つける,虹,窓,決める,さあ,溶け合う,もぐ,願い,果て,乗せる,やっと,え,羽ばたく,すぐ,勇気,打ち寄せる
初音ミク解析を実行してmusic_info.txtがあるとして
data0 <- read.csv(paste(wd, "music_info.txt", sep=""), header=FALSE, encoding="utf-8") # data 読み込み submit_data <- read.delim(paste(wd, "count_info.txt", sep=""), header=FALSE) colnames(submit_data) <- c("nicoID", "view", "comment", "mylist", "post") submit_date <- as.Date(gsub("/", "-", submit_data[, 5])) music_info <- read.csv(paste(wd, "music_info.csv", sep=""), header=FALSE) colnames(music_info) <- c("ID", "title", "nicoID", "song", "music", "arrenge", "vocaloid", "lyric") matchID <- match(submit_data$nicoID, music_info[,3]) # 統合したデータ data1 <- cbind(submit_data, music_info[matchID,]) data1 <- data1[order(data1$post),] # 日付順に並び替え lyrics <- as.character(data1$lyric) corpus <- lexicalize(lyrics) vocab0 <- as.character(tfidf0$word[tfidf0$nscore > 0.4]) corpus0 <- lexicalize(doclines=lyrics, vocab=vocab0) #TFIDFスコアで選出した語彙 corpus <- list(documents=corpus0, vocab=vocab0) multi_convert <- function(lex){ paste(apply(lex, 2, paste, collapse=":"), collapse=" ") } input <- lapply(corpus$document, multi_convert) word_count <- sapply(corpus$document, ncol) multi_dat <- mapply(paste, word_count, input, sep=" ") write.csv(matrix(unlist(multi_dat), nc=1), file=paste("miku_multi_dat.txt", sep=""), row.names=FALSE, quote=FALSE) # DTM用データ # seq.dat の作成 days <- sort(as.Date(submit_data[,5])) birth <- as.Date("07-08-31") qbreak <- birth + seq(0, 6, by=1/4)*365 # 4半期 hbreak <- birth + seq(0, 6, by=1/2)*365 # 半年 ybreak <- birth + seq(0, 6, by=1)*365 # 一年 # 1行目に時系列の数、2行目以降 i 番目の時系列の数 ta <- table(cut(days, hbreak)) file0 <- "seq_half.dat" write.table(matrix(c(length(ta), ta), nc=1), file=file0, row.names=FALSE, col.names=FALSE) # 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中の単語リスト wordfreq <- table(unlist(wordset)) # すべての単語の、全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(res) } tfidf0 <- TFIDF(corpus, progress=TRUE) write.(tfidf0, file="TFIDF_score.txt")
# DTMの解析 lyrics <- as.character(data1$lyric) time0 <- read.csv("miku-seq.dat", header=FALSE)$V1 n_times <- time0[1] # 時系列の数 timeseg <- time0[-1] timerange <- range(as.Date(data1$post)) birth <- as.Date("07-08-31") timeidx <- seq(birth, timerange[2], length=12) tfidf0 <- read.csv(paste(wd, "TFIDF_score.csv", sep="")) word0 <- as.character(read.csv(paste(wd, "score04word.txt", sep=""))$x) # TFIDFでスコア0.4以上のものを選んでいるはず # e-log のあるディレクトリ file0 <- list.files()[grep("e-log", list.files())] topicdtm <- array(0, c(length(word0), n_times, length(file0))) # term, time, topic for(i in seq(file0)){ topicdtm[,, i] <- exp(matrix(scan(file0[i]), ncol=n_times, byrow=TRUE)) } corpus <- lexicalize(lyrics, vocab=word0) lda0 <- lda.collapsed.gibbs.sampler(corpus, 30, word0, 25, 0.1, 0.1) toptopis <- top.topic.words(lda0$topics, 50, by.score=TRUE) tmptopic <- match(toptopis[, 1], cor0$vocab) # トピックごとの上位単語 mapply(function(x) apply(apply(topicdtm[, , x], 2, order, decreasing=TRUE), 2, head, 50), seq(n_times)) L <- list(word=array(0, c(50, n_times, 30)), prob=array(0, c(50, n_times, 30))) for(i in seq(n_times)){ for(j in seq(30)){ idx <- head(order(topicdtm[, i, j], decreasing=TRUE), 50) L$prob[, i, j] <- topicdtm[idx, i, j] L$word[, i, j] <- word0[idx] }} # 各トピック、時系列で再生数の最も多い代表曲を確かめる n_music <- 2 # 再生数の多い上位2曲 result <- array(0, c(n_music, 3, n_times, 30)) saisei <- 393939 for(t0 in seq(30)){ for(d0 in seq(timeseg)){ label0 <- which(docgroup == d0) topmusic <- apply(e.theta[label0,], 2, order, decreasing=TRUE) y0 <- head(which(data1[label0,][topmusic[,t0], "view"] > saisei), n_music) # 再生数の多い上位2曲 #print(as.character(data1[label0,][topmusic[,1], "title"][y0])) result[,,d0,t0] <- as.matrix(data1[label0,][topmusic[,t0], c("view", "post", "title")][y0,]) }} # プロットする plottopic <- 7 cols <- rainbow(plottopic) topicdiffidx <- order(apply(apply(probsum, 2, range), 2, diff), decreasing=TRUE) yl <- range(c(0, probsum[, head(topicdiffidx, plottopic)])) matplot(probsum[, head(topicdiffidx, plottopic)], xlim=c(0.2, n_times+1.5), ylim=yl, col=cols, lty=1, lwd=5, type="l", xaxt="n", ylab="topic proportion", bty="l") axis(1, at=seq(n_times), label=timeidx, las=2) y0 <- probsum[n_times, head(topicdiffidx, plottopic)] y0[c(4,6)] <- y0[c(4,6)] + c(0.005, -0.003) text(rep(par()$usr[2], plottopic), y0, paste("Topic", head(topicdiffidx, plottopic)), xpd=TRUE, adj=0.7, col=cols, cex=1.2) title("Change of topic proportion", cex.main=2) for(t0 in head(topicdiffidx, 7)){ for(d0 in seq(n_times)){ text(d0, probsum[d0, t0], paste(result[,3,d0,t0], collapse="\n"), cex=0.8, xpd=TRUE) # 上位の歌 }}
