とりあえずプロット
例1: 混合正規分布
モデルとして次の分布を考える.
(この例は『ベイズ統計の理論と方法』に出てくる.)
ここで は平均0, 分散1 の正規分布の密度関数である. とする.
この手のモデルは2つの分布が混ざったような形になるので混合分布とよばれ, モデルに基づくクラスタリングなどの際によく使われる.
サンプルを生成した分布(とする)が のとき, なら はなんでも, また なら はなんでも, データを生成した分布とモデルが一致する.
つまりサンプルを生成した分布に対して, モデルの最適なパラメータが一意に定まらない.
サンプルの大きさを100として, このときの尤度関数を等高線でプロットしてみよう.
グリッドサーチ(範囲を限定して適当な幅で単純な総当り)で求めた最尤推定値をバツ印でプロットしてあるが, これはサンプルのあらわれ方によって大きく揺らぐ.
次に で生成したサンプル で生成したサンプルを50個ずつ混ぜてみよう
このとき, モデルの最適なパラメータは である.
のとき:
まずはデータのヒストグラムを見る.
まあ, 言われたらなんとなく2つ山があることに気づくかな、くらいである.
このときの尤度関数を見る.
尤度関数のモードを中心とした2変量正規分布からの乱数をグレーの点で重ねてある.
(2変量正規分布の密度関数の等高線は楕円になる 2変量正規分布の等高線(確率楕円)の描き方 - ジョンとヨーコのイマジン日記).
モードの周りはいいとして, 裾のほうは正規分布で近似するのが苦しい感じである.
のとき:
データのヒストグラムを見る.
2つの分布が混ざっていることにはなかなか気づかないだろう.
このときの尤度関数を見る.
正規分布で近似するのは苦しい感じである.
のとき:
2つの分布が混ざっているのではないかと感じる人はほとんどいなさそうである.
このときの尤度関数を見る.
正規分布による近似は苦しい.
例2: 非線形回帰
モデルとして次の分布を考える.
は既知の数とする.
(この例は 藤原香織、渡辺澄夫(2006)ベイズ尤度比検定による変化点検出のシミュレーション - ジョンとヨーコのイマジン日記 と同じ. )
例えば を時間として, なんらかの施策の前後でデータの変化を見たいときは(データを適当にスケーリングするとして)このようなモデルを考えるかもしれない.
ちなみに, 一番単純なニューラルネットワークではこのような非線形の変換をベクトルに対して繰り返して行い, 例えば のようなモデルを考える.
さて, としてサンプルを生成してプロットすると次のようになる.
このとき, のとき はなんでも, また のとき はなんでも, データを生成した分布とモデルが一致する.
例1のときと同様, サンプルの大きさを100として, このときの尤度関数を等高線でプロットしてみよう.
グリッドサーチで求めた最尤推定値をバツ印でプロットしてあるが, これはサンプルのあらわれ方によって大きく揺らぐ.
のとき:
のとき:
で生成したサンプルを50個ずつ混ぜてみよう. (といっても は今回の例では登場しない.)
このとき または でデータを生成した分布とモデルが一致する.
無限大まではプロットできないので の の範囲で尤度関数の等高線を描いてみる.
例3: ガンマ分布
最後に, 形状パラメータ2, 尺度パラメータ1のガンマ分布でサンプルを100個生成して, モデルを正規分布 とした例をやってみよう.
(この例は『In All Likelihood』に出てくる)
尤度関数のモードを中心とした2変量正規分布からの乱数をグレーの点で重ねてあるが, これは近い形の分布になっている.
(途中計算は省略して), で, データを生成した分布とモデルの間のカルバック・ライブラ距離は最小となる.
最小となってもぴったり一致はしないので「選んだモデルの範囲内では」というただし書きつきではあるが, 例3は最尤法がうまくいっている例である.
R のコード
library(ggplot2) #対数尤度関数 llmixnorm <- function(par,y){ a0 <- par[1] b0 <- par[2] sum(log((1-a0)*dnorm(y)+a0*dnorm(y,b0))) } lltanh <- function(par,y,x){ a0 <- par[1] b0 <- par[2] sum(dnorm(y, b0*tanh(a0*x), log=TRUE)) } llnorm <- function(par,y, lp=FALSE){ a0 <- par[1] b0 <- par[2] sum(dnorm(y, a0, b0, log=TRUE)) } # 2変量正規乱数の生成 sample_norm <- function(optp, H, np){ U <- chol(-H) #コレスキー分解 s <- backsolve(U, matrix(rnorm(2*np),2,np))+optp # Uの逆行列を左からかけてる data.frame(a=s[1,], b=s[2,]) } ### Example1 N <- 100L set.seed(1) y0 <- rnorm(N) y11 <- c(rnorm(N/2),rnorm(N/2,1)) y12 <- c(rnorm(N/2),rnorm(N/2,0.5)) y13 <- c(rnorm(N/2),rnorm(N/2,0.25)) ggplot()+ geom_histogram(data=NULL, aes(x=y11), fill="grey70", bins=25)+ theme_bw(14)+labs(x="y (1)", y="count") ggsave("./Desktop/y1.png") ggplot()+ geom_histogram(data=NULL, aes(x=y12), fill="grey70", bins=25)+ theme_bw(14)+labs(x="y (2)", y="count") ggsave("./Desktop/y2.png") ggplot()+ geom_histogram(data=NULL, aes(x=y13), fill="grey70", bins=25)+ theme_bw(14)+labs(x="y (3)", y="count") ggsave("./Desktop/y3.png") parms <- expand.grid(a=seq(0,1,length.out = 200), b=seq(-5,5,length.out = 200)) l10 <- apply(parms, 1, llmixnorm, y=y0) l11 <- apply(parms, 1, llmixnorm, y=y11) l12 <- apply(parms, 1, llmixnorm, y=y12) l13 <- apply(parms, 1, llmixnorm, y=y13) optp10 <- parms[which.max(l10),] optp11 <- unlist(parms[which.max(l11),]) optp12 <- unlist(parms[which.max(l12),]) optp13 <- unlist(parms[which.max(l13),]) dfL10 <- data.frame(parms, value = exp(l10)) dfL11 <- data.frame(parms, value = exp(l11)) dfL12 <- data.frame(parms, value = exp(l12)) dfL13 <- data.frame(parms, value = exp(l12)) #ヘシアン=フィッシャー情報量(行列)の逆行列の符号反転 H11 <- optimHess(optp11, llmixnorm, y=y11) dfs1 <- sample_norm(optp11, H11, 10000) H12 <- optimHess(optp12, llmixnorm, y=y12) dfs2 <- sample_norm(optp12, H12, 10000) H13 <- optimHess(optp13, llmixnorm, y=y13) dfs3 <- sample_norm(optp13, H13, 10000) ggplot(dfL10,aes(x=b,y=a))+ geom_contour(aes(z=value, colour=after_stat(level)))+ geom_point(data=optp10, shape=4, size=1, stroke=2)+ scale_colour_binned(type = "viridis")+ theme_bw(14) ggsave("./Desktop/p_10.png") ggplot(dfL11,aes(x=b,y=a))+ geom_point(data=dfs1, alpha=0.1, colour="grey")+ geom_contour(aes(z=value, colour=after_stat(level)))+ scale_colour_binned(type = "viridis")+ theme_bw(14) ggsave("./Desktop/p_11.png") ggplot(dfL12,aes(x=b,y=a))+ geom_point(data=dfs2, alpha=0.1, colour="grey")+ geom_contour(aes(z=value, colour=after_stat(level)))+ scale_colour_binned(type = "viridis")+ theme_bw(14) ggsave("./Desktop/p_12.png") ggplot(dfL13,aes(x=b,y=a))+ geom_point(data=dfs3, alpha=0.1, colour="grey")+ geom_contour(aes(z=value, colour=after_stat(level)))+ scale_colour_binned(type = "viridis")+ theme_bw(14) ggsave("./Desktop/p_13.png") #### Example 2 set.seed(2) y21 <- c(rnorm(N/2,-0.4), rnorm(N/2,0.4)) x <- seq(-1, 1, length.out=N) parms <- expand.grid(a=seq(-5,5,length.out = 200), b=seq(-5,5,length.out = 200)) qplot(x, y0, geom = "line")+ theme_bw(14)+labs(y="y (1)") ggsave("./Desktop/p_d1.png") ggplot()+ geom_line(data=NULL, aes(x=x, y=y21))+ stat_function(fun = function(x)0.4*tanh(5*x), colour="royalblue", linetype=2, size=1)+ theme_bw(14)+labs(y="y (2)") ggsave("./Desktop/p_d2.png") L20 <- apply(parms, 1, lltanh, y=y0, x=x) dfL20 <- data.frame(parms, value=exp(L20)) optp20 <- parms[which.max(L20),] L2 <- apply(parms, 1, lltanh, y=y21, x=x) dfL2 <- data.frame(parms, value=exp(L2)) optp2 <- unlist(parms[which.max(L2),]) H1 <- optimHess(optp2, lltanh, y=y21, x=x) dfs <- sample_norm(optp2, H1, 10000) ggplot(dfL20,aes(x=b,y=a))+ geom_contour(aes(z=value, colour=after_stat(level)))+ geom_point(data=optp20, shape=4, size=2, stroke=1)+ scale_colour_binned(type = "viridis")+ theme_bw(14)+ylim(c(-5,5)) ggsave("./Desktop/p_20.png") ggplot(dfL2,aes(x=b,y=a))+ geom_point(data=dfs, alpha=0.1, colour="grey")+ geom_contour(aes(z=value, colour=after_stat(level)))+ scale_colour_binned(type = "viridis")+ theme_bw(14) ggsave("./Desktop/p_21.png") ####Example 3 set.seed(3) y_g <- rgamma(100,2) parms <- expand.grid(a=seq(0.1,4,length.out = 200), b=seq(0.1,4,length.out = 200)) l3 <- apply(parms, 1, llnorm, y=y_g) optp3 <- unlist(parms[which.max(l3),]) dfL3 <- data.frame(parms, value = exp(l3)) optp3 H3 <- optimHess(optp3, llnorm, y=y_g) dfs <- sample_norm(optp3, H3, 10000) ggplot(dfL3,aes(x=b,y=a))+ geom_point(data=dfs, alpha=0.1, colour="grey")+ geom_contour(aes(z=value, colour=after_stat(level)))+ scale_colour_binned(type = "viridis")+ theme_bw(14) ggsave("./Desktop/p_gamma.png")
参考文献
最尤推定の基礎
変な形の尤度関数をおもしろがるにはある程度最尤推定についての基礎知識がいるので補足する.
とはいえ, まったくの初学者が以下を理解するのことは難しいと思う. 数学的な道具としては中心極限定理とテイラー展開くらいを使う.
また, 以下での は不定積分でなく関数の定義域全区間での積分を意味する.
さて, データ を生成したなんらかの確率分布 があるとして, それを母集団と呼ぶ.
それぞれ独立に母集団 に従う確率変数 () を大きさ のランダム標本(ランダムサンプル)と呼ぶ.
(現実の多くの場合には, 推測したいターゲットがこの仮想的な「母集団」と対応するように考えたりとか, ランダム標本になるようにデータのとり方を工夫したりとかするだろう.)
統計学の重要な目的なひとつは におおよそ近い, 適当な確率分布 をつくることである.
分析者が設定した確率分布 を単にモデルと呼ぶ. パラメータ をつけて を考え, なるべくいい を選ぶことにしよう.
ふたつの確率分布の近さを測るものとして, カルバック・ライブラ距離がある.
と のカルバック・ライブラ距離を次式で定義する.
ここで は分布 による期待値を表す( ).
カルバック・ライブラ距離の第2項が のみによって定まり, モデルに依存しないので, 第1項をなるべく小さくすることを考える.
得られるのは データ(確率変数) なので期待値を標本平均で置き換え, 対数尤度関数を次式で定義する.
ここではモデルに自由パラメータ をつけて, としている.
これはカルバック・ライブラ距離の第1項の符号反転(-1倍)なので, 対数尤度関数を最大にする を選ぶことで, モデルが母集団に近づくのではないかと考えている.
準備として, スコア関数 とフィッシャー情報量 をそれぞれ,
スコア関数:
フィッシャー情報量:
と定義する.
次により, の による平均は 0 である.
ここから, の分散 は,
である. 一方フィッシャー情報量は,
より のときと同様, 第1項は消える. 第2項は
である. まとめると,
で, の分散は と等しい.
さて, が平均的に最大値を取る点 の周りでのテイラー展開は,
である(テイラー展開ができることは仮定). と置くと,
上述のスコア関数とフィッシャー情報量についての性質を思い出すと, 中心極限定理より, が十分大きいとき, 標準正規分布に従う確率変数 を用いて,
という近似が成り立つ(テイラー展開の以降の項は より速く 0 に近づく). であったので,
右辺は2次関数であり, のとき最大になる.
よって, とすると, が十分大きいとき, は平均 0, 分散 の正規分布に従う. これが最尤法の基礎である.
ここでは1パラメータ( が1個)のモデルを扱ったが, パラメータが複数になっても基本的には同じである(が線形代数の知識がないとしんどい).
変な形の尤度関数は, が数字だけ見ると大きいようでも, 尤度関数が正規分布に似ても似つかない例である.