[R]パーティクルフィルタ・平滑化の実装

概要

• パーティクルフィルタ・平滑化を実装し、DLMパッケージによる結果との比較を行なう
• 平滑化の計算が合っているのか微妙。教えて偉い人！

Rコード

サンプル時系列の生成

参考文献[1]のP.219を参考に、dlmパッケージを使って適当な時系列を作成します。コレに対してパーティクルフィルタ・平滑化を適用させます。
今回は単純な線形ガウシアンモデル。パラメータも特定させておきます。

答え合わせように、フィルタ、平滑化も先に計算しておきます(各々modFilt, modSmoothに格納)。

library(pipeR)
library(dlm)

#------------------------------------------------------------------------------
# Generate sample data
#------------------------------------------------------------------------------
mod <- dlmModPoly(1, dV = 2, dW = 1, m0 = 10, C0 = 9)
n <- 100
set.seed(23)
simData <- dlmForecast(mod = mod, nAhead = n, sampleNew = 1)
y <- simData$newObs[[1]]

modFilt <- dlmFilter(y, mod)
modSmooth <- dlmSmooth(modFilt)

theta.filt.kf <- modFilt$m[-1]
theta.smooth.kf <- modSmooth$s[-1]

sd.filt.kf <- with(modFilt, sqrt(unlist(dlmSvd2var(U.C, D.C))))[-1]
sd.smooth.kf <- with(modSmooth, sqrt(unlist(dlmSvd2var(U.S, D.S))))[-1]

パーティクルフィルタ本体

重点遷移密度の選び方について、DLMであれば最適重点核として\( y_t \)が与えられたもとでの事後分布を選ぶのが良いのですが、今回は事前分布を使っています。
非ガウス分布の実装も視野に入れているのでこういう仕様にしています。パッと見た雰囲気では、この事後分布を一般的に書くのはできないんですよね？(たぶん)

さらに、参考文献[1]のP.216に紹介されている多項リサンプリングを入れています。
これは少数の粒子が大きい重みをしめてしまうことによるモンテカルロ近似の劣化を防ぐための措置です。

パーティクルフィルタのメインの実装に関しては参考文献[2]のP.214のアルゴリズムをなぞっているつもりです。

ParticleFilterNorm <- function(y, nParticle, nEff, x0,
                               systemSd, obsSd, smooth = F, smoothLag = 20){
 
  if (length(x0) != nParticle){
    return ("ERROR: The Length of x0 should match the number of particles")
  }
 
  n <- length(y)
  pfOut <- wt <- matrix(NA_real_, n + 1, nParticle)
  pfOut[1, ] <- x0
  wt[1, ] <- 1 / nParticle
  N.eff <- rep(N, n)
 
  if (smooth){
    pfOutSmooth <- wtSmooth <- matrix(NA_real_, n + 1, nParticle)
    pfOutSmooth[1, ] <- x0
    wtSmooth[1, ] <- 1 / nParticle
  }else{
    pfOutSmooth <- wtSmooth <- NaN
  }
 
  for (it in 2 : (n + 1)){
    #calculate p_n
    pfOut[it, ] <- pfOut[it - 1, ] + rnorm(nParticle, 0, systemSd)
   
    wt[it, ] <- dnorm(y[it - 1] - pfOut[it, ], 0, obsSd)
    wt[it, ] <- wt[it, ] / sum(wt[it, ])
    f <- sample(pfOut[it, ], size = nParticle, replace = T, prob = wt[it, ])
    pfOut[it, ] <- f
   
    N.eff[it] <- 1 / crossprod(wt[it, ])
    if (N.eff[it] < nEff){
      # multinominal resampling
      tmp <- sample(pfOut[it, ], size = nParticle, replace = T, prob = wt[it, ])
      pfOut[it, ] <- tmp
      wt[it, ] <- 1 / nParticle
    }
   
    #smoother
    if (smooth){
      #calculate p_n
      pfOutSmooth[it, ] <- pfOutSmooth[it - 1, ] + rnorm(nParticle, 0, systemSd)
     
      wtSmooth[it, ] <- dnorm(y[it - 1] - pfOutSmooth[it, ], 0, obsSd)
      wtSmooth[it, ] <- wtSmooth[it, ] / sum(wtSmooth[it, ])
     
      if (it >= smoothLag){
        #Correct?
        for (t in 1 : smoothLag){
          tmp <- sample(pfOutSmooth[it - t + 1, ], size = N, replace = T, prob = wtSmooth[it, ])
          pfOutSmooth[it - t + 1, ] <- tmp
        }
      } 
    }
 
  }
 

  return( list(
    pFilt = pfOut,
    pSmooth = pfOutSmooth,
    weightFilt = wt,
    weightSmooth = wtSmooth,
    nEff = N.eff
  ))
}

プロットなど

y.pfに上述のパーティクルフィルタ関数の実行結果を格納しています。

