ベイズマックスへようこそ。
統計に関するあれやこれやを自由気ままに投稿します。
全記事一覧はこちらから。

2019年12月15日

どの方略が優勢か?:0%と100%を含むパーセントデータの分析 with JAGS

 この記事はStan Advent Calendar 2019の15日目のエントリー記事です。この記事では,「あなたは何%の試行で方略Aを用いましたか?」といった質問項目を実施したときに得られるパーセントデータの分析事例を紹介します。

1. 分析に用いるデータ

 今回分析するデータのヒストグラムを図1に示します。

adcl.hist1.png
図1. 今回の分析に使用するパーセントデータのヒストグラム

 このデータは,筆者が以前行った研究 (Muto, Matsushita, & Morikawa, 2019)で収集したデータの一部です (OSFで公開しています)。詳細は省きますが,この実験では60名の実験参加者 (12名×実験5つ) に2種類の認知課題を遂行してもらったあとで,それぞれの課題において,研究者があらかじめが想定していた方略Aと方略Bについて実験参加者が使用した割合を0%〜100%の範囲で評定してもらいました。測定には図2のような視覚アナログスケール (visual analogue scale) を使用しました。参加者は,0〜100%の線分上の当てはまる位置に縦線を引くことで割合を回答します。データは0〜100の範囲の整数値として記録されました。

adcl.vas.png
図2. 視覚アナログスケールの例 (実際に用いた質問文は論文参照)。

 60名の参加者が課題1・課題2のそれぞれについて方略A・方略Bの使用頻度を評定したため方略Aのパーセントデータは60名×2=120個の要素から成る反復測定データですが,今回は簡単のために対応のないデータとして扱います (つまり,120名の参加者が1回ずつ評定した場合と同じとみなす)。図1のヒストグラムはこれらの120個の値のヒストグラムです。 (ちなみに,ここでいう方略Aとは論文中でegocentric transformation strategyと呼んでいる方略ですが,この記事では単に方略Aと呼ぶことにします。方略Bことmental scanning strategyに関してはこの記事では扱いませんが,方略Bで同じ分析をしても類似した結果が得られると予想されます。)

 図1のヒストグラムの両端 (濃い棒) は評定値がちょうど0%または100%であった参加者の割合を表し,それ以外の薄い棒は[1%, 99%]の範囲のデータについてbinの幅を9としてそれぞれの割合をプロットしたものです。右端の100%のバーがその隣の[91%, 99%]のバーよりも低いのはbinの幅が異なるためであって,100%と回答した参加者が99%と回答した参加者よりも少なかったことを意味する訳ではないので注意。このヒストグラムを見ると,方略Aが用いられた割合は0%付近と100%付近にピークを持ち,かつ0%と100%の値を含んでいることが分かります。つまり,方略Aを使う参加者はほとんどの試行で方略Aを用いるが,方略Aを使わない参加者は一貫して使わない,といった傾向がありそうです (※実際には,参加者の違いではなく実験状況の違いによって方略の使用頻度が二極化すると考えられます)。このようなデータの生成メカニズムを考えるときに真っ先に思い浮かぶのがベータ分布でしょう (図3)。ベータ分布は(0,1)の範囲の実数を実現値として返す確率分布で,非負のパラメータ αβ によって分布の形が様々に変化します。特に 0 < α < 1 かつ 0 < β < 1 のときにはU字型の分布となり,α = β であれば左右対称の分布,α < β であれば0%側に偏った分布,α > β であれば100%側に偏った分布になります。

adcl.betad.png
図3. いろいろなベータ分布。

 この分布を使えば今回のデータをうまく説明できそうな気がしますが,残念ながら両端の0と1に対しては確率密度を定義できない (無限大に発散してしまう) ため,今回のように0%と100%を含むデータに対してはそのまま当てはめることができません。代替案としてゼロワン過剰ベータ分布を使えば恐らくフィッティングはうまくいきますが解釈が困難になります (単純にパラメータが多くなり,しかも評定値が0%になるメカニズムと1%になるメカニズムが質的に異なることを仮定してしまうので,今回のデータには恐らく不適切)。今回のデータをうまく説明するためには一工夫必要なようです。このようなデータの背後にある生成過程を考えてモデルを構築してみましょう。

2. モデル

 今回用いる評定値データは,その前に行った320試行から成る認知課題において方略Aを用いた割合の評定値です。そこでまず,ある実験参加者が認知課題において方略Aを用いる確率を θ と置くと,実際に方略Aを用いた試行の数 ν は,二項分布を用いて

ν ~ Binomial(n = 320, p = θ)

と表現できます。νθ も直接観測することができない未知のパラメータです。さて,もし実験参加者が,自分が方略Aを用いた試行の数 (= ν) と総試行数 (= 320) を正確に知っていれば,実験参加者の評定値は ν / 320 になるはずです。ところが現実的には記憶の曖昧さや評定値の記入の不正確さなどに由来する誤差が生じるはずなので,実際に観測される評定値 Y

Y ~ Normal(μ = ν / 320, σ)

という正規分布に従うと考えることにします。このモデルには離散パラメータの ν が含まれるため,今回はStanではなくJAGSを用いてパラメータの推定を試みます。が,回答誤差のパラメータ σ がうまく収束せず,試行錯誤もむなしく本記事の執筆までに解決することができなかったので,今回は σ を推定せず,σ = 0.0001と決め打ちして αβ を推定することにします (回答の誤差がほとんどないという強い仮定を置くことを意味します)。うまく収束しなかった原因として考えられるのは,(1) σ だけでなく方略Aが用いられる確率 θ にも測定誤差に関する情報が反映されてしまって識別できなかった,(2) 正規分布が誤差分布として適切ではなかった (例えば両端では誤差は小さく50%付近で誤差が最大となるといった仮定を含めたり,[0,1]の範囲に収まるように工夫したりする必要がある?),(3) 筆者がJAGSの仕様をきちんと理解していないためモデルの書き方が悪かった,などがあり得ると思います (原因が分かる方がおられましたら教えて頂けると嬉しいです)。とりあえずこの点には目をつむり,以下のJAGSコードを書いて分析してみました。ちなみにJAGSはStanと比べると収束効率が悪いので,バーンイン期間を (Stanで実装するときよりも) 若干長めにしたり,初期値を明示したりといった工夫をしたほうがよい場合があります。今回はn.chains=4, n.iter=5000, n.burnin=1000, n.thin = 2とし,αの初期値を(0.1,0.3)の一様分布,βの初期値を(0.2,0.4)の一様分布から発生させました。

