この記事はR Advent Calendar 2013の12月29日の配当記事です。
境界の彼方というアニメで私の大好きな種田梨沙さんがメインヒロインである栗山未来を演じている。
作中で「不愉快です」というセリフが口癖らしく、いたるところで出てくるが、このセリフ、栗山未来以外にも他のキャラがしゃべるシーンがいくつかある。
というわけでRを使ってこのセリフが音響学的に判別できるかやってみる。イメージとしては、
音声取り込み→統計量抽出→判別性能解析→結果→反省→ドヤ顔
という流れでやる。
音声の取り込みは昔やったようにパッケージがあるのでそれを使う。全12話のうち、栗山未来が33回、名瀬博臣(CV:鈴木達央)が1回、神原秋人(CV:KENN)が2回、伊波桜(CV:豊田萌絵)が4回セリフを言っている(厳密には『不愉快』や『不愉快だ』なので、音声サンプルを厳密に揃えるのは難しい)。
特徴量抽出にはseewaveパッケージのcovspectro関数を使う。ふたつの異なるスペクトラムを比較してCross-Covariance(CC)なるひとつの統計量を算出してくれるらしい。引用の成書が学内の図書館(一番遠い)にあるらしいのだが借りに行けてないのでとりあえず使う。
本気でやりたかったらPythonで音声信号処理というのが詳しく、RにもtuneRパッケージにmelfccというケプストラム分析のための関数があるのでこちらをがんばってなんとかしてほしい。
40のセリフがあるので、これをがんばって通りCCを計算する。一回の計算にものすごい時間がかかるので、並列計算にするのもいいだろう。
さて、ここで、栗山未来(CV:種田梨沙)と栗山未来(CV:種田梨沙)のセリフの比較は真陽性としての統計量であり、栗山未来(CV:種田梨沙)と他3人のセリフの比較は真陰性としての統計量になる。陽性と陰性の集団になんらかの検査を行い、なんらかの統計量が出るとき、その検査の判別性能はROC解析で判定できる。pROCパッケージがDeLong検定、感度判定など含めていろいろできて使いやすいと思う(BMC Bioinformatics 2011, 12:77)。
結果としてはROC曲線の曲線下面積(AUC)で見ると、0.6もいかないという不甲斐ない結果に終わった。AUCが1だと感度・特異度ともに100%に近い素晴らしい判別性能で、逆に0.5に近いとコイン投げして適当に決めた(ランダム)ものと等しくてじゃあなぜこの検査したの?ということになる。今回CCを用いた判定はこんな感じで、いいものとは言えない結果になってしまった。
普通に考えれば男女の声の聞き分けは人間が聴いても普通にできるわけで、今回何がダメだったかというと、CCの算出というものがそもそも判別に適した解析なのかという問題がある。covspectro関数の説明には
This function tests the similarity between two spectrograms by returning their maximal covariance and the time shift related to it.
とあるが原著を当たってないのでsimilarityとはなんぞや?という疑問が残る。
また、先にも挙げた、セリフが厳密には揃っていない問題や、BGMや環境音といったノイズの存在をとりあえず放置してやったのでこんな結果になった。ノイズの消去では独立成分分析とかがヒットするのでここらへんもいつかやりたい。
ドヤ顔
声優統計第三号、完売しました。
library(seewave) library(sound) library(tuneR) cv <- c(rep(1, 19), 2, rep(1, 5), 3, 1, 1, 4, 4, 1, 4, 1, 4, 1, 1, 1, 1, 3, 1) # セリフを喋ったキャラ charname <- c("栗山未来", "名瀬博臣", "神原秋人", "伊波桜")[cv] # wavファイルの読み込み wavdir <- "/dir/" # wav のあるディレクトリ wavs <- mapply(readWave, paste(wavdir, seq(40), ".wav", sep=""), SIMPLIFY=FALSE) # parallel computing library(foreach) library(doSNOW) cl <- makeCluster(4, "SOCK") registerDoSNOW(cl) cmb1 <- combn(40, 2, simplify=FALSE) # 組み合わせパターン mat <- diag(1, length(cmb1)) # Cross-variance matrix dimnames(mat) <- list(charname, charname) res <- foreach(i = seq(cmb2), .combine=c, .packages="seewave") %dopar% { w <- list(wavs[[ cmb1[[i]][1] ]], wavs[[ cmb1[[i]][2] ]]) w <- lapply(w, head, n=min(sapply(w, nrow))) # 長さが違うと計算してくれないので cc <- covspectro(w[[1]], w[[2]], f=f, n=23, plot=FALSE) res0 <- cc$covmax res0 } mat[lower.tri(mat)] <- res # ROC解析 mat <- as.matrix(read.csv("covspectro.csv")) auc <- rep(0, length(unique(cv))) rocs <- vector("list", length(unique(cv))) idx <- c(300, 130, 435, 370) # ROC曲線のどこらへんから伸ばすか xp <- c(0.1 , -0.1, 0.1, 0.16) # 線のx座標への伸ばし具合 yp <- c(0.25, -0.2, 0.08, 0.16) # 線のy座標への伸ばし具合 adj <- list(c(0.5, -0.4), c(0.5, 1.4), c(0.5, -0.4), c(0.5, -0.4)) # textの位置微調整 lty <- c(1,3,2,6) cols <- c("black", "red", "blue", "green") leglabel <- c("全員", "名瀬博臣", "神原秋人", "伊波桜") for(i in unique(cv)){ taneda1 <- mat[cv==1, cv==1] # 種田同士 if(i == 1){ taneda2 <- mat[cv==1, cv!=1] # それ以外 } else { taneda2 <- mat[cv==1, cv==i] # 特定の誰か } cc1 <- taneda1[upper.tri(taneda1)] cc2 <- c(taneda2) library(pROC) roc1 <- roc(unlist(mapply(rep, 1:2, sapply(list(cc1, cc2), length))), c(cc1, cc2)) rocs[[i]] <- roc1 auc[i] <- roc1$auc if(i == 1){ par(mar=c(5, 4.5, 4, 2)) plot(roc1, cex.lab=2, cex.axis=1.6, lty=1 ,lwd=3) coords(roc1, "best", "threshold") } else { lines(roc1$specificities, roc1$sensitivities, lty=lty[i], col=cols[i], lwd=3) } j <- idx[i] x0 <- rocs[[i]]$specificities[j] y0 <- rocs[[i]]$sensitivities[j] segments(x0, y0, x0+xp[i], y0+yp[i], lty=lty[i], lwd=3, col=cols[i]) text(x0+xp[i], y0+yp[i], leglabel[i], cex=1.8, adj=adj[[i]]) } legend("bottomright", legend=paste(leglabel, round(auc, 3), sep="\t"), title="AUC", bty="n", cex=1.8)