情報量基準

AIC / BIC / DIC / TIC のような。データのあてはまりのよさとモデルの複雑度を天秤に図るタイプのやつ。

たくさん種類があるのは確率モデルに関する仮定と汎化誤差の近似の仕方の違いによるものだと理解している。

検定

回帰係数が０である、という帰無仮説を検定することである変数が貢献しているかどうかを定量化するタイプのやつ。棄却されなければ「えい！」と変数を削ってしまう。

ささっと分析してデータの雰囲気を掴みたい時に使うことはある。

L1正則化

寄与度の小さな（ある閾値より小さな）係数をゼロにしてしまう、というような感じのやつ。

事前分布としてラプラス分布を使うことに相当。単純に寄与度が低い変数は消してしまえ！というノリなのだろうか？もっと深遠な背景があるのだろうか？勉強不足でよくわからない。

ベイズモデル選択

複数のモデルに事前分布を設定して、「モデルの事後分布」を計算するたぐいのもの。事後分布が求まったあとはMAPなものを選んでくるか、事後分布で平均をとってしまうか。

たとえばディリクレ混合過程。これはGMMのような混合モデルの混合数の事後分布を求めることができる。

PRMLの変分ベイズのところで出てきた関連度自動決定もこのタイプだと思っていいのだろうか。これも勉強不足により不明。

***

いろいろと抜けがあるとは思うが、とりあえずすぐに思いついたのはこれくらい。場合によっては追記します。

自己相関ほぼ完全になし、という結果になった。ギブスサンプラーだとこうはいかない。ただし、

• 微分方程式を解く時間のスケールが小さすぎると自己相関が出たので良い感じのスケールをちょっとだけ探索した。
• ステップ幅を固定にしたら怪しげな自己相関の挙動がでた。
• 計算時間でギブスサンプラーと比較してどちらが有利かは今回は検討してません。

という点は追記しておきます。

PRML 11章 を読んで適当に実装してみた。リープフロッグのところで無駄な計算をしているので要改良。

# Hybrid MC sampling
#  [Remark]
#   "p" in this source file is "r" in PRML
#   "q" in this source file is "z" in PRML

# Setting
h <- 0.01
Sigma <- matrix(c(3,2.5,2.5,3),nc=2)
iSigma <- solve(Sigma)

# Energy : log of density function
E <- function(q){
  sum(q * (iSigma %*% q)) # normal distribution
}

dE <- function(q){
  2*iSigma %*% q
}

# Kinematic
K <- function(p){
  sum(p^2)
}

# Hamiltonian
H <- function(p,q){
  E(q) + K(p)
}

# Leapfrog method
step.leapfrog <- function(p,q,h){
  p.half <- p-(h/2)*dE(q)
  q.1 <- q+h*2*p.half
  p.1 <- p.half-(h/2)*dE(q.1)
  list(p=p.1,q=q.1)
}

#-------------
# Main
#-------------
N <- 3000  # The number of sampling
R <- 30    # Leapfrog step counts
q.values <- matrix(rep(0,2*N),nc=2)  # Buffer
p=rnorm(2) # initial state
q=rnorm(2) # initial state
H.value <- H(p,q)
for( n in 1:N){
  h <- 0.01+0.1*runif(1)  # Leapfrog step size
  p.old <- p
  q.old <- q
  H.old <- H.value
  for( i in 1:R ){
    nxt <- step.leapfrog(p,q,h)
    p <- nxt$p
    q <- nxt$q
  }

  if( exp(H(p,q)-H.old) < runif(1) ){ # rejection
    p <- p.old
    q <- q.old
  }

  q.values[n,] <- q
  p <- rnorm(2)
  H.value <- H(p,q)
}

# Plotting results
par(mfrow=c(3,1))
plot(q.values,xlab="x1",ylab="x2",main="Result of hybrid MC sampler",pch=20,col="gray")
acf(q.values[,1],main="Auto-correlation function of x1")
acf(q.values[,2],main="Auto-correlation function of x2")
dev2bitmap(file="hybridMC.jpg",width=6,height=18,gaa=4,taa=4)

