[R]未知パラメータがある場合のパーティクルフィルタ

概要

• 未知パラメータ(ノイズの分散など)を含む場合のパーティクルフィルタの実装
• システムノイズが正規分布の場合とコーシー分布の場合の比較

システムノイズが正規分布の場合

詳しい理論に関しては参考文献のP.225辺りからを御覧ください。

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]


#------------------------------------------------------------------------------
# Particle Filter (Normal distribution)
#------------------------------------------------------------------------------
ParticleFilterNorm <- function(y, nParticle, nEff, x0, systemVar0, obsVar0, a){
 
  if (length(x0) != nParticle){
    return ("ERROR: The Length of x0 should match the number of particles")
  }
 
  #initial settings
  n <- length(y)
  pfOut <- wt <- matrix(NA_real_, n + 1, nParticle)
  pfOutSystemVar <- pfOutObsVar <- matrix(NA_real_, n + 1, nParticle)
 
  pfOut[1, ] <- x0
  pfOutSystemVar[1, ] <- systemVar0
  pfOutObsVar[1, ] <- obsVar0
  wt[1, ] <- 1 / nParticle
  N.eff <- rep(N, n + 1)
 
  for (it in 2 : (n + 1)){
    it %>>% print
   
    meanObs <- weighted.mean(pfOutObsVar[it - 1, ], wt[it - 1, ])
    meanSystem <- weighted.mean(pfOutSystemVar[it - 1, ], wt[it - 1, ])
    varObs <- weighted.mean((pfOutObsVar[it - 1, ] - meanObs)^2, wt[it - 1, ])
    varSystem <- weighted.mean((pfOutSystemVar[it - 1, ] - meanSystem)^2, wt[it - 1, ])
   
    muObs <- a * pfOutObsVar[it - 1, ] + (1 - a) * meanObs
    sigma2Obs <- (1 - a^2) * varObs
    alphaObs <- muObs^2 / sigma2Obs
    betaObs <- muObs / sigma2Obs
   
    muSystem <- a * pfOutSystemVar[it - 1, ] + (1 - a) * meanSystem
    sigma2System <- (1 - a^2) * varSystem
    alphaSystem <- muSystem^2 / sigma2System
    betaSystem <- muSystem / sigma2System
   
    Ik <- sample(nParticle, size = nParticle, replace = T,
                 prob = wt[it - 1, ] * dnorm(y[it - 1] - pfOut[it - 1, ], 0, sqrt(muObs)))
    pfOutObsVar[it, ] <- rgamma(nParticle, shape = alphaObs[Ik], rate = betaObs[Ik])
    pfOutSystemVar[it, ] <- rgamma(nParticle, shape = alphaSystem[Ik], rate = betaSystem[Ik])
    pfOut[it, ] <- pfOut[it - 1, Ik] + rnorm(nParticle, 0, sqrt(pfOutSystemVar[it, ]))
   
    wt[it, ] <- dnorm(y[it - 1] - pfOut[it, ], 0, sqrt(pfOutObsVar[it, ])) /
      dnorm(y[it - 1] - pfOut[it - 1, Ik], 0, sqrt(muObs[Ik]))
    wt[it, ] <- wt[it, ] / sum(wt[it, ])
   
    N.eff[it] <- 1 / crossprod(wt[it, ])
    if (N.eff[it] < nEff){
      # multinominal resampling
      tmp <- sample(nParticle, size = nParticle, replace = T, prob = wt[it, ])
      pfOut[it, ] <- pfOut[it, tmp]
      pfOutObsVar[it, ] <- pfOutObsVar[it, tmp]
      pfOutSystemVar[it, ] <- pfOutSystemVar[it, tmp]
     
      wt[it, ] <- 1 / nParticle
    }
   
   
  }
 
  return( list(
    theta = pfOut,
    systemVar = pfOutSystemVar,
    obsVar = pfOutObsVar,
    wt = wt,
    nEff = N.eff
  ))
}


#------------------------------------------------------------------------------
# MAIN
#------------------------------------------------------------------------------
N <- 10000
x0 <- rnorm(N, mod %>>% m0, mod %>>% C0 %>>% sqrt)
systemVar0 <- runif(N, 0, 10)
obsVar0 <- runif(N, 0, 10)
a <- 0.975
y.pf <- ParticleFilterNorm(y, N, N / 2, x0, systemVar0, obsVar0, a)


# Plot theta
theta.avg <- sapply(2 : (length(y) + 1), function(i)
  weighted.mean(y.pf$theta[i, ], y.pf$wt[i, ]))
theta.sd <- sapply(2 : (length(y) + 1), function(i)
  weighted.mean((y.pf$theta[i, ] - theta.avg[i])^2, y.pf$wt[i, ]))

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

# Plot system variance
systemVar.avg <- sapply(2 : (length(y) + 1), function(i)
  weighted.mean(y.pf$systemVar[i, ], y.pf$wt[i, ]))
