Extended Kalman filter example in R

Last week’s post about the Kalman filter focused on the derivation of the algorithm. Today I will continue with the extended Kalman filter (EKF) that can deal also with nonlinearities. According to Wikipedia the EKF has been considered the de facto standard in the theory of nonlinear state estimation, navigation systems and GPS.

Kalman filter

I had the following dynamic linear model for the Kalman filter last week:

xt+1=Axt+wt,wtN(0,Q)yt=Gxt+νt,νtN(0,R)x1N(x^0,Σ0)

With xt describing the state space evolution, yt the observations, A,Q,G,R,Σ0 matrices of appropriate dimensions, wt the evolution error and νt the observation error. The Kalman filter provides recursive estimators for xt via:

Kt=AΣtG(GΣtG+R)1x^t+1=Axt^+Kt(ytGx^t)Σt+1=AΣtAKtGΣtA+Q

In the case of nonlinearities on the right hand side of either the state (xt) or observation (yt) equation the extended Kalman filter uses a simple and elegant trick: Taylor series of the first order, or in other words, I simply linearise the right hand side. The matrices A and G will be the Jacobian matrices of the respected vector functions.

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 r and carrying capacity k: p˙=rp(1pk) The above ordinary differential equation has the well known analytical solution:

p=kp0exp(rt)k+p0(exp(rt)1)

Suppose I observe data of a population for which I know the carrying capacity k, but where the growth rate r is noisy.

Extended Kalman filter

The state space and observation model can then be written as: ri=ri1pi=kpi1exp(ri1ΔT)k+pi1(exp(ri1ΔT)1)yi=[01][ripi]+ν

Or with xi:=[ripi] as:

xi=a(xi)yi=Gxi+νiνiN(0,R)

In my example the state space model is purely deterministic, so there isn’t any evolution noise and hence Q=0.

With an initial prior guess for x0 and Σ0 and I am ready to go. The R code below shows my implementation with the algorithm above. Note that I use the 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/

BibTeX citation:

@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 }
}

Related