関連エントリ：ハミルトン系の数値計算 (PRML11章)

↓ PRML

機械学習の対数線形モデルが最大エントロピー法とも呼ばれる，みたいな記述は頻繁に目にするし，統計力学のボルツマン分布の話とか考慮すれば，なんとなくそうなってそうな気はするけど，実際どうなの？というのを (たんに好奇心を満たすために) 調べてみた．実用上は何の意味ないと思う．

対数尤度関数に L1 正則化項を加えるタイプの目的関数を使った場合，もはやエントロピーは最大化されない，とかそういうわりとどうでもいいことがわかったりするかもしれない．

概要

「言語処理のための機械学習入門 (→ amazon) 」などに出てくるタイプの対数線形モデルの係数の最尤推定量が，エントロピーを「ある制約条件下」で最大化した場合のラグランジュ未定乗数に対応することを説明する (クロス表の対数線形モデルとはたぶん別物)．

ただし，記号が煩雑になるのを避けるため，対数線形モデルとほぼ同一の構造を持ち，記号が煩雑でない条件付きロジットモデルがエントロピー最大化と等価であることを見る．

本文の最後に対数線形モデルと等価なエントロピー最大化問題を示す．多少ややこしくなるが，同じ方針で証明可能．

設定

あるカテゴリーの製品群 \(\{1,2,\cdots,K\}\) のどれかを購入した消費者に対して，
ランダムサンプリングを行って購入製品を調査したところ，以下のようなデータが得られたとする．

表：市場のランダムサンプリングによって得られた購入人数データ

ここで全サンプル数を \(N=n_1+n_2+\cdots+n_K\) としておく．

エントロピーの最大化

製品 \(i\) の購入確率を \(p_i\) と書くことにする．天下り的に以下のエントロピー最大化問題を考える．
\begin{align}
\text{maximize}\qquad&-\sum_{i=1}^K\;p_i\log p_i\\
\text{subject to}\qquad & \sum_{i=1}^K\;p_i=1\\
& \sum_{i=1}^K\; c_ip_i=\bar c
\end{align}
ここで，サンプル内の平均購入価格を
\begin{align}
\bar c=\frac1N\sum_{i=1}^K n_ic_i
\end{align}
と定義した．一つ目の制約条件は確率の正規化条件，二つ目はランダムサンプリングによって観測された価格を再現するための制約条件．

以下，これをラグランジュ未定乗数法でまじめに解く．
\begin{align}
L=-\sum_{i=1}^K\;p_i\log p_i+\mu\bigg(1-\sum_{i=1}^K \; p_i\bigg) + \lambda\bigg(\sum_{i=1}^K c_ip_i-\bar c\bigg)
\end{align}
として，\(p_i\) で微分してゼロと置けば
\begin{align}
-\log p_i – 1 + \mu + \lambda c_i = 0
\end{align}
となり，式変形すれば
\begin{align}
p_i = \exp(\mu-1+\lambda c_i)
\end{align}
となる．これを正規化条件に代入すれば，
\begin{align}
\exp(\mu-1) = \bigg(\sum_{i=1}^K\exp(\lambda c_i)\bigg)^{-1}
\end{align}
を得るので，
\begin{align}
p_i=\frac{\exp(\lambda c_i)}{\sum_{i=1}^K\exp(\lambda c_i)}
\end{align}
を得る．これは条件付きロジットの式になっている．

もう一つの未定乗数 \(\lambda\) については，この \(p_i\) を制約条件に代入することにより，
\begin{align}
\sum_{i=1}^K(c_i-\bar c)\exp(\lambda c_i)=0
\end{align}
の解になっていることがわかる．これは一般には数値計算で求めるしかないので，ひとまずここで計算を止め，この解を \(\lambda^*_{E}\) と書くことにする．

以上で最大エントロピー原理を仮定することで製品の選択確率が結果として条件付きロジットになることがわかった．そしてそのラグランジュ未定乗数 \(\lambda\) は条件付きロジットの係数に対応することもわかった．

条件付きロジットの最尤推定