jagsmodel.txt
model{
	#prior
	alpha ~ dunif(0.0001,2)
	beta ~ dunif(0.0001,2)
	sigma <- 0.0001
	tau <- 1/pow(sigma,2)
	
	#model
	for (i in 1:N){
		theta[i] ~ dbeta(alpha, beta)T(0.00001,0.99999)
		nu[i] ~ dbinom(theta[i], 320)
		Y[i] ~ dnorm(nu[i] / 320, tau)
	}

	#pred
	theta_pred ~ dbeta(alpha, beta)
	nu_pred ~ dbinom(theta_pred, 320)
	Y_pred ~ dnorm(nu_pred / 320, tau)
}

3. 分析結果

 図4は,今回のデータのヒストグラムに事後予測分布を重ねたプロットです。予測分布の[73%,90%]のあたりが実測値よりも若干低めですが,全体的なU字のパターンはうまく表現できているようです。パラメータのEAP推定値はα = 0.15 (95% CI = [0.08, 0.22]),β = 0.26 (95% CI = [0.18, 0.36])でした。α < β なので,100%付近の参加者よりも0%付近の参加者のほうが人数が多いと解釈できます。

adcl.hist2.png
図4. データのヒストグラムとモデルの事後予測分布 (赤の破線)。

4. 発展編:実験条件間の比較

 これだけで終わってしまうのは物足りないので,もうちょっと踏み込んだ分析もしてみました。今回の実験では,理論的に方略Aが優勢になると予想される実験条件Aと,方略Aではなく方略Bが優勢になると予想される実験条件Bの2通りを設定していました。そこで,実際にこの予想が当たっているかどうかを確かめるために,実験条件Aと実験条件Bのそれぞれについて別々に αβ を推定してみました。コードは以下の通り。n.chains=4, n.iter=5000, n.burnin=1000, n.thin = 2とし,初期値は特に明示しませんでした。

jagsmodel_2cond.txt
model{
	#prior
	alpha1 ~ dunif(0.0001,2)
	beta1 ~ dunif(0.0001,2)
	alpha2 ~ dunif(0.0001,2)
	beta2 ~ dunif(0.0001,2)

	sigma <- 0.0001
	tau <- 1/pow(sigma,2)
	
	#model
	for (i in 1:N1){
		theta1[i] ~ dbeta(alpha1, beta1)T(0.00001,0.99999)
		nu1[i] ~ dbinom(theta1[i], 320)
		Y1[i] ~ dnorm(nu1[i] / 320, tau)
	}
	for (i in 1:N2){
		theta2[i] ~ dbeta(alpha2, beta2)T(0.00001,0.99999)
		nu2[i] ~ dbinom(theta2[i], 320)
		Y2[i] ~ dnorm(nu2[i] / 320, tau)
	}

	#pred
	theta_pred1 ~ dbeta(alpha1, beta1)
	nu_pred1 ~ dbinom(theta_pred1, 320)
	Y_pred1 ~ dnorm(nu_pred1 / 320, tau)

	theta_pred2 ~ dbeta(alpha2, beta2)
	nu_pred2 ~ dbinom(theta_pred2, 320)
	Y_pred2 ~ dnorm(nu_pred2 / 320, tau)

	#generated quantities
	phi1 <- log(alpha1 / beta1)
	phi2 <- log(alpha2 / beta2)
}

 実験条件AとBのそれぞれにおける評定値のヒストグラムと予測分布を以下の図5に示しました。ヒストグラムから,条件Aでは方略Aの使用頻度のピークが100%付近にあるのに対し,条件Bでは逆になっていることが分かります。事後予測分布もその特徴をうまく捉えているように見えます。EAP推定値は,条件Aでは α = 1.18 (95% CI = [0.70, 1.77]),β = 0.36 (95% CI = [0.21, 0.52]),条件Bでは α = 0.06 (95% CI = [0.004, 0.14]),β = 0.49 (95% CI = [0.30, 0.75])でした。ここで,αβ の大小関係から分布の偏り度合いが分かるということを利用して,φ = ln(α/β) という生成量を作ってみます。この生成量 φ は,α = β のとき,すなわち方略Aの使用頻度が0%付近と100%付近の両方に等しくピークを持ち分布が左右対称となるときに0と一致します。また,φ が0より小さければ小さいほど0%側に,0より大きければ大きいほど100%側に偏った分布を表します。EAP推定値は条件Aで φ = 1.18 (95% CI = [0.77,1.61]),条件Bで φ = -2.32 (95% CI = [-4.50, -1.33]) でした。これらの結果から,先ほどの予想通り,条件Aでは多くの参加者が方略Aを一貫して用いるのに対し,条件Bでは多くの参加者が方略Aをほとんど使わないということを定量的に示すことができました。

adcl.cond.png
図5. 条件ごとのデータのヒストグラムとモデルの事後予測分布 (赤の破線)。

5. まとめ

 という訳で,この記事では0%と100%を含むパーセントデータのモデリングを試みました。方略Aが課題中に用いられる確率がベータ分布に従うと仮定し,実際に方略Aが何試行で使われたかのメタ認知によって評定値が決まるという発想です。フィッティングするだけならゼロワン過剰ベータ分布や切断正規分布の混合分布などを使うやり方もありますし,例えば0%と100%のデータをそれぞれ1%と99%に置き換えるといった小細工をすれば単なるベータ分布モデルでも似たような結果を得ることはできるのですが,ドメイン知識を利用することで倹約的かつ解釈しやすいモデルを無理なく作ることができうることをこの記事でお示しできたのではないかと思います。σ の推定がうまくいかないという問題もありますし,まだまだ改善の余地はあるはずなので,もう少し吟味してみようと思います。

 以前,某研究会で講演者の方がご自身の論文で報告したデータを再分析してモデリングされていたのを見て,楽しそうだなーと思ったのがこの記事を執筆するきっかけになりました。元の論文 (Muto et al., 2019) では,今回の評定値データはメインの行動データの解釈に役立てるための補助的なデータという位置づけに過ぎなかったので,条件間の平均値差の検定だけしてお茶を濁していました。それはそれで問題ないとは思うのですが,もっと上手な分析方法があるのではないかとずっともやもやしていたというのもあって,この機会に再分析&モデリングを試みたという訳です。この論文のデータはオープンにしているので実は誰でもモデリングをすることが可能です。オープンデータの営みがもっと普及すればモデリングの可能性も広がる気がしてワクワクしますね。

 そしてこの記事を書き終えてから気付いたのですが,この記事は「Stan」 Advent Calendarの記事のはずなのにStan全く使ってねえ……。StanでできないことをJAGSにやってもらったということで許してクレメンス。

