現場に居る確率:法廷用ベイジアンネットワーク

  • ある容疑者Xを疑っている。そのほかにたくさん(N=99)の人が「もしかしたら」犯人かもしれない
  • まずは、現場にいたかどうかの確率を計算したい
  • その上で、容疑者Xか、その他大勢か、どちらが現場にいたっぽかったかを数値で比較したい
  • 『犯行現場』を定義しよう。『●月×日▼時から△時、場所Y(非常に狭い土管の中だったら、出這入り人数に上限がある、そんな感じ)』を『犯行現場』とする
  • 容疑者Xには、それなりのアリバイがあって、▼時から△時の1/100の時間帯だけ、場所Yに居られたが、それ以外の時間帯は、アリバイが成立しているとする
  • その他大勢の候補はN人いるが、その犯行現場の『土管』には、その時間帯すべてを使っても、M人しか入ることはできないとする(全速力で出這入りをくりかえした実験結果、とか)
  • ここで容疑者Xに1つのノードを割り振り、その「事前確率」を1/(N+1)とし、その他大勢の事前確率をN/(N+1)とすることで、疑似的に両者を区別する
  • その上で、Xは1/100の割合で『犯行現場』に居られて、その他大勢は、M人が『犯行現場』に居られた、とする
ps <- list()
ps[[1]] <- cptable(~p1,values=c(1,99),levels=c("1","0"))
ps[[2]] <- cptable(~p2,values=c(99,1),levels=c("1","0"))
# 誰かが現場に居て、動機を持って、犯行に関わって、遺留品を残す

# 現場に居る確率

Ls <- list()
Ls[[1]] <- cptable(~L1|p1,values=c(0.01,0.99,0,1),levels=c("1","0"))
# 土管がぎゅうぎゅうでもみんな「居あわせた」かもしれない場合
Ls[[2]] <- cptable(~L2|p2,values=c(1,0,0,1),levels=c("1","0"))
plist2 <- compileCPT(list(ps[[1]],ps[[2]],Ls[[1]],Ls[[2]]))
querygrain(net2,nodes=c("p1","p2","L1","L2"))
# ぎゅうぎゅうの土管に『定員』を設定した場合
Ls[[2]] <- cptable(~L2|p2,values=c(10,89,0,1),levels=c("1","0"))
plist2 <- compileCPT(list(ps[[1]],ps[[2]],Ls[[1]],Ls[[2]]))
net2 <- grain(plist2)
querygrain(net2,nodes=c("p1","p2","L1","L2"))
  • 土管に定員を入れることで、L2の値に変化が出ている。L1とL2の比が犯人であると疑うときの尤度比に効いてくる
> querygrain(net2,nodes=c("p1","p2","L1","L2"))
$p1
p1
   1    0 
0.01 0.99 

$L1
L1
     1      0 
0.0001 0.9999 

$p2
p2
   1    0 
0.99 0.01 

$L2
L2
   1    0 
0.99 0.01 

> Ls[[2]] <- cptable(~L2|p2,values=c(10,89,0,1),levels=c("1","0"))
> plist2 <- compileCPT(list(ps[[1]],ps[[2]],Ls[[1]],Ls[[2]]))
> net2 <- grain(plist2)
> querygrain(net2,nodes=c("p1","p2","L1","L2"))
$p1
p1
   1    0 
0.01 0.99 

$L1
L1
     1      0 
0.0001 0.9999 

$p2
p2
   1    0 
0.99 0.01 

$L2
L2
  1   0 
0.1 0.9