１　候補が絞り込まれていくとき - ryamadaの遺伝学・遺伝統計学メモ

こちらで情報による意見の変化について考えた
世の中では、複数の候補者からの選出、というイベントがなされている。だれか１人の候補者が過半数を取ると決定する仕組みで、全候補者への投票ができる段階から、候補者の数が変更されていく。単純に上位２名の決選にすることもできるし、次第に候補者を絞っていくこともできるだろう
どちらも何かしらのきっかけで、「候補〜仮説」の尤度が変化する話
前者は、比較的小さい自然数に関して事前確率を考えた後、候補となる自然数に制約が入ったとして、事前確率をどのように変化するか、の話
簡単なところから始めよう
投票
- 複数の候補者がいて、たくさんの選挙権者がいるとする
- 選挙権者は候補者に対して、投票したい順序がある
- 選挙権者は自分が最も投票したい候補者に投票する
- 過半数の得票を取れば、確定、そうでなければ、以下の手順で候補者を絞ることにする
- １回、投票が行われるごとに、最下位の候補者は除外される
- 候補者が減ると、その候補者を選んでいた選挙権者だけは、投票先を変更する。このときの変更行動は偏りが出る。
- Rでやってみよう

- 次の記事へ進む

# 投票
# 選挙権者数
Nv <- 10001
# 候補者数
Nc <- 10
# 選挙権者の候補者の好き嫌いはN.opパターンに分かれるとする
N.op <- 30
op.list <- list()
for(i in 1:N.op){
	op.list[[i]] <- sample(1:Nc)
}
# それぞれの好き嫌いパターンの確率を決める
library(MCMCpack)
op.prob <- rdirichlet(1,rep(1,N.op))
# Nv人の好き嫌い順を描き出した行列を作る
Opinions <- matrix(0,Nv,Nc)
for(i in 1:Nv){
	Opinions[i,] <- op.list[[sample(1:N.op,1,prob = op.prob)]]
}
# １人ずつ候補者を減らしていく過程が以下
loop <- TRUE
# 初めは全員が投票対象
list.c <- 1:Nc
# ログを取ろう
log <- NULL
while(loop){
# 投票対象者をプリントアウト
	print("candidates")
	print(list.c)
# 選挙権者ごとに何番目の候補者に投票するかを確認
	votes <- t(apply(Opinions[,list.c],1,order))[,length(list.c)]
# 人数を集計して、その結果をプリントアウト
	res <- tabulate(votes,length(list.c))
	print("result")
	print(res)
	tmp <- rep(0,Nc)
	tmp[list.c] <- res
	log <- rbind(log, tmp)
# 過半数得票者がいるかどうかを確認
	if(max(res) > sum(res)/2){
# 過半数得票者がいれば、ループは止めて、被選出者を登録
		loop <- FALSE
		selected <- list.c[which(res == max(res))]
# 過半数得票者がいなければ
	}else{
# リストから外される候補者を選んで、外す
		tobe.deleted <- which(res == min(res))
# いきなり複数がはずれると、過半数を取らなくても、候補者が１人に絞られたりするのでそれを回避する
		tobe.deleted.2 <- sample(tobe.deleted,1)
		list.c <- list.c[-tobe.deleted.2]
		if(length(list.c) == 1){
			loop <- FALSE
			selected <- list.c
		}
	}
}
# 選出者
print(selected)
# 得票数の推移
matplot(log,type="l")