経緯
この減衰曲線はどういう関数で説明するのが適切か考えている（指数関数ではない）https://t.co/PYdROur8XJpic.twitter.com/nFkikWjH1x
— イスカリオテの湯葉 (@yubais) 2016年3月1日
1話をチラ見して半分はそのまま帰り、半分は2話目を読む。うち3/4が3話目まで進み、さらに5/6が4話目も読む。7話くらいまで読むとだいたい最後まで読む。あと最終話だけ見る人が結構いる
— イスカリオテの湯葉 (@yubais) 2016年3月1日
はじめに：とりあえず棒グラフ
まずは rvest で 横浜駅SF（イスカリオテの湯葉）のアクセス数 - カクヨムからPV数のデータを抜き出してきます。
library(rvest)library(pipeR) read1 <- read_html("https://kakuyomu.jp/works/4852201425154905871/accesses") tab1 <-html_table(read1) tab2 <-strsplit(tab1[[1]]$X2,"\n") tab3 <-do.call("rbind",tab2) PVchar <-gsub(",","",tab3[,1]) dat <-data.frame(number=1:length(PVchar),title=tab1[[1]]$X1,PV= as.integer(PVchar))
横浜駅SF、各話のPV数は下図の通りです。
装飾的な要素を廃した棒グラフは次の図です。
各エピソードに上から順に通し番号をふっています。
モデルと推定
閉じた形の関数で説明するのは諦め、確率モデルを考えました。
PV数は、
エピソード iのPV 数（）= 移入数（
）+ 前エピソードからの遷移（
）
という形に分解できると仮定しました。
移入数はそのエピソードから閲覧を開始するPVの数です。前エピソードからの遷移は前エピソードのPV数に遷移する割合（）を乗じた形で表すことにします。
PV数の分布はポアソン分布を仮定しました。
となりあったエピソードは条件が近いだろう、ということから、の事前分布は平均
の正規分布、
の事前分布は平均
の正規分布を仮定しました。
無情報事前分布として、正規分布の分散は幅の広い一様分布を仮定しました。
モデルを記述した Stan のコードはこれです。
data { int<lower=1> N_site; int<lower=0> Y[N_site];} parameters { real r[N_site]; real p0[N_site]; real<lower=0,upper=1e+7> s_r; real<lower=0,upper=1e+7> s_p;} model { Y[1]~ poisson_log(r[1]);for(j in2:N_site){ r[j]~ normal(r[j-1], s_r); p0[j]~ normal(p0[j-1], s_p); Y[j]~ poisson(exp(r[j])+inv_logit(p0[j])*Y[j-1]);}} generated quantities { real<lower=0, upper=1> p[N_site]; real<lower=0> expr[N_site]; real<lower=0> Y_mean[N_site];for(j in1:N_site){ expr[j]<- exp(r[j]); p[j]<- inv_logit(p0[j]);} Y_mean[1]<- exp(r[1]);for(j in2:N_site){ Y_mean[j]<- exp(r[j])+inv_logit(p0[j])*Y[j-1];}}
R から Stan を操作します。
dat4stan <-list(Y=dat$PV,N_site=nrow(dat))library(rstan) model1 <-stan_model("~/Documents/dotR/yokohamamodel.stan") rstan_options(auto_write =TRUE) options(mc.cores = parallel::detectCores()) fit1 <-sampling(model1,dat4stan,iter=6000,warmup=5000, control=list(adapt_delta=0.9,max_treedepth=15))#traceplot(fit1,c("s_r","s_p"))#traceplot(fit1,"p0")#traceplot(fit1,"r") Y_mean <-get_posterior_mean(fit1,"Y_mean")[,5] expr <-get_posterior_mean(fit1,"expr")[,5] p <-get_posterior_mean(fit1,"p")[,5] expr <-get_posterior_mean(fit1,"expr")[,5] ggplot(dat)+ geom_bar(aes(x=number,y=PV),stat ="identity",fill="grey60")+ geom_line(aes(x=number,Y_mean),colour="blue",size=1)+ geom_line(aes(x=number,expr),colour="red",size=1)+ scale_y_continuous(labels=comma)
当てはめた結果は下図のようになりました。
赤い線は移入数、青い線は移入数と前エピソードからの遷移をあわせたPV数の推定値です。
考察
係数 は全エピソードから遷移してくる割合を示しているため、
は離脱率（そのページで読み進めるのをやめる割合）と解釈できます。
各エピソードの離脱率とその95%信用区間は下図のようになりました。
ex <-extract(fit1) upper_p <-apply(1-ex$p,2,function(x)quantile(x,0.975)) lower_p <-apply(1-ex$p,2,function(x)quantile(x,0.025)) ggplot(dat)+ geom_bar(aes(x=reorder(title,-number),y=1-p),stat ="identity",alpha=0.6)+ geom_errorbar(aes(x=rev(number),ymin=lower_p,ymax=upper_p),colour="red")+ coord_flip()+ xlab("")+ylab("離脱率")+ scale_y_continuous(labels=percent)
序盤は離脱率が高く徐々に離脱率は下がっていくのですが、12話、16話、21話など、ちょこっと離脱率が高くなっているエピソードも見受けられます。
そのあたりがユーザーが疲れてくるタイミングなのかもしれません。
各エピソードの移入数とその95%信用区間は下図のようになりました。
upper_r <-apply(ex$expr,2,function(x)quantile(x,0.975)) lower_r <-apply(ex$expr,2,function(x)quantile(x,0.025)) ggplot(dat)+ geom_bar(aes(x=reorder(title,-number),y=expr),stat ="identity",alpha=0.6)+ geom_errorbar(aes(x=rev(number),ymin=lower_r,ymax=upper_r),colour="red")+ coord_flip()+ xlab("")+ylab("移入数")+ scale_y_continuous(labels=comma)
やはり最終話から読みはじめるユーザーがけっこういるようです。
アマゾンアフィリエイトのコーナー
- 作者:R.A.ラファティ,R.A. Lafferty,柳下毅一郎
- 出版社/メーカー:河出書房新社
- 発売日: 2016/04/06
- メディア:文庫
- この商品を含むブログを見る
ぼくの好きなSF『地球礁』です。
子どもたちが韻を踏んだ詩で人を殺す話です。
訳文もリズミカルで読みやすいです。
買ってください。よろしくお願いします。