注意：この記事は大好評放送中のハロー!!きんいろモザイクと最近話題のDeep learning をかぶせて話題沸騰!!にしたかったけれども、きんいろモザイクに出ている声優のサンプルボイス(東山奈央)が入手できず、DNNについても結局実装が間に合わずにrandom forestとか多項ロジスティック回帰でごまかしてるじゃんｪ…と思ったらなんとかDNNできたので半分タイトル詐欺です。
感動した。
ご注文はDeep Learningですか？ - kivantium活動日記
ここではOpenCV を用いて顔認識をして、そのデータをDNNに流して主要キャラ+その他判定をしている。
ならば、声優統計を修める者としては、音声解析の技術を用いて
誰が今歌っているのかを識別したい。
これをDNNの技術を用いてやってみる。
やり方としては、
サンプルボイスの収集→統計量の作成→学習→学習器の性能評価→推定→動画作成
という感じでやる。
サンプルボイスの収集
きんいろモザイクのキャストは西明日香、田中真奈美、種田梨沙、内山夕実、東山奈央の5人だが、東山奈央のサンプルボイスがなかったので、代替案としてご注文はうさぎですか?の水瀬いのり、佐倉綾音、種田梨沙、佐藤聡美、内田真礼のサンプルボイスを集めた。
BGMがないものを採用し、無音領域は適当にカットした。
統計量の作成
とりあえずメルケプストラムを採用した。12次元とってきて、時間変化の動的特徴量と合わせて1フレーム 10 msec あたり24次元のデータが入力となる。
学習
とりあえずRでも使えるh2oを使ってみる。パラメータの調整はi5, 8GB RAM のレッツノートでは全くうまく行かなかったよ…
入力データは5人のメインキャラ+その他の6ラベルが50000ずつのフレームとした。
その他というのはBGMや他の声優の声ということで、前回の解析で使ったボイス集からサンプリングした。
計算機資源のしょぼさを反省しており、現在はGPUPCを使えるように申請中で、TheanoやCaffeを使ってさらに高速な感じでできればいいなと思う。
# Deep learning library(h2o) # deep learning のための接続 localH2O <- h2o.init(ip = "localhost", port = 54321, startH2O = TRUE, nthreads=-1) # dat_tr は1列目がラベル、2列目以降が入力ベクトルのひらすらでかいデータ # 読み込み h2o_tr <- h2o.importFile(localH2O, path = "dl_train_mel.csv") h2o_ts <- h2o.importFile(localH2O, path = "dl_test_mel.csv") df_tr <- as.data.frame(h2o_tr) df_ts <- as.data.frame(h2o_ts) # これくらいが計算時間の限界 dl <- h2o.deeplearning(x = 2:ncol(df_tr), y = 1, data = h2o_tr, activation = "Tanh", hidden=rep(1000, 3), epochs = 5, rate=0.01) pred.dl <- h2o.predict(object=dl, newdata=h2o_ts) p <- as.data.frame(pred.dl)$predict table(p) v <- as.data.frame(h2o_ts$V1)$V1 mat <- table(v, p) sum(diag(mat))/length(v)
学習器の性能評価
テストデータは6ラベル10000ずつのフレームを用意した。とりあえず同じように分類できたかを割合で出すということで。
結果は70%くらいの分類能だった。
Minase_Inori Sakura_Ayane Taneda_Risa Sato_Satomi Uchida_Maaya Other Minase_Inori 9655 72 29 33 11 59 Sakura_Ayane 64 9478 97 5 168 169 Taneda_Risa 194 323 8999 42 99 297 Sato_Satomi 292 59 24 9425 8 72 Uchida_Maaya 91 814 191 21 8532 305 Other 6829 14666 9350 1451 4508 50331
推定
predict するだけ。10 msec ごとに推定されて、最も確率の高いキャラが推定される。混声の場合はそれぞれの確率で混合されていると考えると
初っ端から圧倒的種田率()
predict Minase_Inori Sakura_Ayane Taneda_Risa Uchida_Maaya Sato_Satomi Other Taneda_Risa 0.0188608989 0.1630974859 0.8161082864 0.000003831 0.000003944 0.0019255573 Taneda_Risa 0.0069014449 0.0141900461 0.9757663012 4.78813080917462E-006 0.000431119 0.0027063172 Taneda_Risa 0.0010154428 0.2572121322 0.7388253808 2.58052859862801E-005 0.0002405713 0.0026806884 Sakura_Ayane 0.0272961222 0.9442297816 0.0271465927 4.11001019529067E-005 0.0002363344 0.0010500529 Taneda_Risa 0.1239169091 0.0305609833 0.8443024158 3.30391935676744E-006 3.27450834447518E-006 0.0012130789 Taneda_Risa 0.0202784631 0.3523899317 0.6195970774 0.000002033 3.84907465900142E-008 0.007732505 Taneda_Risa 0.0186102167 0.0161491111 0.9485545754 1.07119058156968E-006 2.20463178379759E-007 0.0166848917 Taneda_Risa 0.0865577981 0.1521711946 0.6512304544 1.5910183719825E-005 9.73642386270512E-007 0.1100237072 Taneda_Risa 0.0029677181 0.0482471623 0.9420395494 9.03342788660666E-006 5.52017036170582E-006 0.0067310599
動画作成
Rではanimation パッケージの saveVideo でできて、1フレームあたりの秒数と拡張子指定で時間がかかるけれども完成する。
これ自体には音楽がついていないので、適当な動画編集ソフトで音楽をつける。
ちなみにキャラ画像は公式HPのツイッターからパクってくる。その他は不純物シノにした。
library(png) library(jpeg) library(animation) pngs <- list.files("/cv/pic/", pattern="jpg") # パクってきたツイッター画像を適当にラベル付けしていれておく pics <- mapply(function(x) readJPEG(x, native=TRUE), pngs) ra <- 1 #原点に近いところが潰れるので拡大したかったけど、等倍でやった。 xy0 <- sapply(pics, dim)[1:2, ] #pixel xy0[] <- min(xy0) xy0[2,] <- 1000 # なんか横が潰れるのでテコ入れ rownames(xy0) <- c("height", "width") s0 <- 0.001 #拡大縮小率 cols <- c("pink", "lightblue", "violet", "yellow", "lightgreen", "black") # キャラの色 saveVideo({ ani.options(interval = 0.01, nmax = nrow(dat)) for(j in seq(nrow(dat))){ b0 <- barplot(unlist(dat[j,-1]), ylim=c(0, 1), col=cols, axisname=FALSE, las=1) pa <- par()$usr text(pa[2], pa[4]+0.02, paste(round(j*0.01), "sec"), pos=2, xpd=TRUE, cex=2) lay0 <- cbind(b0, pa[3]-0.09) for(i in seq(pics)){ xleft=lay0[i, 1]*ra - xy0[2, i]/2*s0 ybottom=lay0[i, 2]*ra - xy0[1, i]/2*s0 xright=lay0[i, 1]*ra + xy0[2, i]/2*s0 ytop=lay0[i, 2]*ra + xy0[1, i]/2*s0 rasterImage(image=pics[[i]], xleft=xleft, ybottom=ybottom, xright=xright, ytop=ytop, xpd=TRUE) } } }, video.name = "BM.mp4", other.opts = "-b 300k") # higher bitrate, better quality
動画をアップロードするのは非常にめんどくさかったので時系列プロットにする。
dat <- read.csv("predicted.csv") cvnames <- c("佐倉綾音", "水瀬いのり", "種田梨沙", "内田真礼", "佐藤聡美", "その他") cols <- c("pink", "lightblue", "violet", "yellow", "lightgreen", "black") par(mfrow=c(6, 1), mar=c(2, 4, 2, 2), cex.lab=1.2) for(i in 2:7){ plot(dat[, i], type="l", col=cols[i-1], xaxt="n", xlab="", ylab="Probability", ylim=c(0, 1), las=1) title(cvnames[i-1]) axis(1, at=seq(0, 9000, length=10), labels=seq(0, 90, length=10)) }
完成品がこれ。
h2oの実験の段階から、推定がすべて種田梨沙だったり水瀬いのりになったりでものすごい汎化性能が悪く、入力データでそこそこ精度が高くなってもやっぱりテストデータで汎化性能が悪かった。歌のほとんどが内田真礼かその他で占められているし、佐藤聡美にいたっては1秒以下しかない。
その他のラベルを抜いて同様にやってみたが、まったく改善しなかった。
改善策としては、DNNは特徴量の抽出も行えるというのが売りのひとつになっているから、特徴量として入力したメルケプストラムはたぶんよろしくなかった。というのも、メルケプストラムは人間の耳の特性に非常によく似た、母音の周波数を表すとかなんとかがよくある説明らしく、既に完成(?)された特徴量を入力にしたのはあまりよろしくなかったかもしれない。MFCC features are not suitable. とはこちらでも言われている。というわけで、改善策その1としてはメルケプストラムになる前の、FFTしたくらいのデータでやるのはどうか。FFTしたくらいであれば、周波数はある程度特徴的なピークがとれて、なおかつ2000次元くらい取れるから適当にDNNに放り込んだらなんとかしてくれるっしょ(適当。メルフィルタバンクくらいの処理はかませてもいいか。
もうひとつ、OPのBGMは分離すべきだったかもしれない。独立成分分析はやったけれども、これも前回同様うまく分離できなかった。と思っていたらdeep karaoke(論文)という、いわゆるカクテルパーティ効果をDNNでやりましょう、という話があったのでこれを試して、BGMによるノイズを減らすのも手だろう。
MEDLEYDBという楽曲学習器もあるので、これを使えばたぶん早い。
library(tuneR) library(seewave) library(sound) library(dtt) library(fastICA) library(phonTools) library(e1071) wd1 <- "/cv/cv_deep/" # ごちうさ声優のサンプルボイス wd2 <- "/cv/original/" # その他声優のサンプルボイス f1 <- list.files(wd1, pattern="wav") f2 <- list.files(wd2, pattern="wav") cv_gochiusa <- unique(mapply(function(x) x[1], strsplit(f1, "_silence_"))) wav1 <- mapply(readWave, paste(wd1, f1, sep="")) wav2 <- mapply(readWave, paste(wd2, f2, sep="")) fs <- 44100 msec <- 0.05 # サンプリングの長さ niter <- 10000 # 作成するデータ数 n_frm <- 8 # フォルマント # ごちうさ声優のデータを集める res_mel <- res_frm <- NULL for(cv in seq(cv_gochiusa)){ pb <- txtProgressBar(max=niter, style=3) for(n in seq(niter)){ setTxtProgressBar(pb, n) tmp_mel <- tmp_frm <- NULL i <- sample(grep(cv_gochiusa[cv], f1), size=1) r <- rle(wav1[[i]]@left > 100) # 無音っぽいところは省きたい lidx <- cumsum(r$lengths)[r$lengths < msec*fs] # if(length(lidx) > 1){ cutpoint <- sample(head(lidx, -1), size=1) tmp_w <- extractWave(wav1[[i]], from=cutpoint, to=cutpoint+msec*fs) m0 <- try(melfcc(tmp_w, wintime=0.01, spec_out=TRUE), silent=TRUE) if(class(m0) != "try-error"){ dc <- delta_cepstrum(m0$cepstra, dd=5) tmp_mel <- rbind(tmp_mel, cbind(m0$cepstra, dc)) tmp_mel <- as.data.frame(cbind(cv_gochiusa[cv], tmp_mel)) res_mel <- rbind(res_mel, tmp_mel) } frm <- findformants(tmp_w@left, fs=fs, verify=FALSE) # フォルマント抽出 if(length(frm$formant) >= n_frm){ tmp_frm <- rbind(tmp_frm, head(frm$formant, n_frm)) tmp_frm <- as.data.frame(cbind(cv_gochiusa[cv], tmp_frm)) res_frm <- rbind(res_frm, tmp_frm) } } #print(n) } } write.csv(res_frm, "gochiusa_frm.csv") write.csv(res_mel, "gochiusa_mel.csv") # 別声優データを作る # ごちうさ声優のデータを集める res_mel <- res_frm <- NULL pb <- txtProgressBar(max=niter, style=3) for(n in seq(niter)){ setTxtProgressBar(pb, n) tmp_mel <- tmp_frm <- NULL i <- sample(seq(wav2), size=1) r <- rle(wav2[[i]]@left > 100) # 無音っぽいところは省きたい lidx <- cumsum(r$lengths)[r$lengths < msec*fs] # if(length(lidx) > 1){ cutpoint <- sample(head(lidx, -1), size=1) tmp_w <- extractWave(wav2[[i]], from=cutpoint, to=cutpoint+msec*fs) m0 <- try(melfcc(tmp_w, wintime=0.01, spec_out=TRUE), silent=TRUE) if(class(m0) != "try-error"){ dc <- delta_cepstrum(m0$cepstra, dd=5) tmp_mel <- rbind(tmp_mel, cbind(m0$cepstra, dc)) tmp_mel <- as.data.frame(cbind("Other", tmp_mel)) res_mel <- rbind(res_mel, tmp_mel) } frm <- findformants(tmp_w@left, fs=fs, verify=FALSE) # フォルマント抽出 if(length(frm$formant) >= n_frm){ tmp_frm <- rbind(tmp_frm, head(frm$formant, n_frm)) tmp_frm <- as.data.frame(cbind("Other", tmp_frm)) res_frm <- rbind(res_frm, tmp_frm) } } } write.csv(res_mel, "other_mel.csv") write.csv(res_frm, "other_frm.csv") # melfcc のcepstra 行列をぶち込む形式 # dd は前後いくつ取るか delta_cepstrum <- function(mat, dd=2){ res <- mat dat1 <- mat[c(rep(1, dd) ,seq(nrow(mat)), rep(nrow(mat), dd)), ] x <- seq(2*dd + 1) for(j in seq(ncol(dat1))){ for(i in (dd+1):(nrow(dat1)-dd)){ y <- dat1[(i-dd):(i+dd), j] lm1 <- lm(y ~ x) res[i-dd, j] <- lm1$coefficients[2] } } return(res) }