systemVar.l <- y.pf$systemVar %>>% apply(1, function(x){quantile(x, 0.25)})
systemVar.u <- y.pf$systemVar %>>% apply(1, function(x){quantile(x, 0.75)})

rep(mod %>>% W, n) %>>% plot(type = "l", ylim = c(0, 10))
systemVar.avg %>>% lines(col = 2, type = "l", lwd = 2)
systemVar.l %>>% lines(col = 2, type = "l", lty = 2)
systemVar.u %>>% lines(col = 2, type = "l", lty = 2)
legend("topright", c("True system variance",
                        "Particle Filter"),
       lty = rep(1, 2), col = c(1, 2), lwd = c(1, 2), bty="n")


# Plot observe variance
obsVar.avg <- sapply(2 : (length(y) + 1), function(i)
  weighted.mean(y.pf$obsVar[i, ], y.pf$wt[i, ]))
obsVar.l <- y.pf$obsVar %>>% apply(1, function(x){quantile(x, 0.25)})
obsVar.u <- y.pf$obsVar %>>% apply(1, function(x){quantile(x, 0.75)})

rep(mod %>>% V, n) %>>% plot(type = "l", ylim = c(0, 10))
obsVar.avg %>>% lines(col = 2, type = "l", lwd = 2)
obsVar.l %>>% lines(col = 2, type = "l", lty = 2)
obsVar.u %>>% lines(col = 2, type = "l", lty = 2)
legend("topright", c("True observe variance",
                     "Particle Filter"),
       lty = rep(1, 2), col = c(1, 2), lwd = c(1, 2), bty="n")

対象データに関しては前回の記事と同様のものを使っております。前回との違いとしては、システムノイズと観測ノイズの分散が同時に推定されているという点ですね。
また、今回は重点遷移密度を得るためにAnxiliary Particle Filter(補助粒子フィルタ)を使っています。これは、未知パラメータを含んでいるからという理由と、他の分布への一般化も視野に入れているからという理由です。

また参考文献中では実装されていませんが、多項リサンプリングも行なっています。

状態の推定結果

粒子数は1万個です。以下のように、若干ずれる箇所はありますが、カルマンフィルタとほぼ同程度の推定を行なっていることが分かります。

システム分散の推定結果

システム分散の真値は1ですが、まあまあという感じですかね。
赤の破線はそれぞれ25%タイル値、75%タイル値を表しています。

観測分散の推定結果

こちらの真値は2ですが、まあこんな感じという感じなんですかね(― ―)

システムノイズがコーシー分布の場合

ほとんど正規分布の場合と変わりません。正規分布のコードをコピーして再利用しているので、変数名などが適切ではないですがそこは目をつむってください(― ―)

library(pipeR)

#------------------------------------------------------------------------------
# Generate sample data
#------------------------------------------------------------------------------
n <- 100
systemScale <- 0.05
obsVar <- 1.5

state <- rcauchy(n, location = 0, scale = systemScale) %>>% cumsum
y <- state + rnorm(n, 0, obsVar %>>% sqrt)

y %>>% plot(type = "l")
state %>>% lines(type = "l", col = 2)
legend("bottomright", c("Observation",
                        "True state"),
       lty = rep(1, 2), col = c(1, 2), lwd = c(1, 1), bty="n")

#------------------------------------------------------------------------------
# Particle Filter (Cauchy distribution)
#------------------------------------------------------------------------------
ParticleFilterCauchy <- function(y, nParticle, nEff, x0, systemVar0, obsVar0, a){
 
  if (length(x0) != nParticle){
    return ("ERROR: The Length of x0 should match the number of particles")
  }
 
  #initial settings
  n <- length(y)
  pfOut <- wt <- matrix(NA_real_, n + 1, nParticle)
  pfOutSystemVar <- pfOutObsVar <- matrix(NA_real_, n + 1, nParticle)
 
  pfOut[1, ] <- x0
  pfOutSystemVar[1, ] <- systemVar0
  pfOutObsVar[1, ] <- obsVar0
  wt[1, ] <- 1 / nParticle
  N.eff <- rep(N, n + 1)
 
  for (it in 2 : (n + 1)){
    it %>>% print
   
    meanObs <- weighted.mean(pfOutObsVar[it - 1, ], wt[it - 1, ])
    meanSystem <- weighted.mean(pfOutSystemVar[it - 1, ], wt[it - 1, ])
    varObs <- weighted.mean((pfOutObsVar[it - 1, ] - meanObs)^2, wt[it - 1, ])
    varSystem <- weighted.mean((pfOutSystemVar[it - 1, ] - meanSystem)^2, wt[it - 1, ])
   
    muObs <- a * pfOutObsVar[it - 1, ] + (1 - a) * meanObs
    sigma2Obs <- (1 - a^2) * varObs
    alphaObs <- muObs^2 / sigma2Obs
    betaObs <- muObs / sigma2Obs
   
    muSystem <- a * pfOutSystemVar[it - 1, ] + (1 - a) * meanSystem
    sigma2System <- (1 - a^2) * varSystem
    alphaSystem <- muSystem^2 / sigma2System
    betaSystem <- muSystem / sigma2System
   
    Ik <- sample(nParticle, size = nParticle, replace = T,
                 prob = wt[it - 1, ] * dnorm(y[it - 1] - pfOut[it - 1, ], 0, sqrt(muObs)))
    pfOutObsVar[it, ] <- rgamma(nParticle, shape = alphaObs[Ik], rate = betaObs[Ik])
    pfOutSystemVar[it, ] <- rgamma(nParticle, shape = alphaSystem[Ik], rate = betaSystem[Ik])
    pfOut[it, ] <- pfOut[it - 1, Ik] + rcauchy(nParticle, 0, sqrt(pfOutSystemVar[it, ]))
   
    wt[it, ] <- dnorm(y[it - 1] - pfOut[it, ], 0, sqrt(pfOutObsVar[it, ])) /
      dnorm(y[it - 1] - pfOut[it - 1, Ik], 0, sqrt(muObs[Ik]))
    wt[it, ] <- wt[it, ] / sum(wt[it, ])
   
    N.eff[it] <- 1 / crossprod(wt[it, ])
    if (N.eff[it] < nEff){
      # multinominal resampling
      tmp <- sample(nParticle, size = nParticle, replace = T, prob = wt[it, ])
      pfOut[it, ] <- pfOut[it, tmp]
      pfOutObsVar[it, ] <- pfOutObsVar[it, tmp]
      pfOutSystemVar[it, ] <- pfOutSystemVar[it, tmp]
     
      wt[it, ] <- 1 / nParticle
    }
   
   
  }
 
  return( list(
    theta = pfOut,
    systemVar = pfOutSystemVar,
    obsVar = pfOutObsVar,
    wt = wt,
    nEff = N.eff
  ))
}