引用文献:
Muto, H., Matsushita, S., & Morikawa, K. (2019). Object's symmetry alters spatial perspective-taking processes. Cognition, 191, 103987. https://doi.org/10.1016/j.cognition.2019.05.024

posted by mutopsy at 00:00 | 統計

2019年12月03日

今までに買ったチョコボールの箱数の推定:JAGS・Stan・数値積分による離散パラメータの推定

「おまえは今まで買ったチョコボールの数をおぼえているのか?」

 ……こんなことを聞かれたら,あなたならどう答えますか?「覚えとらんわ」と一蹴するのは簡単ですが,答えられないのはちょっと悔しい。という訳で,この記事では僕が今までに買ったチョコボールの箱数の推定を試みます。

※この記事は,Stan Advent Calendar 2019の3日目のエントリー記事です。

1. チョコボールとエンゼルについて

 改めまして,こんにちは。mutopsyです。冒頭でも説明した通り,この記事では僕が今までに買ったチョコボールの箱数を推定することを目指します。

 チョコボールは森永製菓から発売されている国民的チョコレート菓子の1つです。チョコボールの箱の「くちばし」と呼ばれる開口部には,ごくまれにエンゼルのイラストが印刷されており,銀のエンゼルなら5枚,金のエンゼルなら1枚で「おもちゃのカンヅメ」と交換することができます。金のエンゼルと銀のエンゼルが当たる確率は企業秘密とのことですが,以前12,283箱分のチョコボールデータを用いて推定してみたところ,銀のエンゼルが当たる確率は約3.60% (3.13〜4.10%程度),金のエンゼルが当たる確率は約0.05% (0.02〜0.12%程度) であると推定されました(「たのしいベイズモデリング2:事例で拓く研究のフロンティア」の第1章;過去の記事も参照:[その1] [その2])。今回の分析では,銀のエンゼルが当たる確率についての情報を利用します。

1. 利用可能な情報とモデル

 当然ながら,今までに買ったチョコボールの箱数を推定するためには何らかの情報が必要です。今回僕が注目したのは,今までに当てた銀のエンゼルの数です。これまでに買ったチョコボールの総数そのものはさすがに覚えていませんが,銀のエンゼルが当たるというイベントはそれなりに記憶に残る事象であり,かつ生起頻度も少ないので,それぐらいなら覚えているのも難しくないでしょう。さらにいえば,僕は以前に銀のエンゼルを5枚集めておもちゃのカンヅメと交換してもらったこともあり,そしておそらくそれ以来銀のエンゼルを見かけていないので,これまでに当てた銀のエンゼル数が5枚であることがはっきりしています。そういう訳で,今回の分析では「今までに当てた銀のエンゼルの数は5枚」という情報と「銀のエンゼルが当たる確率は約3.60%」という情報を使って今までに当てたチョコボールの箱数の推定を試みます。ちなみに金のエンゼルを当てたことはありませんが,金のエンゼルが当たる確率は非常に低いため,「今までに当てた金のエンゼルの数は0枚」という情報はあまり役に立ちません。簡単のためにも今回の分析では金のエンゼルの情報については用いないことにします(反対に,「金のエンゼルをn (≧1) 枚当てたことがある」という情報は有用なので積極的に利用すべきです)。

 銀のエンゼルが当たる確率は約3.60%と述べましたが,先に紹介した書籍ではベイズ推定を用いて銀のエンゼルが当たる確率θsilverの確率分布 (事後分布)を計算しました (3.60%という値は事後分布のMAP推定値)。せっかくなので今回は点推定値ではなく分布の持つ情報をフル活用しましょう。この確率分布は以下のベータ分布とほぼ一致します (※書籍の分析では弱情報事前分布を用いたので厳密には一致しませんがほとんど無視できる程度の差です)。

θsilver ~ Beta(α = 351 + 1, β = 9404 + 1)

この分布は,9755 (= 351 + 9404) 箱のチョコボールから351枚の銀のエンゼルを見つけたときに二項分布モデルを用いて推定したθsilverの分布に相当します (一様事前分布を想定した場合)。チョコボールをν箱開封したときに銀のエンゼルがNsilver枚得られる確率は,二項分布を用いて

Nsilver ~ Binomial(n = ν, p = θsilver)

と表現することが可能です。このνが今回推定したいパラメータですね。ただし,νは自然数をとる離散パラメータなので,離散パラメータを直接推定することができないStanを使う場合は一工夫必要になります。そこでこの記事では,まず始めに離散パラメータを推定することができるJAGSを用いた推定法を紹介し,続いてStanで同様の分析を行う方法を説明します。そして最後に,数値積分を用いて正確な事後分布を得る方法も簡単に紹介します。ちなみに今回はNsilver = 5の場合の推定結果を示しますが,他の値を使うことももちろんできますし,Nsilverを確率分布で表現できるようにモデルを拡張することも可能です (例えば,「正確には覚えていないが3〜5枚のいずれかのはず」といった記憶の曖昧さも表現できます)。

3-1. JAGSによる推定

 JAGSはStanと違って離散パラメータを直接推定することができるので,上記のモデルをそのままコードに起こすだけで分析を実行することができます。分析に使用するJAGSコードは以下の通り。

angels_postmodel_jags.txt
model{
	#モデル
	N_silver ~ dbinom(theta_silver, nu)

	#銀のエンゼルが当たる確率の事前分布
	theta_silver ~ dbeta(alpha, beta)

	#今までに買ったチョコボールの数の事前分布(離散一様分布)
	nu ~ dcat(p_each[])
	for (m in 1:Max_nu){
	  p_each[m] <- 1/Max_nu
	}
}