条件付きロジットによる最尤推定が，上で得た未定乗数 \(\lambda^*_{E}\) と等しいことを示す．

条件付きロジットモデル
\begin{align}
p_i=\frac{\exp(\lambda c_i)}{\sum_{i=1}^K\exp(\lambda c_i)}
=\frac{\exp(\lambda c_i)}{Z(\lambda)}
\end{align}
の最尤推定量 \(\lambda^*_{MLE}\)は
\begin{align}
\prod_{i=1}^K \;\;p_i^{n_i} = \prod_{i=1}^K \bigg(\frac{\exp(\lambda c_i)}{Z(\lambda)}\bigg)^{n_i}
\end{align}
を最大化する \(\lambda\) である．対数をとると，
\begin{align}
-N\log Z(\lambda) + \sum_{i=1}^Kn_i\lambda c_i
\end{align}
となるので(\(N\) はサンプル数)，\(\lambda\) で微分して右辺をゼロと置くと
\begin{align}
-N \frac{Z’(\lambda)}{Z(\lambda)} + \sum_{i=1}^Kn_ic_i=0
\end{align}
となる．式変形をして
\begin{align}
\quad&-Z’(\lambda) + Z(\lambda)\cdot\frac1N\sum_{i=1}^Kn_ic_i=0\\
\Longleftrightarrow\quad&-Z’(\lambda) + Z(\lambda)\cdot \bar c=0\\
\Longleftrightarrow\quad&\sum_{i=1}^K(c_i-\bar c)\exp(\lambda c_i)=0
\end{align}
となる．この非線形方程式を解けば \(\lambda^*_{MLE}\) を求めることができる．

この非線形方程式はエントロピーの最大化によるラグランジュ未定乗数である \(\lambda^*_E\) を求めるために上で導出したものと同じものである．従って
\begin{align}
\lambda^*_{MLE}=\lambda^*_E
\end{align}
が示された．

対数線形モデルと等価なエントロピー最大化問題

データ \(\{(\boldsymbol{x}_j, i_j)\}_{j=1}^N\) と素性関数 \(\boldsymbol\phi\) が与えられた時，対数線形モデルの最尤推定量は以下のエントロピー最大化問題のラグランジュ未定乗数に対応する．K はクラス数である．
\begin{align}
\text{maximize} \qquad
&-\sum_{i=1}^K\sum_{j=1}^NP(i|\boldsymbol{x}_j)\log P(i|\boldsymbol{x}_j)\\
\text{subject to} \qquad
&
\sum_{i=1}^K P(i|\boldsymbol{x}_j)=1\qquad \forall j=1,\cdots,N\\
&
\frac1N\sum_{j=1}^N\bigg[\sum_{i=1}^K \boldsymbol{\phi}(\boldsymbol{x}_j,i)P(i|\boldsymbol{x}_j)\bigg]
=\frac1N\sum_{j=1}^N\boldsymbol{\phi}(\boldsymbol{x}_j,i_j)
\end{align}
２つ目の制約式の右辺は素性のデータ平均になっている．データ平均とモデル平均が一致するような制約条件．

まとめ

条件付きロジットモデルとエントロピーの最大化の関係をみた．説明変数が複数のときには、エントロピー最大化の制約条件が複数になるだけで本質的に同じになる．どうでもいいことだが，機械学習でよくやるような対数尤度関数に L1 正則化項を加えるタイプの目的関数を使った場合，エントロピーは最大化されない（もちろん L2 でも同じ）．

蛇足：統計力学との関連

価格を状態のエネルギーと置き直せば，ボルツマン分布のはなしと同じこと．エネルギー一定の条件下でエントロピーを最大化するとボルツマン分布が導出される，というアレを単に言い換えただけです．この場合のラグランジュ未定乗数は温度の逆数に比例するような定数になる．

行動ゲーム理論入門

posted at 2012.5.9

川越 敏司
エヌティティ出版

Amazon.co.jp で詳細を見る

ゲーム理論

ゲーム理論をすこしかじったことがあればご存知のように

