機械学習のTA なのに機械学習素人なので機械学習と統計の講義を聞いている。
多次元な確率分布から乱数をいい感じに取ってくる方法に、ランダムウォークを使う。
多次元な確率分布としては、単純に2次元正規分布、とする。二次元の正規分布は、x1 とx2 のそれぞれの変数が平均, で、変数間の関係として分散共分散行列 である。
R ならrvtnorm パッケージが使える。
アルゴリズムとしては、二次元正規分布の確率密度関数を として、ある適当な初期値 から開始する。
ある のとき、どれくらいランダムウォークするかは、一様分布 からランダムに決める。ここでは歩く量 とする。つまり、x方向もy方向も -0.5 から0.5 までの一様分布からサンプリングされる。
さて、ここでランダムサンプリングするかしないかは、以下のルールで決める。
ある のとき一様分布からランダムウォークする量が決まって、 に移動したとすると、次の位置 は、 として位置を変えるか、 として動かないか、である。
この動く/動かない、を決めるのは、確率密度比 より、として確率を決めて、
:動く
:動かない
とする。
確率密度比 が1 より大きいということは、 のほうが よりもっともらしい、ということで、動くべき、ということになる。逆のときは動かないほうがいい、ということになるが、それでもちょっとは動くことも可能性としては残したほうがよい、という気分がある。というのが、(確率密度の)比は0 以下にはならないからである。
という感じで、適当な初期値、確率密度関数(ここではdrvnorm で得られる)、繰り返し回数、を指定すると、乱数ができる。繰り返しは10000回行った。
できた。
さて、これは初期値依存なので、初期値がうまく設定されないと、いい感じにならない。ここで、初期値を少し離して実行してみる。
できた。
ここで試している確率密度は単純なもので、初期値が目的の関数から離れていても、サンプリング回数が多くなればそこそこたどり着く、ことが多い。ここで、ある程度離れた初期値で、サンプリング回数も減らしてみる(1500回)。
最初の100サンプリングくらいでもう目的の関数部分にたどり着いているので、それなりにいい感じの乱数ができているが、上の図とはサンプル数が段違いなので、カーネル密度推定したものの楕円形(これは二次元正規分布で設定した の傾き具合に相当する)がグニャグニャである。
上の図では、ランダムウォークの過程を各 のときで色付けしておいた。ここで、確率密度比 (の対数)と、確率密度比の確率を用いて点が移動したのか否かの記録をプロットしている。
確率密度比 (の対数)が非常に大きいもしくは小さいときは、最初の50点くらいで、それ以降はほとんど1、つまり がほぼ等しい状態になっている。この時点では、ランダムウォークの点は二次元正規分布に近いところをウロウロしている。ランダムウォークの移動量は、 のけっこう狭いグリッド内なので、一発のランダムウォークで二次元正規分布から逸脱することはない。
が1 以上のときは、確率1 で移動することになるので、移動したことを示すマゼンタが記録されている。 が1 未満のときは、確率で移動して確率 でその場にとどまるので、(対数では0)より下の領域では、2色出ている。
こういうのがRstan でのいわゆるwarm up や収束になる。
library(mvtnorm) library(MASS) x0 <- c(0.1, 0.2) x0 <- c(-1, 2) iter <- 1500 # 繰り返し回数 x <- matrix(0, iter, 2) # ランダムウォークの座標 dratio <- rep(0, iter) # 確率密度比 out <- rep(0, iter) # 確率密度比にしたがって確率的に動いたか、動かなかったかの記録 x[1,] <- x0 rho <- 0.7 sig <- matrix(c(1, rho, rho, 1), 2) mu <- c(4, 5) for(i in 2:iter){ walk <- runif(2, -0.5, 0.5) # 歩く量 v <- x[i-1,] + walk # 次の候補点 dratio[i-1] <- dmvnorm(v, mean=mu, sigma=sig)/dmvnorm(x[i-1,], mean=mu, sigma=sig) # 確率密度比 out[i-1] <- rbinom(1, 1, min(1, dratio[i-1])) # 動いたか、動かなかったか x[i,] <- x[i-1,] + out[i-1]*walk } kd <- kde2d(x[,1], x[,2], c(bandwidth.nrd(x[,1]), bandwidth.nrd(x[,2])), n=1000) cols <- jet.colors(iter) plot(x, type="p", pch=16, cex=0.6, col=2, xlab="x1", ylab="x2") #lines(x, col=cols) for(i in 2:iter){ segments(x[i-1,1], x[i-1,2], x[i,1], x[i,2], col=cols[i]) } points(x[1,1], x[1,2], pch="★", col=6) points(mu[1], mu[2], pch="★", col=5) contour(kd, add=TRUE, col=6) pcols <- c("black", "magenta") plot(dratio, log="y", type="n", xlab="sampling number", ylab="log likelihood") for(i in 2:iter){ segments(i-1, dratio[i-1], i, dratio[i], col=cols[i]) } abline(h=1, lty=3) points(seq(iter), dratio, cex=0.4, col=pcols[out+1], pch=16) legend("topright", legend=c("動かなかったとき", "動いたとき"), pch=16, col=pcols, cex=2)