ベータ分布と二項分布を用いて上記のモデルをそのまま書いています。Stanとは異なり変数の宣言は不要です。νの事前分布として十分幅の広い離散一様分布を指定しています。今回は上限 (Max_nu) を1000とします (データとしてRから渡す)。以下のRコードを実行すれば走ります。

JAGSで分析するためのRコード
#以下の環境で動作確認済み
#JAGS4.3.0, R2jags0.5-7, R3.5.2, Windows 10 Pro

#JAGSを下記URLからダウンロードしインストールする必要があります。
# http://mcmc-jags.sourceforge.net/
library(rjags)
library(R2jags)

#銀のエンゼルが当たる確率の事後分布 (ベータ分布) のパラメータ
alpha <- 351 + 1
beta <- 9404 + 1

#今回の分析に必要な情報
N_silver = 5 #今までに当てた銀のエンゼルの数
Max_nu = 1000 #今までに買ったチョコボールの数の上限 (十分大きな値にしておく)

#データの作成
data.post <- list(N_silver = N_silver, Max_nu = Max_nu, 
                  alpha = alpha, beta = beta)

#モデルの読み込みとサンプリング
fit.jags <- jags(data=data.post, model.file="angels_postmodel_jags.txt", parameters.to.save=c("nu"), 
             n.chains=4, n.iter=10500, n.burnin=500, n.thin = 1, DIC=TRUE)
  #MAPやHDIといった要約統計量の推定精度がどのくらい必要かに応じてn.iterを変える。
  #n.iter=250500ぐらいまで増やせばそれなりの精度になります (時間はかかりますが)。

maphdi(fit.jags) #MAPとHDIを計算するための自作関数;過去記事参照
#結果は以下の通り:
#                MAP   Lower95    Upper95   Lower99   Upper99
#deviance   3.531314  3.438523   7.376154  3.438523  10.26979
#nu       141.986992 46.000000 296.000000 36.000000 369.00000

MAPとHDIの計算部分は以前の記事で紹介した自作関数を使用しています。νの事後分布を可視化すると以下のようになります。

post_jags.png

ということで,MAP推定値で見ると,僕はどうやら今まで約139箱のチョコボールを購入したようです。体感的にもそんなもんかなといったところです。ただし事後分布の幅は広めなので注意が必要です。また,iterationの数が少ないと点推定値はかなりぶれます。ちなみに今までに買ったチョコボールの数が100個を超える確率を計算したところ約84%となりました。

3-2. Stanによる推定

 前節ではJAGSによる推定方法を紹介しましたが,今回のモデルの場合は実は負の二項分布からの乱数を発生させるだけでνの事後分布を得ることが可能です。Stanを使うまでもないのですが,例えば銀のエンゼルが当たる確率をデータから推定した上でその値を使ってνを推定したい,という場合は全部Stanで書いた方が楽なので,そういった場合を念頭に置いてStanによる推定法を紹介します。今回のモデルでは

Nsilver ~ Binomial(n = ν, p = θsilver)

という二項分布を用いていますが,Nsilverが定数でνが確率変数のとき,νの事後分布は負の二項分布を用いて

ν ~ NegBinomial(r = Nsilver + 1, p = θsilver)

と表現することができます (負の二項分布は,成功率がpのときにr回成功するまでに要する試行数が従う分布です)。したがって,既知のNsilverθsilverを用いれば,MCMCするまでもなくνの事後分布を得ることができます。ただし,Stanのneg_binomial関数では2番目の引数が成功確率ではなくオッズ (成功確率と失敗確率の比) になっているので書き方を工夫する必要があります。Stanコードは以下の通りです。

angels_postmodel_stan.stan
data{
  int alpha;
  int beta;
  int N_silver;
}

parameters{
  real theta_silver;
}

model{
  theta_silver ~ beta(alpha,beta);
}

generated quantities{
  int nu;
  nu = neg_binomial_rng(N_silver+1,theta_silver/(1-theta_silver)) + N_silver;
}

 モデル記述部ではθsilverをベータ分布から発生させているだけです。生成量として負の二項分布から乱数を発生させればνの事後分布を得ることができます。上記コードを実行するためのRコードは以下の通り。ただし前処理の部分はJAGSコードと同じなので省略しています。

Stanで分析するためのRコード
#以下の環境で動作確認済み
#rstan2.18.2, Rtools3.5, R3.5.2, Windows 10 Pro
library(rstan)

... #JAGSのときと同じ前処理

stanmodel_post <- stan_model(file="angels_postmodel_stan.stan")
fit.stan <- sampling(stanmodel_post, data=data.post, seed=123,
                     chains=4, iter=250500, warmup=500, thin=1
                     ) #JAGSよりも速いのでiterを多めにしている。

round(maphdi(fit.stan),2)
#結果は以下の通り:
#                  MAP  Lower95  Upper95  Lower99  Upper99
#theta_silver     0.04     0.03     0.04     0.03     0.04
#nu             135.62    46.00   296.00    32.00   367.00
#lp__         -1514.99 -1516.88 -1514.96 -1518.29 -1514.96

そしてνの事後分布は以下の通り。

post_stan.png

 多少誤差はありますが,JAGSの結果とほぼ一致していることが分かります。

3-3. 数値積分による推定

 これまでは,二項分布のパラメータνを推定する方法として(1)JAGSで離散パラメータとして推定する方法と(2)Stanを使って (あるいは使わなくても) 負の二項分布から乱数を発生させる方法を紹介しました。ただし,これらの方法は乱数を用いた方法のためiterationが小さいと(少ないと)推定結果が安定せず,たとえばMAP推定値を1の位まで正確に求めるためにはiterationをかなり大きく設定する必要があります。そこでこの節では,乱数に頼らずに事後分布を数値積分で求める方法を簡単に紹介します。いろいろなやり方があると思いますが,ここでは高校数学で習う区分求積法を用いたコードを紹介します。Rコードは以下の通り。

数値積分で推定するためのRコード
Max_nu = 1000

#θがベータ分布に従うときの二項分布モデル(r|ν,θ)の,nの尤度を返す関数を定義 (区分求積法でθを消去)
cal.lik.nu <- function(nu,r,alpha,beta,bin.n=2000){
  output.lik.nu<-0
  bin.w <- 1/bin.n
  for (x in 0:(bin.n-1)){
    p.t <- x/bin.n+bin.w/2
    output.lik.nu <- output.lik.nu + bin.w * dbinom(r,nu,p.t) * dbeta(p.t,alpha,beta)
  }
  return(output.lik.nu)
}