• ジョン・ナッシュが「ナッシュ均衡」という概念を提唱して、
• 不動点定理を使って混合戦略ナッシュ均衡のの存在を証明した、

というのは有名すぎる事実。映画「ビューティフル・マインド」の主人公としてご存じの方も多いと思う。

「行動ゲーム理論入門」はナッシュ均衡のその先の展開について非常にわかりやすく書かれた本ということになる。以下、この本のさわりの部分を自分なりに要約してみる。

合理的エージェントの世界

そもそも、古典的な経済学に出てくる経済活動をする人たち（エージェント）は「合理的」であるとされる。彼らは合理的なスーパーマンなのでゲームが与えられたら、ただちにナッシュ均衡を「計算」して、自分のとるべき行動を決定する。

これが何を意味するのか。例えば 6×6 オセロ^[1]のような「ゲーム」を考えてみよう。これは実は後手必勝になることが証明されている。つまり、合理的なエージェント同士が（お金をかけて）対戦すれば、かならず後手が勝利することを意味している。

計算資源の有限性

問題がどこにあるのか？といえば、 6×6 オセロの証明はコンピュータを二週間走らせ続けることで証明された（1994年）、ということだ。これは「ふつうの」人間業なのだろうか？という疑問からこの本はスタートする。

この疑問を一般化しよう。原理的には解（最善手）が存在するけれども、それを求めることがチューリングマシンの意味で不可能となるような問題、ようするに「アルゴリズムを構成することができない問題」に対しても、最善手を見つけてしまうような「彼ら」は経済活動を行う人間のモデルとして妥当なのだろうか？

このような考察から、人間＝エージェントは神のごとく無限の計算能力をもつものとしてではなく、有限の計算資源を持った「限定合理的なエージェント」としてモデル化されるべきだ、と「結論」されることになる。こういう論理展開にはしびれまくる。

ただし、個人的な意見として、人間の計算能力をどの程度か、と仮定するのは一般論としては非常に微妙な問題も含んでいる思う。チューリングマシンと高々同程度だ、という考え方は（特に根拠はないが）個人的には妥当というか、むしろ目からウロコが落ちる感じがしたが、一部の人々にとっては議論を呼びそうな内容かもしれない。

アレゲな人たちだけではなく、まっとうな科学者の間でも意見がわかれそうだ（とはいえ「脳とコンピュータの違い」によればチューリングマシンとみなすことにはそれなりの妥当性がありそうでもあるが）。

その後の展開

この後、話は均衡に吸い込まれるための力学系の話や、さらにエージェントの行動決定が強化学習／信念学習によって学習されるケースの考察など興味深い話題を経て、非効率な均衡を制度の設計によって解消するための方法論である「メカニズムデザイン」まで話は及ぶ。どの章も非常に平易に書かれていて、かつ興味深いものばかり。

まとめ

ということで、知的好奇心を最大限に満足する本でした。この本が経済学者にとって有益かどうかは（僕は経済学者じゃないから）わからないけど、人の行動に日々頭を悩ます企業のマーケティング担当者とか、ゲームデザイナーとか、スマホアプリ開発者など「人間の行動に深く関わる技術者」が読んでみてもいいんじゃないだろうか。得るものは必ずあると思う（ただし、ある程度理論が好きな人に限るとは思うが）。

最後に余談というかメモ。世の中の現実的な問題は均衡から逸脱して極めて複雑でダイナミックな挙動をしめすような例が少なくない。例えば

• Google と SEOスパマーとのイタチごっこ
• 予測不可能な非定常性を示す交通渋滞

などなど。こういった扱いづらいものたちを単純に統計学・機械学習の問題として扱ってしまうのではなく、人間が相互作用しあうゲーム理論という視点から眺めてみると見通しがよくなることもあるかな、というのがこの本を読んだ教訓。

1. ^[1] 原著では実際にはヘックスという別のゲームを使って詳細な説明がなされている。 ↩

あの検索結果は個人的には結構便利だとは思うのですが、レイテンシがわりと大きいため、一番上のリンクをクリックしようとした瞬間にあの水色のボックスが出現したりすることが多いのが少し困る。