#------------------------------------------------------------------------------
# MAIN
#------------------------------------------------------------------------------
N <- 1000000
x0 <- rnorm(N, 0, y %>>% sd)
systemVar0 <- runif(N, 0, 1)
obsVar0 <- runif(N, 0, 10)
a <- 0.975
y.pf <- ParticleFilterCauchy(y, N, N / 2, x0, systemVar0, obsVar0, a)


# Plot theta
theta.avg <- sapply(2 : (length(y) + 1), function(i)
  weighted.mean(y.pf$theta[i, ], y.pf$wt[i, ]))
theta.sd <- sapply(2 : (length(y) + 1), function(i)
  weighted.mean((y.pf$theta[i, ] - theta.avg[i])^2, y.pf$wt[i, ]))

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

# Plot system scale
systemVar.avg <- sapply(2 : (length(y) + 1), function(i)
  weighted.mean(y.pf$systemVar[i, ], y.pf$wt[i, ]))
systemVar.l <- y.pf$systemVar %>>% apply(1, function(x){quantile(x, 0.25)})
systemVar.u <- y.pf$systemVar %>>% apply(1, function(x){quantile(x, 0.75)})

rep(systemScale, n) %>>% plot(type = "l", ylim = c(0, 1))
systemVar.avg %>>% lines(col = 2, type = "l", lwd = 2)
systemVar.l %>>% lines(col = 2, type = "l", lty = 2)
systemVar.u %>>% lines(col = 2, type = "l", lty = 2)
legend("topright", c("True system scale",
                     "Particle Filter"),
       lty = rep(1, 2), col = c(1, 2), lwd = c(1, 2), bty="n")


# Plot observe variance
obsVar.avg <- sapply(2 : (length(y) + 1), function(i)
  weighted.mean(y.pf$obsVar[i, ], y.pf$wt[i, ]))
obsVar.l <- y.pf$obsVar %>>% apply(1, function(x){quantile(x, 0.25)})
obsVar.u <- y.pf$obsVar %>>% apply(1, function(x){quantile(x, 0.75)})

rep(obsVar, n) %>>% plot(type = "l", ylim = c(0, 10))
obsVar.avg %>>% lines(col = 2, type = "l", lwd = 2)
obsVar.l %>>% lines(col = 2, type = "l", lty = 2)
obsVar.u %>>% lines(col = 2, type = "l", lty = 2)
legend("topright", c("True observe variance",
                     "Particle Filter"),
       lty = rep(1, 2), col = c(1, 2), lwd = c(1, 2), bty="n")

今回推定対象としたデータ列は以下。コーシー分布に従う状態に、正規分布を上乗せしています。
状態がコーシー分布なので、正規分布よりもドラスティックなジャンプが時々発生します。

状態の推定結果

粒子数は100万個。青線は状態の真値で、赤線がパーティクルフィルタで推定された状態です。
概ね推定されているような気がしなくもないですがやはり精度はかなり悪くなりますね。
100万個でこれですからね。MBPで走らせるとかなり時間がかかります(― ―)

システムノイズのscaleの推定結果

真値は0.05ですがこんなもんなんですかね。時々ゼロに張り付いたりしていますが。

観測分散の推定結果

こちらはまあいい感じですかね。真値は1.5です。

参考文献

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