#全てのnについて尤度を計算しベクトルとして格納
lik.nu <- 1:Max_nu
for(n in 1:Max_nu){
  lik.nu[n] <- cal.lik.nu(n,N_Silver,prior_pars$alpha,prior_pars$beta)
}

#尤度を正規化して確率に直す (nの事前分布に離散一様分布を仮定した場合)
prob.nu <- lik.nu / sum(lik.nu)

#MAPとHDIの計算と格納 ※参照:http://bayesmax.sblo.jp/article/185297395.html
accum<-1:length(prob.nu)
for(i in 1:length(prob.nu)){
  if (i ==1){
    accum[i] <- sort(prob.nu)[i]
  } else{
    accum[i] <- accum[i-1] + sort(prob.nu)[i]
  }
}
Interval95 <- grep(TRUE,prob.nu>max(sort(prob.nu)[accum<=(min(abs(accum-0.05))+0.05)]))
Interval99 <- grep(TRUE,prob.nu>max(sort(prob.nu)[accum<=(min(abs(accum-0.01))+0.01)]))
HDI95 <- c(min(Interval95),max(Interval95))
HDI99 <- c(min(Interval99),max(Interval99))
Result.intg <- data.frame(MAP=which.max(prob.nu),Lower99=HDI99[1],
                      Lower95=HDI95[1],Upper95=HDI95[2],Upper99=HDI99[2],
                      row.names = "n_total")

#MAPとHDIの表示
print(Result.intg) #MCMCサンプルから計算した値よりも正確
#        MAP Lower99 Lower95 Upper95 Upper99
#n_total 138      34      50     300     369

#今までに買ったチョコボールの数が100を超える確率
print(sum(prob.nu[101:length(prob.nu)])) #MCMCサンプルから計算した値よりも正確
#[1] 0.8419658

事後分布は次の通り。

post_intg.png

 この方法を使うと高速かつ正確に事後分布を求めることができます。iterationをものすごく増やせばJAGSやStanでも同じ結果が得られます。モデルによってはMCMCより数値積分したり解析的に解いたりしたほうが楽な場合もあるということですね。

4. まとめ

 という訳で,僕が今までに買ったチョコボールの数を推定することにぶじ成功しました。離散パラメータを推定するためにJAGSを使うもよし,Stanで乱数を発生させるのもよし,数値積分に頼るのもよし。手段はどうあれ目的は達成できましたね。これでもう大丈夫。「おまえは今まで買ったチョコボールの数をおぼえているのか?」と聞かれたら,僕ならこう答えます。

「おぼえていないが どうやら50〜300箱の ようだ──ッ」

※この記事の内容はもともと「たのしいベイズモデリング2」の第1章に含めるつもりでいたのですが,紙面の都合で泣く泣くカットせざるを得なかったためアドカレのネタとして使い回すことにしました。という裏話。

posted by mutopsy at 00:00 | 統計

2019年01月09日

二項分布モデルと幾何分布モデルで推定した確率パラメータの事後分布の比較

 こんにちは。mutopsyです。この記事では,同一のカウントデータを二項分布でモデリングした場合と幾何分布でモデリングしたときに,推定される確率パラメータの事後分布が一致することを説明します。間違いがあったらご指摘ください。

 次の2つの例を考えてみましょう。

  1. N箱のチョコボールを購入したら銀のエンゼルが1枚当たった。銀のエンゼルが当たる確率θ1を推定せよ。
  2. 銀のエンゼルが当たるまでチョコボールを購入したらN箱目で当たった。銀のエンゼルが当たる確率θ2を推定せよ。

θ1θ2はどちらも試行にかかわらず一定の値をとり,かつ各試行は独立であると仮定します。ここではチョコボールを例に挙げていますが,2つの事象 (e.g., 当たるか外れるか) のカウントデータであれば何でも構いません。どちらの文も,「銀のエンゼルがN箱中1箱当たった」という同じ結果を述べていますが,データの収集方法に違いがあります。1番目のケースではNがあらかじめ決まっていた状況で銀のエンゼルが1回当たったという結果が得られていますが,2番目のケースでは銀のエンゼルが1回当たることがあらかじめ決まっていた状況でN箱を要したという結果が得られているという違いです。この違いは確率パラメータの推定結果に影響を与えるのでしょうか。

 この例のようにNの決め方 (決まり方) が異なるケースでは,異なる統計モデルを想定するのが自然です。1番目の例のように,Nが所与のときに銀のエンゼルが当たった枚数 (K = 1) のデータが得られた場合には,二項分布を用いて

1 ~ Binomial(N, θ1)

と表現することができます。一方,2番目の例のように,銀のエンゼルが当たった枚数 (K = 1) が所与のときにNというデータが得られた場合には,幾何分布を用いて

N ~ Geometric(θ2)

と表現できます。幾何分布は,同一の確率パラメータを持つベルヌーイ分布に従う試行を独立に繰り返し行ったときに初めて成功する (今回の例では銀のエンゼルが当たる) のに要する回数の分布です。二項分布では銀のエンゼルが当たった回数 (K = 1) が説明されるのに対し,幾何分布では銀のエンゼルが当たるまでに要した試行回数 (N) が説明されるのがポイントです。

 では,2つのモデルでθ1θ2の推定結果がどうなるのかを確認してみましょう。今回は,N = {10, 20, 50, 100} の場合のθ1θ2をStanでベイズ推定してみます。4通りのN と2つのモデル (Is_Censored = 0なら二項分布モデル,Is_Censored = 1なら幾何分布モデル) の組み合わせを用いて8個のθをまとめて推定します。Stanコードは次の通り。rstan2.18.2,Rtools3.5,R3.5.2,Windows10で実行しました。

Stanコード01: 二項分布モデルと幾何分布モデルの比較
data {
  int N_ID; //標本の数 = 8
  int N[N_ID]; //試行回数 = {10,20,50,100,10,20,50,100}
  int K[N_ID]; //成功回数 (今回は1で固定;2以上の場合は負の二項分布になる)
  int Is_Censored[N_ID]; //打ち切られたデータか否か = {0,0,0,0,1,1,1,1}
}

