前回は正規分布の裾の積分をなんとなく決めた提案分布による重点サンプリングで求めた。今回は提案分布の違いがどのような誤差の違いを生むのかについて実験した。ただし、今回の積分範囲は [4,∞) とした。ようするに \(f\) を標準正規分布のpdfとして
\begin{align}
\int_4^\infty f(x)dx
\end{align}
を求める問題。
考える提案分布たち
以下の様な感じで。赤いのが真の分布。これを使ったときはふつうのモンテカルロ法に対応することに注意。その他に３つほど提案分布を考えてみる。
Image may be NSFW.
Clik here to view.
誤差評価
上の４つの提案分布を使ったケースにおける誤差の評価。横軸はサンプリング回数を表している。
Image may be NSFW.
Clik here to view.
紫色の提案分布以外は「漸近的に」同じオーダーで誤差が減少している（両対数プロット）。すべて傾きは -1/2 になっているが、定数の部分が異なる。最もパフォーマンスがいいのは
- ほどよく4の周りを覆っている青い分布
になっている。紫色の分布はほとんど4より小さい部分をサンプリングしないので、全くパフォーマンスが出ない。なんとなく直感に合う結果になった。
ちなみにモンテカルロでは傾きが -1/2 になることはよく知られているが、重点サンプリングでも同じになることは自明（重点サンプリングは前回の記事でふれたように、物理量の定義と分布の定義を変更したモンテカルロ法に過ぎないので）。
メトロポリス・ヘイスティングスのときはターゲット分布と提案分布がなるべく近いほうが良かったけど、このケースでは提案分布からむしろ遠ざける（ただし「良い感じに」という条件付き）ことで精度が向上する。
どこがヨサゲなのか事前に知る簡便な方法はあるのだろうか？（基本的には変化の激しいところを重点的にサンプリングするという戦略がよさそうな気がするけど）
スクリプト in R
p.star <- pnorm(-4)
n <- 10^(2:7)
n.try <- sapply(1e+08/n,function(x) min(c(x,5e+04)))
results.mc <- rep(0,length(n))
results.is <- rep(0,length(n))
results.is.worse <- rep(0,length(n))
results.is.worse.2 <- rep(0,length(n))
for(i in log10(n)){
tmp.mc <- rep(0,n.try[i-1])
tmp.is <- rep(0,n.try[i-1])
tmp.is.worse <- rep(0,n.try[i-1])
tmp.is.worse.2 <- rep(0,n.try[i-1])
for(j in 1:n.try[i-1]){
tmp.mc[j] <- mean(rnorm(n[i-1])>4)
proposal <- rnorm(n[i-1],2,2)
tmp.is[j] <- mean((proposal > 4) *
(dnorm(proposal)/dnorm(proposal,2,2)))
proposal <- rnorm(n[i-1],1,1)
tmp.is.worse[j] <- mean((proposal > 4) *
(dnorm(proposal)/dnorm(proposal,1,1)))
proposal <- rnorm(n[i-1],8,1)
tmp.is.worse.2[j] <- mean((proposal > 4) *
(dnorm(proposal)/dnorm(proposal,1,1)))
}
results.mc[i-1] <- mean(abs(tmp.mc-p.star))
results.is[i-1] <- mean(abs(tmp.is-p.star))
results.is.worse[i-1] <- mean(abs(tmp.is.worse-p.star))
results.is.worse.2[i-1] <- mean(abs(tmp.is.worse.2-p.star))
}
result.df <- rbind(data.frame(n,error=results.mc,
Method="Standard MC Smp."),
data.frame(n,error=results.is.worse,
Method="Importance Smp. (mu=1 / sigma^2=1) "),
data.frame(n,error=results.is,
Method="Importance Smp. (mu=2 / sigma^2=2) "),
data.frame(n,error=results.is.worse.2,
Method="Importance Smp. (mu=8 / sigma^2=1) "))
library(ggplot2)
ggplot(aes(x=n,y=error,colour=Method),data=result.df) +
geom_point(aes(x=n,y=error),cex=5) +
geom_line(aes(x=n,y=error),lw=1.2) +
geom_line(aes(x=c(1e+05,1e+07),y=c(1e-04,1e-05)), colour="black", lt=2, lw=2) +
geom_text(aes(x=1e+6,y=5e-5,label="Theoretical slope"),colour="black",angle=336) +
opts(legend.position = c(.25,.15),
legend.background=theme_rect(fill="white"),
legend.text=theme_text(size=14),
title="Comparing scaling law of absolute error (MC vs IS)\n") +
scale_x_log10("\nData size",breaks=n) +
scale_y_log10("Absolute error\n",breaks=10^-(2:8))
ggsave("ImportanceSampling.png",height=8,width=9)
xx <- seq(-4,12,0.1)
dens <- rbind(data.frame(x=xx,y=dnorm(xx),
Proposal.Density="mu=0, sigma^2=1 (True distribution)"),
data.frame(x=xx,y=dnorm(xx,1,1),
Proposal.Density="mu=1, sigma^2=1"),
data.frame(x=xx,y=dnorm(xx,2,2),
Proposal.Density="mu=2, sigma^2=2"),
data.frame(x=xx,y=dnorm(xx,8,1),
Proposal.Density="mu=8, sigma^2=1"))
ggplot(dens,aes(x=x,y=y)) +
geom_line(aes(colour=Proposal.Density),lw=1.2) +
ylim(c(0,0.6)) + ylab("p.d.f.\n") +
opts(legend.position = c(0.5,0.83),
legend.background=theme_rect(fill="white"),
legend.text=theme_text(size=14),
title="Sampling distributions (proposal distrubutions)\n"))
ggsave("ProposalDistribution.png",height=8,width=9)
lm(log(results.is) ~ log(n))