N <- 1000
x0 <- rnorm(N, mod %>>% m0, mod %>>% C0 %>>% sqrt)
systemSd <- mod %>>% W %>>% sqrt %>>% drop
obsSd <- mod %>>% V %>>% sqrt %>>% drop
y.pf <- ParticleFilterNorm(y, N, N / 2, x0, systemSd, obsSd, T, 2)

# Filter distribution estimated by particle fileter
theta.filt <- sapply(2 : (length(y) + 1), function(i)
  weighted.mean(y.pf$pFilt[i, ], y.pf$weightFilt[i, ]))
sd.filt <- sapply(2 : (length(y) + 1), function(i)
  weighted.mean((y.pf$pFilt[i, ] - theta.filt[i])^2, y.pf$weightFilt[i, ]))

# Filter plot
y %>>% plot(type = "l")
theta.filt %>>% lines(col = 2, type = "l", lwd = 2)
(theta.filt + sd.filt) %>>% lines(col = 2, type = "l", lty = 2)
(theta.filt - sd.filt) %>>% lines(col = 2, type = "l", lty = 2)
theta.filt.kf %>>% lines(col = 3)
legend("bottomright", c("Observation", "theta(Particle Filter)", "theta(Kalman Filter)"),
       lty = rep(1, 3), col = c(1, 2, 3), lwd = c(1, 2, 1), bty="n")

sd.filt %>>% plot(type = "l", col = 2)
sd.filt.kf %>>% lines(type = "l", col = 3)
legend("topright", c("Sd of theta(Particle Filter)", "Sd of theta(Kalman Filter)"),
       lty = rep(1, 2), col = c(2, 3), lwd = rep(1, 2), bty="n")

# Smooth distribution estimated by particle filter
theta.smooth <- sapply(2 : (length(y) + 1), function(i)
  weighted.mean(y.pf$pSmooth[i, ], y.pf$weightSmooth[i, ]))
sd.smooth <- sapply(2 : (length(y) + 1), function(i)
  weighted.mean((y.pf$pSmooth[i, ] - theta.smooth[i])^2, y.pf$weightSmooth[i, ]))

# Smooth plot
y %>>% plot(type = "l")
theta.smooth %>>% lines(col = 2, type = "l", lwd = 2)
(theta.smooth + sd.smooth) %>>% lines(col = 2, type = "l", lty = 2)
(theta.smooth - sd.smooth) %>>% lines(col = 2, type = "l", lty = 2)
theta.smooth.kf %>>% lines(type = "l", col = 4)
legend("bottomright", c("Observation", "theta(Particle Smoother)", "theta(Kalman Smoother)"),
       lty = rep(1, 3), col = c(1, 2, 4), lwd = c(1, 2, 1), bty="n")

sd.smooth %>>% plot(type = "l", col = 2)
sd.smooth.kf %>>% lines(type = "l", col = 4)
legend("topright", c("Sd of theta(Particle Smoother)", "Sd of theta(Kalman Smoother)"),
       lty = rep(1, 2), col = c(2, 4), lwd = rep(1, 2), bty="n")

結果

上記のプロットを行なったものが以下

フィルタ分布

フィルタに関してはカルマンフィルタと同じような結果が出ていそう。
赤破線はパーティクルフィルタからもとめた1標準偏差です。

フィルタ分布の標準偏差に関しては、パーティクルフィルタは精度が落ちていますね。参考文献[1]よりも明らかに悪そうです。これは重点遷移密度に事後分布を選んでいなからなのでしょうか…

平滑化

平滑化ラグは2を使用。なんとなく近い分布が得られていそうな気がしますが、微妙に違う感じにも。。

標準偏差は以下、フィルタ分布よりは精度が上がっているような気がしますがそれでもかなり暴れん坊将軍ですな。

平滑化(ラグが20の場合)

参考文献[2]によると、ラグは20くらいを選ぶと良いと書いてあるのでそれを選んだ場合の結果。
ラグを含む分布の精度が極端に悪い。なぜでしょう。

今後の課題

• そもそも平滑化あってるのか？
• 非ガウス分布
• 未知パラメータを含むパーティクルフィルタ

参考文献

Amazon.co.jp： Rによるベイジアン動的線形モデル (統計ライブラリー): G.ペトリス, S.ペトローネ, P.カンパニョーリ, 和合 肇, 萩原 淳一郎: 本
http://www.amazon.co.jp/dp/4254127960

Amazon.co.jp| 時系列解析入門| 北川 源四郎| 本| 微積分・解析
http://www.amazon.co.jp/dp/4000054554

モンテカルロ・フィルタおよび平滑化について
http://www.ism.ac.jp/editsec/toukei/pdf/44-1-031.pdf

逐次モンテカルロ/(粒子|パーティクル|モンテカルロ)フィルタを実装してみた – My Life as a Mock Quant
http://d.hatena.ne.jp/teramonagi/20140525/1400996808

Particle Filter
http://daweb.ism.ac.jp/koza/koza2008/PF_Nakano20081030.pdf