Extended Kalman filter example in R
Kalman filter
I had the following dynamic linear model for the Kalman filter last week:
With
Logistic growth
As an example I will use a logistic growth model, inspired by the Hakell example given by Dominic Steinitz.
The logistic growth model can be written as a time-invariant dynamical system with growth rate
Extended Kalman filter
The state space and observation model can then be written as:
Or with
In my example the state space model is purely deterministic, so there isn’t any evolution noise and hence
jacobian
function of the numDeriv
package.After a few time steps the extended Kalman filter does a fantastic job in reducing the noise. Perhaps this shouldn’t be too surprising as a local linearisation of the logistic growth function will give a good fit. The situation might be different for highly nonlinear functions. The Wikipedia article about the Kalman filter suggests the unscented version in those cases.R code
# Example inspired by | |
# https://idontgetoutmuch.wordpress.com/2014/09/09/fun-with-extended-kalman-filters-4/ | |
# Logistic growth function | |
logistG <- function(r, p, k, t){ | |
k * p * exp(r*t) / (k + p * (exp(r*t) - 1)) | |
} | |
k <- 100 | |
p0 <- 0.1*k | |
r <- 0.2 | |
deltaT <- 0.1 | |
# Let's create some sample data: | |
set.seed(12345) | |
obsVariance <- 25 | |
nObs = 250 | |
nu <- rnorm(nObs, mean=0, sd=sqrt(obsVariance)) | |
pop <- c(p0, logistG(r, p0, k, (1:(nObs-1))*deltaT)) + nu | |
Estimate <- data.frame(Rate=rep(NA, nObs), | |
Population=rep(NA,nObs)) | |
library(numDeriv) | |
a <- function(x, k, deltaT){ | |
c(r=x[1], | |
logistG(r=x[1], p=x[2], k, deltaT)) | |
} | |
G <- t(c(0, 1)) | |
# Evolution error | |
Q <- diag(c(0, 0)) | |
# Observation error | |
R <- obsVariance | |
# Prior | |
x <- c(r, p0) | |
Sigma <- diag(c(144, 25)) | |
for(i in 1:nObs){ | |
# Observation | |
xobs <- c(0, pop[i]) | |
y <- G %*% xobs | |
# Filter | |
SigTermInv <- solve(G %*% Sigma %*% t(G) + R) | |
xf <- x + Sigma %*% t(G) %*% SigTermInv %*% (y - G %*% x) | |
Sigma <- Sigma - Sigma %*% t(G) %*% SigTermInv %*% G %*% Sigma | |
A <- jacobian(a, x=x, k=k, deltaT=deltaT) | |
K <- A %*% Sigma %*% t(G) %*% solve(G %*% Sigma %*% t(G) + R) | |
Estimate[i,] <- x | |
# Predict | |
x <- a(x=xf, k=k, deltaT=deltaT) + K %*% (y - G %*% xf) | |
Sigma <- A %*% Sigma %*% t(A) - K %*% G %*% Sigma %*% t(A) + Q | |
} | |
# Plot output | |
op <- par(mfrow=c(2,1)) | |
time <- c(1:nObs)*deltaT | |
plot(y=pop, x=time, t='l', main="Population growth", | |
xlab="Time", ylab="Population") | |
curve(logistG(r, p0, k, x), from=0, to=max(time), col=2, add=TRUE, lwd=1) | |
lines(y=Estimate$Population, x=time, col="orange", lwd=2) | |
legend("bottomright", | |
legend=c("Data","Actual", "Estimate"), | |
bty="n", | |
col=c("black", "red", "orange"), | |
lty=1, lwd=2) | |
plot(y=Estimate$Rate, x=time, t='l', main="Estimated growth rate", | |
xlab="Time", ylab="Rate", col="orange", lwd=2) | |
abline(h=r, col=adjustcolor("red", alpha=0.5), lwd=2) | |
legend("topright", | |
legend=c("Actual", "Estimate"), | |
bty="n", | |
col=c("red", "orange"), | |
lty=1, lwd=2) | |
par(op) |
Session Info
R version 3.1.2 (2014-10-31)
Platform: x86_64-apple-darwin13.4.0 (64-bit)
locale:
[1] en_GB.UTF-8/en_GB.UTF-8/en_GB.UTF-8/C/en_GB.UTF-8/en_GB.UTF-8
attached base packages:
[1] stats graphics grDevices utils datasets methods base
other attached packages:
[1] numDeriv_2012.9-1
loaded via a namespace (and not attached):
[1] tools_3.1.2
Citation
For attribution, please cite this work as:Markus Gesmann (Jan 13, 2015) Extended Kalman filter example in R. Retrieved from https://magesblog.com/post/2015-01-13-extended-kalman-filter-example-in-r/
@misc{ 2015-extended-kalman-filter-example-in-r,
author = { Markus Gesmann },
title = { Extended Kalman filter example in R },
url = { https://magesblog.com/post/2015-01-13-extended-kalman-filter-example-in-r/ },
year = { 2015 }
updated = { Jan 13, 2015 }
}