parameters{
  real<lower=0,upper=1> theta[N_ID]; //当たる確率
}

model{
  for (i in 1:N_ID){
    if (Is_Censored[i] == 0){
      K[i] ~ binomial(N[i],theta[i]); //二項分布
    } else if (Is_Censored[i] == 1){
      N[i]-K[i] ~ neg_binomial(K[i],theta[i]/(1-theta[i])); //負の二項分布 (K = 1のとき幾何分布と一致)
    }
  }
}

幾何分布は負の二項分布の特殊なケースなのでモデル上は負の二項分布を使って表現しています (現時点ではStanには幾何分布用の関数はありません)。neg_binomialの第2引数にはθそのものではなくθのオッズを与える必要があります。また,左辺にはNではなくN-1を与えます (Stanで使われている負の二項分布の定義に合わせるため)。このモデルを走らせるためのRコードは以下の通り。

Rコード01: MCMCの実行
library(rstan)
N_ID <- 8
N <- c(10,20,50,100,10,20,50,100)
K <- rep(1,N_ID)
Is_Censored <- c(0,0,0,0,1,1,1,1)

#コンパイル
stanmodel <- stan_model(file="binomgeom.stan")

#データの準備
data <- list(N_ID = N_ID, N = N,
             K = K, Is_Censored = Is_Censored)

#サンプリング
fit <- sampling(stanmodel, data=data, seed=123,
                 chains=4, iter=250500, warmup=500, thin=1)

 各々の場合のθの事後分布とMAP推定値は以下の通り。

posterior_binomgeom.png
図1. 幾何分布モデルと二項分布モデルで推定したθの事後分布とそのMAP推定値。

二項分布モデルで推定したθ1を半透明の赤色,幾何分布モデルで推定したθ2を半透明の青色で描画していますが,ほとんど重なっていて紫色にしか見えません。MAPも,多少の誤差はありますがほぼ一致しています。どうやら,どちらのモデルを使っても推定結果は一致ししそうです。

 両者が一致することは,事後分布を解析的に求めれば分かります。まず,二項分布の確率質量関数は,Nを所与として

posterior_binomgeom.png

と表されます。K = 1のとき,

posterior_binomgeom.png

となります。データが1つしかないときのθ1の尤度関数は

posterior_binomgeom.png

と表せます。最初のNθ1とは無関係な定数なので消去しています。最後に,θ1について無情報事前分布を仮定して尤度関数を正規化することで,次の事後分布が得られます。

posterior_binomgeom.png

 次に幾何分布ですが,確率質量関数は

posterior_binomgeom.png

と表されます。二項分布モデルの場合と同じように,これをθ2の関数 (尤度関数) とみなして正規化すると,

posterior_binomgeom.png

という事後分布が得られます。先ほどの二項分布モデルの事後分布と一致していることが確認できると思います。実はこの事後分布はどちらも (α, β) = (2, N) のベータ分布と一致します。二項分布と幾何分布の確率質量関数の違いは組み合わせ (C) を掛けるか否かの違いのみで,この部分は確率パラメータに依存しないため,事後分布を計算する過程で消去されるという訳です。ちなみに,データが複数ある場合やKが2以上の場合 (つまり幾何分布ではなく負の二項分布を使う場合) にも事後分布は同じパラメータを持つベータ分布 (α = 1 + 成功回数,β = 1 + 失敗回数) となり一致します (計算は省略)。

 という訳で,二項分布モデルを使っても幾何分布モデルを使っても確率パラメータの推定結果は一致することが分かりました。とはいえ,データの持つ情報 (データの収集方法の違い) を正確に表現にするためにもモデル上は両者を区別したほうが良さそうです。

posted by mutopsy at 15:22 | 統計

2019年01月04日

StanやJAGSの計算結果からパラメータのMAP推定値とHDIをまとめて得るためのRの自作関数

 こんにちは。mutopsyです。この記事では,StanやJAGSのfitオブジェクトを渡すとパラメータのMAP推定値とHDI (最高密度区間) をまとめて返してくれる自作関数を紹介します。

 StanやJAGSでパラメータの推定結果の要約を出力すると,通常は事後分布のEAP (i.e., 平均) や分位点の値が出力されますが,事後分布のMAP推定値やHDIが知りたい場合もありますよね。そんなわけで,そういう関数を作ってみました (もう既にあるかもしれないけど知ったこっちゃない)。自作関数といっても,HDIの計算にはHDIntervalというパッケージを利用しますが。関数は以下の通り。

Rコード01: MCMCサンプルからMAP推定値とHDIを計算する関数
library(HDInterval)
maphdi <- function(fit,credMass=0.99,include=TRUE,pars=NA){
  if(credMass<0|credMass>1) print("警告:credMassの値が正しくありません。")
  Class <- class(fit)[1]
  if(Class=="stanfit"){
    e <- as.data.frame(rstan::extract(fit))
  }else if(Class=="rjags"){
    e <- as.data.frame(fit$BUGSoutput$sims.list)
  }else if(Class=="data.frame"){
    e <- fit
  }else{
    print("エラー:未対応なオブジェクトです。")
    stop()
  }

  if(is.na(pars[1])) pars <- colnames(e)
  if (include==TRUE){
    e <- e[,pars]
  }else{
    e <- e[,!colnames(e) %in% pars]
  }
  if(length(pars)==1){
    MAP <- density(e)$x[which.max(density(e)$y)]
    HDI95 <- hdi(e)
    HDIAny <- hdi(e,credMass = credMass)
    Result <- data.frame(MAP = MAP, Lower95 = HDI95[1], Upper95 = HDI95[2],
                         LowerAny = HDIAny[1],UpperAny = HDIAny[2])
    rownames(Result) <- pars
  }else{
    MAP <- apply(e,2,function(z) density(z)$x[which.max(density(z)$y)])
    HDI95 <- apply(e,2,HDInterval::hdi)
    HDIAny <- apply(e,2,function(x) HDInterval::hdi(x,credMass = credMass))
    Result <- data.frame(MAP = MAP, Lower95 = HDI95[1,], Upper95 = HDI95[2,],
                         LowerAny = HDIAny[1,],UpperAny = HDIAny[2,])
  }

  colnames(Result)[4:5] <- c(
    paste("Lower",round(credMass*100,2),sep=""),
    paste("Upper",round(credMass*100,2),sep="")
  )
  return(Result)
  }

 試しにRからStanのfitオブジェクトを渡してみます。データとモデルは何でもよいので適当なものを渡します。

