声優言及数における「ブレイク」考察

今日は仕事が暇だったのでWebラジオをチェックしたりしてて、それでも暇だったので声優言及数調査の「ブレイク」をどうするかについて考えていました。単純な増加数では元々言及数の多い人の変動が大きく出てしまってブレイクにならないし、かといって増加率*1にすると「言及数1→言及数10」みたいな人がブレイク扱いになってしまう。

そんなわけで今年の(2010年分の)調査はpercentileの増加分を考慮してみたのですが、それでも全員のデータをマージして計算したせいなのか、この指標もイマイチだったようで。ちなみに降順ソートするとこんな感じ。

名前	平均増加％
東山奈央	5.2
原紗友里	5.1
早見沙織	4.7
三森すずこ	4.6
佐々木未来	4.5
金元寿子	4.4
高森奈津美	4.4
佐倉綾音	4.3
原由実	4.1
水瀬いのり	3.8

増加率でソートした場合と同じく、元々言及数の極端に少ない層が出てきてしまってる感じ。

で、今日は言及数のグラフを見つつ、適当なモデルないかなーと思いつつ、ダラダラと考えていたのですが、ポワソン分布の形が似てるなーということにふと気づいたのでした。考えてみれば、言及数も単位時間当たりのサービス数と考えられなくないので、ポワソン分布に従ってもおかしくない、かな？

と言うことでざっくりと当てはめてみる。基本的な集計データ(sy.data.m, sy.stats.m)はこちらのコードを流用しています。

2010年声優言及数作業メモ（４）データ集計からグラフ出力まで、のコード - XXXannex

s    <- "竹達"
n    <- grep(s, sy.data.m[,1])
l    <- as.integer(sy.data.m[n,])[14:25]
m    <- mean(l[l>0])
name <- as.character(sy.data.m[n,1])
lp   <- c(11+3,25) * sy.stats.m[n,]$a + sy.stats.m[n,]$b
lpp  <- ppois(lp, m)

plot(ppois(0:max(l), m), xlab="count", ylab="probability")
points(lp, lpp, col="red", pch=16)
segments(lp[1],lpp[1],lp[2],lpp[2], col="red")

まずは竹達彩奈さん。赤線の部分は、線形回帰で推定した1月と12月の言及数です。

言及数160あたりに急激な上昇があって、このあたりが「ブレイクの壁」と考えてよさそう。

もうひとつの例は日笠陽子さん。壁を越えかけたのですが・・・もう少し！惜しい！みたいな。

あとは2010最大の特異点・東山奈央ちゃん。平均をmean(l)でなくmean(l[l>0])にしたのは、この子のせいです。言及数0は除外したほうが期待通りの結果になるみたい。

結構うまく動いてるようなので、ざっくりtop20を出してみる。

sy.stats2 <- function(df, df.range=11:25, df.x=df.range){
  ddply(df, .(keyword), function(x){
    # linear regression
    df.coef <- lm(as.numeric(x[df.range]) ~ df.x)$coefficients

    # difference in poisson distribution
    l   <- as.integer(x[14:25])
    m   <- mean(l[l>0])
    lp  <- c(14,25) * df.coef[2] + df.coef[1]
    lpp <- ppois(lp, m)

    data.frame(a=df.coef[2], b=df.coef[1], p1=lpp[1], p2=lpp[2], pp=diff(lpp))
  })
}
sy.stats.m   <- sy.stats2(sy.data.m,  11:25)

> head(sy.stats.m[sort.list(sy.stats.m$pp, dec=T), c(-2,-3)], 20)
       keyword           p1        p2        pp
160   早見沙織 8.632676e-08 0.9999966 0.9999966
254   竹達彩奈 8.043319e-07 0.9999444 0.9999436
291   金元寿子 6.756521e-06 0.9996185 0.9996118
101   寿美菜子 6.381105e-04 0.9943907 0.9937526
29  中村繪里子 4.170721e-03 0.9928974 0.9887266
107   小林ゆう 7.848374e-04 0.9866453 0.9858604
13  三森すずこ 6.312738e-03 0.9750250 0.9687123
271     藤村歩 7.616573e-03 0.9756198 0.9680032
152   新井里美 6.168692e-03 0.9722706 0.9661019
161   明坂聡美 1.473225e-02 0.9740763 0.9593441
70      原由実 7.611096e-03 0.9660794 0.9584683
46  佐々木未来 4.893531e-03 0.9589741 0.9540805
216   清水香里 2.386919e-02 0.9636847 0.9398155
220 片岡あづさ 1.742821e-02 0.9563895 0.9389612
117 小見川千明 2.012171e-02 0.9583597 0.9382380
228   田口宏子 2.025672e-02 0.9573341 0.9370774
71    原紗友里 2.508493e-05 0.9197602 0.9197352
139   徳井青空 2.963616e-02 0.9466504 0.9170142
211   浅倉杏美 1.292039e-02 0.9020589 0.8891385
156   日笠陽子 8.213226e-03 0.8871586 0.8789454

ふーむ。公開した結果と概ね近い感じになるもんだね。やはり、竹達・早見ではなく、早見・竹達の順番になってしまうかー。あっちで公開したのは、どうにかして竹達を1位にしたいという邪なアレでもって操作した感があったからなあ。そして東山奈央ちゃん、佐倉綾音ちゃんは消えてしまうと。切ない。

それはともかく。思いつきでやったモノの中では結構うまく行ったほうかも。あと問題があるとすれば、1月分と12月分の推定言及数を線形回帰で求めてしまってよいものだろうか・・・？という部分ですね。言及数の増加自体は線形っぽい感じではあるので、まあ悪くは無いんだろうけど。これもうまいモデルがあれば。。

おまけ

元調査のトップ10に対してグラフを作ってみました。ポワソン分布を線で結んでるのは見た目重視と言うことで・・・。

ggplot2で画像を保存するときに、画像の大きさとフォントサイズがうまいこと変更できないので諦めた。やはりggplot2はめんどくさすぎるわ。

s  <- c("竹達彩奈", "早見沙織", "金元寿子", "寿美菜子", "小林ゆう", "東山奈央", "日笠陽子", "明坂聡美", "藤村歩", "新井里美")
nn <- sapply(s, grep, sy.data.m[,1])
for(i in 1:length(nn)){
    n    <- nn[i]
    name <- names(n)
    l    <- as.integer(sy.data.m[n,])[14:25]
    m    <- mean(l[l>0])
    lp   <- c(11+3,25) * sy.stats.m[n,]$a + sy.stats.m[n,]$b
    lpp  <- ppois(lp, m)
    
    q <- qplot(lp, lpp, geom=c("point", "line"), colour="red", xlab="count", ylab="probability", main=sprintf("poisson model : %s", name))
    q <- q + geom_line(aes(x=0:max(l), y=ppois(0:max(l), m)), colour="#1E5692")
    q <- q + geom_text(aes(x=1, y=0.85, label=sprintf("diff=%.2f",lpp[2]-lpp[1]), colour="black"), hjust=0, vjust=0)
    q <- q + scale_colour_identity()
    q <- q + opts(legend.position = "none")

    ggsave(q, file=sprintf("pp_%s.png", name), pointsize=8, width=4.8, height=3.2)
}