かといって機能を切ってしまうのもなんとなく忍びないのですこし改良してみた。最初は javascript だけでやろうとしたけど、手持ちの chrome には stylebot という拡張機能がついていたのでそれを使うことにした。

どんなふうに変化するか

こんな感じの画面が

こうなります。これで水色のこいつが急に現れても動じなくてよくなります。

やりかた

googleで適当に検索して右クリック → stylebot(なければインストールしておく) → Style Element

とすると html の要素が選択できるので例の水色のアレを選択して、右下の Advanced をクリック。右上のIDが #evernoteResultStatsMessage になっていることを確認する。だいたい下のような感じの画面のハズ。

そして、下のような感じでお好みのスタイルを右側の CSS for selected element(s) の下側にコピペすればOK。

width: 450px;
position: fixed;
bottom: 50px;
left: 760px;

これで完了。便利か便利じゃないかはよくわかりません。

以下は経験累積分布関数を書くためのコード片。

cumplot <- function(x,...){
  plot(sort(x),(1:length(x))/length(x),type="s",...)
}

cumplot(rnorm(100),xlab="",ylab="",xlim=c(-3,3))
curve(pnorm,add=T,col=2)
legend("topleft",legend=c("empirical CDF","normal CDF"),
       lt=1,col=1:2)

こんな図が書ける。

ほかにも type=”S” (大文字) なんてのがあって、だいたい同じなんだけど、S は上にずれる。経験累積分布の場合は小文字 s が正解。

• 一見、ポアソン分布っぽいが、どれも平均＞分散となっていて underdispersion ぎみ。
• \(\alpha\) が小さいとテーブルの数は少なく、大きくなるにつれてテーブルの数の平均、分散は増加する
• レストランを訪れる人数(図ではdata size)が増加するとやはりテーブルの数の平均、分散は増加する。しかし増加の仕方はゆっくり(平均、分散ともに理論値がわかる。増加の仕方は漸近的に対数 → 記事の一番下の補足)。
• 【わかること】CRPを事前分布として使うときは、潜在クラスタの数の事前分布をこの分布のように仮定していることになる。data size は与えられたデータの数なので変更不可。\(\alpha\) を使って事前知識をモデル化するが、１パラメータなので平均と分散の両方を独立に制御することはできない。実際、データ数10000で\(\alpha=3\)とすると、潜在クラス数が5個以下の可能性をほとんど排除していることになる(右下の図)

実験に使ったR的なスクリプト。

#--------------------------------------------------
# CRP で確保されるテーブルの数の分布に関する実験

CRP_probs <- function(size,alpha){
  alpha/((1:size)-1+alpha)
} # Polyaの壺的な確率を返す

rCRP_numLatentClass <- function(n, size, alpha=1){
  probs <- CRP_probs(size,alpha)
  sapply(1:n,function(i) sum(runif(size) < probs))
}  # テーブルの数をサンプリングするだけならこれだけでOK

numLC_theoretical <- function(size,alpha){
  pp <- CRP_probs(size,alpha)
  list(mean=signif(sum(pp),3),var=signif(sum(pp*(1-pp)),3))
}  # テーブルの数の平均、分散の理論値を返す

#--- Main ---

library(MASS)
par(mfrow=c(3,3))
xlab <- "Number of tables allocated in CRP"
for(alpha in c(0.5,1,3)){
  for(datasize in 10^(2:4)){
    # テーブル数のシミュレーション10000回
    num.table.simulated <- rCRP_numLatentClass(10000,datasize,alpha)
    # 理論的な平均、分散を計算
    theo <- numLC_theoretical(datasize,alpha)

    # プロット
    truehist(num.table.simulated,xlim=c(0,40),ylim=c(0,0.3),h=1,xlab=xlab)
    text(20,0.3,paste("data size =",datasize,"/ alpha =",alpha),cex=2)
    text(30,0.27,paste("mean =",theo$mean,"/ sdv =",signif(sqrt(theo$var),3)),cex=1.2)
  }
}

補足、というか疑問