Rコード02: 関数を使ってみる
>fit.eg <- sampling(stanmodel, data=data, seed=123,
                 chains=4, iter=10500, warmup=500, thin=1)
> maphdi(fit.eg)
              MAP    Lower95    Upper95    Lower99    Upper99
beta.1  1.8502036  1.3540767  2.3442492  1.1987086  2.5187496
beta.2  0.6478270  0.5188389  0.7805164  0.4767612  0.8295815
beta.3  0.7103451  0.5996639  0.8201469  0.5627496  0.8524817
beta.4 -0.5622637 -0.7994808 -0.3030058 -0.8891769 -0.2392025
sigma   0.3135227  0.2814639  0.3548575  0.2728315  0.3686322
lp__   97.7211912 93.6796922 99.1662181 91.7998798 99.3115815

 こんな風に,Stanのfitオブジェクトをmaphdi()に引数として渡すだけで各パラメータのMAP推定値と95% HDI・99% HDIを計算して出力することができます。Stan2.18, rstan2.18.2, Rtools3.5, R3.5.2, Windows10で動作確認済み。JAGSにも対応しています (JAGS4.3.0, R2jags0.5-7で確認済み)。

 また,fitオブジェクトの代わりに,MCMCサンプルが格納されたデータフレームを渡してもMAP推定値とHDIを返してくれます。

Rコード03: MCMCサンプルを直接渡す
> e <- as.data.frame(rstan::extract(fit.eg))
> head(e)
    beta.1    beta.2    beta.3     beta.4     sigma     lp__
1 2.194799 0.5785987 0.6255656 -0.4086454 0.3094092 97.46736
2 1.726557 0.6609587 0.7787883 -0.7231942 0.3058624 97.31513
3 2.053161 0.6021407 0.6534262 -0.3992853 0.3425830 96.40984
4 1.941408 0.6503287 0.6399921 -0.4178822 0.2976153 97.93040
5 2.518750 0.4448252 0.7676119 -0.7428853 0.3209268 91.90027
6 1.758346 0.6890341 0.6522970 -0.4046868 0.2985565 97.78386
> maphdi(e)
              MAP    Lower95    Upper95    Lower99    Upper99
beta.1  1.8502036  1.3540767  2.3442492  1.1987086  2.5187496
beta.2  0.6478270  0.5188389  0.7805164  0.4767612  0.8295815
beta.3  0.7103451  0.5996639  0.8201469  0.5627496  0.8524817
beta.4 -0.5622637 -0.7994808 -0.3030058 -0.8891769 -0.2392025
sigma   0.3135227  0.2814639  0.3548575  0.2728315  0.3686322
lp__   97.7211912 93.6796922 99.1662181 91.7998798 99.3115815

 引数のcredMassに0〜1の範囲の値を与える事で,99% HDIの代わりに任意の確度のHDIを出力することもできます。95% HDIは必ず出力されるようになっています。

Rコード04: 任意のHDIを出力
> maphdi(e,credMass = 0.50)
              MAP    Lower95    Upper95    Lower50    Upper50
beta.1  1.8502036  1.3540767  2.3442492  1.7011924  2.0385575
beta.2  0.6478270  0.5188389  0.7805164  0.6060299  0.6964437
beta.3  0.7103451  0.5996639  0.8201469  0.6729364  0.7490473
beta.4 -0.5622637 -0.7994808 -0.3030058 -0.6429855 -0.4713128
sigma   0.3135227  0.2814639  0.3548575  0.3030061  0.3280369
lp__   97.7211912 93.6796922 99.1662181 96.7857008 98.5912001

 引数のparsにパラメータの名前を与えれば,特定のパラメータの結果のみを出力することもできます。また,include = FALSE とすると,指定したパラメータ以外の結果を出力することもできます。

Rコード05: 一部のパラメータのみ計算

> maphdi(fit.eg,pars=c("beta.1","beta.2"))
            MAP   Lower95   Upper95   Lower99   Upper99
beta.1 1.850204 1.3540767 2.3442492 1.1987086 2.5187496
beta.2 0.647827 0.5188389 0.7805164 0.4767612 0.8295815
> maphdi(fit.eg,pars=c("beta.3"))
             MAP   Lower95   Upper95   Lower99   Upper99
beta.3 0.7103451 0.5996639 0.8201469 0.5627496 0.8524817
> maphdi(fit.eg,include=FALSE,pars=c("beta.1","beta.2"))
              MAP    Lower95    Upper95    Lower99    Upper99
beta.3  0.7103451  0.5996639  0.8201469  0.5627496  0.8524817
beta.4 -0.5622637 -0.7994808 -0.3030058 -0.8891769 -0.2392025
sigma   0.3135227  0.2814639  0.3548575  0.2728315  0.3686322
lp__   97.7211912 93.6796922 99.1662181 91.7998798 99.3115815

 以上です。Enjoy!

posted by mutopsy at 19:10 | Rに関するTips

2019年01月01日

既知の確率質量関数からMAP推定値と最高密度区間 (HDI) を計算するためのRの自作関数

 あけましておめでとうございます。mutopsyです。年末にノロウイルスらしきものに感染してしまいましたがぶじ元気に2019年を迎えることができました。今年も何卒よろしくお願いいたします。新年早々ではありますが,必要に駆られてRの自作関数を作ったので共有します。

 既に分かっている確率質量関数を使ってMAP (最大事後確率) 推定値とHDI (highest density interval; 最高密度区間) を求める関数です。実現値として離散値kを返す既知の確率質量関数 (e.g., 二項分布) で事後分布が表現できる場合に,そのような事後分布のMAPとHDIを計算するのに使えます。ちなみに連続値を返す確率密度関数の場合でも,離散化すればこの関数を使って近似的にMAP推定値とHDIを求めることができるはずです。

 2019年1月2日追記:MAPとなる値やHDIの範囲が2つ以上ある場合 (例えば2峰分布など) にも対応できるように関数を修正しました。結果の出力の仕方も微修正。