よく、テーブル数の平均値は漸近的に \(\alpha\log n/\alpha\) になる、みたいなことが書いてあるけど、級数を使えば厳密計算可能なのでここではそちらを採用している。
\begin{align*}
E[\text{# of tables}]=\sum_{i=1}^n\frac{\alpha}{\alpha-1+i} \sim \alpha\log n/\alpha\qquad (n\to\infty)
\end{align*}
という漸近挙動。同様に分散も厳密計算可能。
\begin{align*}
V[\text{# of tables}] = \sum_{i=1}^n\frac{\alpha}{\alpha-1+i}\bigg(1-\frac{\alpha}{\alpha-1+i}\bigg) \sim ??\qquad (n\to\infty)
\end{align*}
この右辺がどうなるかわからない。数値的には対数的な挙動になることをチェック済み。なんとなく、てきとうな定数に対して \(C+\alpha\log n/\alpha\) になりそうな気がするが。

この関数ははじめて知ったのですが、ヘルプを見て意訳すると以下の様な感じです。

tracemem(x) を実行すると x について duplicate (複製)が生じた時にメッセージを表示する。これは2つのオブジェクトがメモリを共有している場合において、1つが変更された時に生じる。ちなみに untracemem(x) でメッセージフックを解除できる。

ということで関数の内部でコピーが起きたか、を判別するのにピッタリです。

今回の内容：

• tracemem を使って値渡し、参照渡しを確かめる
• 参照渡しなのか、値渡しなのか、が確定するタイミングについて考える

tracemem を使った方法

以下の方法は @sfchaos さんに教えてもらった方法そのままです。前回同様、prod1 は行列 A について値渡しになりそうな関数で、prod2 は参照渡しになりそうな関数です。

prod1 <- function(A,x){
  A <- A + diag(x)
  A %*% x
}

prod2 <- function(A,x){
  A %*% x
}

N <- 1000
A <- matrix(rnorm(N*N),nc=N)
x <- rnorm(N)

tracemem(A)
# => [1] "<0x7e790008>"
invisible(prod1(A,x))  # invisible は結果を print しないようにする関数
# => tracemem[0x7e790008 -> 0x7dfe0008]: prod1  # コピーが発生した！

invisible(prod2(A,x))
# => 何も表示されない！＝コピーが生じていない！

ということで、前回は実行時間から推論しただけでしたが、やはり引数を変更するとコピーが生じる、ということで間違いないことが確認できました。

複製はどのタイミングで生じるのか？

前回、以下のように書きました。

そして、引数が変更されるかされないかはパースした段階でわかる(なのでパースの段階で値渡しか参照渡しかを判別することが可能)

ですが、これは誤りでした。実際、以下のような関数はパースの段階で値渡しか参照渡しかを判別できるでしょうか？

prod3 <- function(A,x,add=T){
  if(add) A <- A + diag(x)
  A %*% x
}

add が真のときは引数が変更されて、偽のときは引数が変更されません。

これをパースの時点で判別しようとすると、Rの副作用を作らないという原則から add がいかなる値であろうともコピーを行うことになるはずです。

もう一つの可能性としては、実際に変更が起きたその瞬間にコピーを作る、というものがありえるでしょう。

実験してみます。

N <- 1000
A <- matrix(rnorm(N*N),nc=N)
x <- rnorm(N)

tracemem(A)
# => [1] "<0x7dfe0008>"

invisible(prod3(A,x,add=T))
# => tracemem[0x7dfe0008 -> 0x7ef40008]: prod3

invisible(prod3(A,x,add=F))
# => 何も表示されない！＝コピーが生じていない！

同じ関数でも引数の状態によってコピーが発生したり、しなかったり。add=F のときは prod3 の if の内部まで進まないため、A が変更されず、したがってコピーが発動しない、ということになります。

つまりRは

• 引数のコピーを作るか(値渡しか)、作らないか(参照渡しか)は実際に引数が変更される瞬間ギリギリまで判別しない、
• 変更される瞬間(直前？)で重い腰を上げてコピーを作成する(遅延評価)

という挙動をしているようですね。

まとめ

• Rは基本的には値渡しであり、C++のように引数として与えられた変数を変更することで外側の世界に影響させることはできない
• 関数内部で引数を変更しない場合は、コピーが生じない (C++ の const& のようなイメージ)
• 関数内部に引数を変更するコードがあったとしても、実際に引数が変更される段まではコピーは生じない (遅延評価)

C++みたいな言語では「フツーに」引数を渡すと全部値渡しになって(特に行列のような巨大なオブジェクトを渡す場合には)効率が悪いので、ポインタや参照で渡したり、副作用を気にする場合は const 参照で渡したりする。

さて、上で述べた R の自動判断機能は以下のような事実に基づくようだ。

• そもそも値渡しは関数に引数を渡した段階でオブジェクトのコピーを生成して「引数として渡された変数を関数の内部で変更してもスコープの外では値が変更されない」ことを保証するのだが、
• オブジェクトが関数の内部で変更されないことが保証されるならば「関数の実行中はスコープの外でも値が変更されない」ことは保証されるのでコピーをそもそも生成する必要がない、
• そして、引数が変更されるかされないかはパースした段階でわかる(なのでパースの段階で値渡しか参照渡しかを判別することが可能) → 間違いでした。詳細はRにおける値渡しと参照渡し(2)に書きました。

実験

これは以下のようにして確かめることができる、はず。

prod1 <- function(A,x){
  A[1,1] <- A[1,1] + 1
  A %*% x
}

prod2 <- function(A,x){
  x[1] <- x[1] + 1
  A %*% x
}

• prod1, prod2 はともに引数として渡された行列 A とベクトル x の積を計算する
• prod1 では A[1,1] に 1 を加える
• prod2 では x[1] に 1 を加える(これはprod1の代入作業のコストと揃えるため)
• その後、積を計算する

ということをやっているのだが、上で述べたようなことがただしければ、

• prod1 では行列 A のコピーが発生し
• prod2 ではベクトル x のコピーが発生する

ため、より巨大なオブジェクトを渡すことになる prod1 が (生じる四則演算の数は同一にもかかわらず) 大幅に遅くなることが予測される。

実際、1000 x 1000 程度の行列を考えると以下の様な結果が得られる。

N <- 1000
A <- matrix(rnorm(N*N),nc=N)
x <- rnorm(N)

system.time( for(i in 1:1000) prod1(A,x) )
# =>   user  system elapsed
# =>  11.03    3.50   14.56

system.time( for(i in 1:1000) prod2(A,x) )
# =>  user  system elapsed
# =>  4.59    0.01    4.62

prod1のほうがかなり遅くなっていることが分かる。これより、上で述べたことはおそらく正しいだろうと結論される。

まとめ

このことを知ったからといって高速なプログラムが書けるようになるわけではないが、少なくとも「こんな大きなオブジェクトを関数に渡すのは気が引ける(なのでグローバル変数にしてしまえ)」という不安を払拭することができると思う。

【追記】続きを書きました。

絵のせつめい。

• データ数 n を変化させた各グラフの中で、事後分布から20組のパラメータをサンプリング。
• 一組のパラメータを90%信頼楕円として表している
• 点線は真の分布。黒丸は事前分布のモード(最頻値)。
• データが少ないうちは事後分布がばらつく、つまりパラメータの不確実性が大きいが、データ数が256を超えたあたりからほぼ真の分布に収束する

下のコードのコメントにも書いたが、ハイパーパラメータを学習しない場合のレシピとして、NIW分布の平均パラメータ \(\mu_0\)、分散パラメータ \(V_0\) に自信がないときはそれぞれ \(k_0, \nu_0\) を小さく設定すればいい、はず。事前分布の影響を小さくできる。

参考その１：前回のエントリ → 逆Wishart分布を図示してみる
参考その２：事後分布のパラメータの求め方 → Wikipedia/Conjugate prior

お絵かきスクリプト in R。ellipse, MCMCpack, mvtnorm パッケージは入っていなければインストールする必要あり。

library(ellipse)   # conffidence ellipse
library(MCMCpack)  # wishart
library(mvtnorm)

#----------------------------------------------------------------------------
# Baysian estimation of 2 dimensional normal distribution
#----------------------------------------------------------------------------

d <- 2     # dimension

#----------------------------------------------------------------------------
# Hyperparameters for NIW (Normal inverse wishart)
k0 <- 0.1        # see below
mu0 <- rep(0,d)  # hyper mean
v0 <- 3.5        # see below
V0 <- diag(rep(10,d)) # hyper variance
Phi0 <- V0*(v0-d-1)
prior.hyper.par <- list(k=k0,mu=mu0,v=v0,Phi=Phi0)

#------------------------------------------------------------------------------------
# [Recipe for determining hyperparameters v0 and k0]
#  1. Less confidence for the hyper mean(mu0), take smaller k0; typically, 0<k0<<1
#  2. Less confidence for the hyper variance(V0), take smaller v0; typically, v0~1+p
#------------------------------------------------------------------------------------

#-----------------------------------------
# Bayesian estimation ( bayesian update)
bayes.update <- function(X,hyper.par){

  k0 <- hyper.par$k
  mu0 <- hyper.par$mu
  v0 <- hyper.par$v
  Phi0 <- hyper.par$Phi

  if(!is.matrix(X)){
    # This is n=1 case that we have to deal with as special because of R issue
    n <- 1
    EX <- X
    X <- t(X)
    C <- matrix(rep(0,d*d),nc=d)
  } else {
    n <- dim(X)[1]
    EX <- colMeans(X)
    C <- (n-1)*cov(X)
  }
  mu <- (k0*mu0 + n*EX)/(k0+n)
  k <- k0+n
  v <- v0+n
  Phi <- Phi0 + C + k0*n/(k0+n)*((EX-mu0) %*% t(EX-mu0))

  list(k=k,mu=mu,v=v,Phi=Phi)  # This new parameters list is a bayesian update result!!

}

#------------------------------------------------------------------
# Sampling from posterior
sample.posterior <- function(n,bayes.fit){
  k <- bayes.fit$k
  v <- bayes.fit$v
  Phi <- bayes.fit$Phi
  mu <- bayes.fit$mu
  result <- list()
  for(i in 1:n){
    # Sampling mu and V from NIW
    V <- riwish(v,Phi)  # 1. sampling covariance matrix by inverse wishart
    result[[i]] <- list()
    result[[i]]$V <- V
    result[[i]]$mu <- rmvnorm(1,mu,V/k) # 2. sampling mu by normal dist.
  }
  result
}

#--------------------------------------------------------------
# Test case
#  --- true distribution
V.true <- matrix(c(3,-1.5,-1.5,1.8),nc=d)
mu.true <- rep(10,d)
#  --- generating random variables
X <- rmvnorm(20000,mu.true,V.true)

par(mfrow=c(3,4))  # dividing graphic device
j <- 1
ids <- 2^seq(0,11)
hc <- rainbow(12)
for(i in ids){
  Y <- X[1:i,]
  bayes.fit <- bayes.update(Y,prior.hyper.par)  # estimating posterior
  post.samp <- sample.posterior(20,bayes.fit)  # sampling from posterior
  plot(Y,pch=".",col="gray",xlim=c(-10,20),ylim=c(-10,20),xlab="",ylab="") # just plotting raw data

  # plotting posterior samples
  for( theta in post.samp ){
    mu <- theta$mu
    V <- theta$V
    elp <- t(apply(ellipse(V,level=0.9),1,function(x) x+mu))
    lines(elp,col=hc[j],lw=2)
  }

  # plotting true distribution
  true.dist <- t(apply(ellipse(V.true,level=0.9),1,function(x) x+mu.true))
  lines(true.dist,type="l",lw=2,lt=4)

  # plotting mode of the prior
  prior <- ellipse(Phi0/(v0+3), level=0.9) + mu0
  lines(prior,lw=2)

  text(20,-7,paste("n =",i),pos=2,cex=2)
  j <- j+1
}

dev2bitmap(file="normal_posterior.jpg",taa=4,gaa=4,width=15,height=12)