Rコード01: 既知の確率質量関数からMAP推定値とHDIを計算する関数
hdimass <- function(prob.k,start.k=0,credMass=0.95){
  #警告メッセージ
  if(sum(prob.k)>1) print("警告:確率の和が1を越えています。")
  if(credMass<0|credMass>1) print("警告:credMassの値が正しくありません。")
  
  #HDIの計算の下準備
  credMass1m <- 1 - credMass
  accum<-1:length(prob.k)
  for(k in 1:length(prob.k)){
    if(k ==1){
      accum[k] <- sort(prob.k)[k]
    }else{
      accum[k] <- accum[k-1] + sort(prob.k)[k]
    }
  }
  Interval <- grep(TRUE,prob.k>max(sort(prob.k)[accum<=(min(abs(accum-credMass1m))+credMass1m)]))
  
  #HDIが複数ある場合やHDIが存在しない場合 (全範囲がHDI) を考慮
  if (length(Interval) <= 1){
    Check <- 0
    Interval <- 1:length(prob.k)
  } else{
    Check <- Interval[2:length(Interval)]-Interval[1:(length(Interval)-1)]-1
  }
  if(sum(Check)==0){
    Lower <- min(Interval) + (start.k-1)
    Upper <- max(Interval) + (start.k-1)
  } else{
    Lower <- c(min(Interval),Interval[grep(TRUE,Check!=0)+1]) + (start.k-1)
    Upper <- c(Interval[grep(TRUE,Check!=0)],max(Interval)) + (start.k-1)
  }
  
  #実際にその範囲の値となる確率
  ActualProb <- sum(prob.k[Interval])
  
  #MAPの計算
  MAP <- grep(TRUE,prob.k == max(prob.k)) + (start.k-1)
  
  #結果をリストにまとめて返す
  Result <- list(MAP=MAP,Lower=Lower,Upper=Upper,ActualProb=ActualProb)
  return(Result)
}

 第1引数 (prob.k) としてそれぞれのkが実現する確率のベクトルを,第2引数 (start.k) としてkの最小値 (デフォルトはstart.k=0) を与えることで,MAPと95% HDIの上限・下限を格納したリストが返り値として得られます。また,実際にHDIの範囲内の値をとる確率も返してくれます (離散分布なので95% HDIであっても厳密には95%にはなりませんが,95%に最も近い値になるはずです)。第1引数 (prob.k) には現実的な長さのベクトルを与えれば十分です。例えば N = 20,θ = 0.5 の二項分布であれば,長さが20もあれば総和がほぼ1になるので計算上は問題ありません (以下の例では一貫して長さ500のベクトルを与えていますがもっと少なくても結果は変わりません)。ちなみに第3引数であるcreadMassに(0,1)の範囲の値を与えれば (例えばcredMass = 0.99),異なる確度のHDIを出力することもできます (99% HDIなど)。

 計算の中身を簡単に説明します。まず最初にfor文で確率質量 (prob.k)を昇順にソートし,順番に累積確率を計算しています。次に,累積確率が閾値 (95% HDIなら5%)に最も近い点を探し,各々のkがHDIに含まれるか否かを論理値ベクトルで表現します。この論理値ベクトルを使って,(credMass)% HDIに含まれるkの値を抽出し,Intervalという内部の変数に格納しています。HDIが1つしかない場合は,Intervalの最小値と最大値ををHDIの下限・上限とみなしています。HDIが2つ以上ある場合は,Interval内で数値が飛び飛びになっている部分を見つけてその変化点をHDIの境界とみなしています。MAP推定値は最大事後確率を実現するkの値を求めることで計算しています。

 実際にこの関数を使って,さまざまなパラメータを持つ二項分布のMAPとHDIを計算してみました。

Rコード02: パラメータと引数を変えながら二項分布で試してみた結果
> #(1) 成功確率0.5,試行回数20の二項分布 (95% HDI)
> hdimass(dbinom(0:500,20,0.5),start.k = 0)
$MAP
[1] 10

$Lower
[1] 6

$Upper
[1] 14

$ActualProb
[1] 0.9586105

> #(2) 成功確率0.2,試行回数20の二項分布 (95% HDI)
> hdimass(dbinom(0:500,20,0.2),start.k = 0)
$MAP
[1] 4

$Lower
[1] 1

$Upper
[1] 7

$ActualProb
[1] 0.9563281

> #(3) 成功確率0.6,試行回数100の二項分布 (95% HDI)
> hdimass(dbinom(0:500,100,0.6),start.k = 0)
$MAP
[1] 60

$Lower
[1] 51

$Upper
[1] 69

$ActualProb
[1] 0.948118

> #(4) 成功確率0.6,試行回数100の二項分布 (99% HDI)
> hdimass(dbinom(0:500,100,0.6),start.k = 0,credMass = 0.99)
$MAP
[1] 60

$Lower
[1] 48

$Upper
[1] 72

$ActualProb
[1] 0.9896389

> #(5) 成功確率0.5,試行回数20,k>=7の切断二項分布 (95% HDI)
> hdimass(dbinom(7:500,20,0.5)/sum(dbinom(7:500,20,0.5)),start.k = 7,credMass = 0.95)
$MAP
[1] 10

$Lower
[1] 7

$Upper
[1] 13

$ActualProb
[1] 0.9388129

> #(6) MAPとHDIが2つずつある混合二項分布 (95% HDI)
> hdimass(dbinom(0:500,100,0.3) * 0.5 + dbinom(0:500,100,0.7) * 0.5)
$MAP
[1] 30 70

$Lower
[1] 22 61

$Upper
[1] 39 78

$ActualProb
[1] 0.9501802
#↑95% HDIは[22,39]または[61,78]の範囲

 いい感じに計算できていると思います。

 最後に,この関数を作った経緯を少しだけ説明します。僕が今行っている分析で離散パラメータの推定を行っているのですが,MCMCの結果からMAP推定値とHDIを十分高い精度で計算するためには発生させるMCMCサンプルの数 (JAGSのn.iterの値) をかなり増やさなければならないことが分かりました。これは現実的ではなかったので,数値積分を利用して事後分布を近似的に計算し,その事後分布からMAP推定値とHDIを計算することにしました。その副産物として今回の関数ができたという訳です。Rを使って事後分布を近似的に求める方法についてもいつか記事で解説するかもしれません。

 という訳で,需要があるかどうかも怪しい誰得関数の紹介から2019年が始まりました。Enjoy!

posted by mutopsy at 16:52 | Rに関するTips