The Haskell:
{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE ForeignFunctionInterface #-}
module Foo where
foreign export ccall foo :: Int -> IO Int
foo :: Int -> IO Int
foo n = return (length (f n))
f :: Int -> [Int]
f 0 = []
f n = n:(f (n-1))
The .cabal:
name: test-via-c
version: 0.1.0.0
homepage: TBD
license: MIT
author: Dominic Steinitz
maintainer: idontgetoutmuch@gmail.com
category: System
build-type: Simple
cabal-version: >=1.10
executable Foo.dylib
main-is: Foo.hs
other-extensions: ForeignFunctionInterface
build-depends: base >=4.7 && =0.6 && <0.7
hs-source-dirs: src
default-language: Haskell2010
include-dirs: src
ghc-options: -O2 -shared -fPIC -dynamic
extra-libraries: HSrts-ghc8.0.1
On my computer running
cabal install
places the library in
~/Library/Haskell/ghc-8.0.1/lib/test-via-c-0.1.0.0/bin
The C:
#include
#include "HsFFI.h"
#include "../dist/build/Foo.dylib/Foo.dylib-tmp/Foo_stub.h"
int main(int argc, char *argv[])
{
int i;
hs_init(&argc, &argv);
for (i = 0; i < 5; i++) {
printf("%d\n", foo(2500));
}
hs_exit();
return 0;
}
On my computer this can be compiled with
gcc-6 Bar.c
~/Library/Haskell/ghc-8.0.1/lib/test-via-c-0.1.0.0/bin/Foo.dylib
-I/Library/Frameworks/GHC.framework/Versions/8.0.1-x86_64/usr/lib/ghc-8.0.1/include
-L/Library/Frameworks/GHC.framework/Versions/8.0.1-x86_64/usr/lib/ghc-8.0.1/rts
-lHSrts-ghc8.0.1
and can be run with
DYLD_LIBRARY_PATH=
~/Library/Haskell/ghc-8.0.1/lib/test-via-c-0.1.0.0/bin:
/Library/Frameworks/GHC.framework/Versions/8.0.1-x86_64/usr/lib/ghc-8.0.1/rts
N.B. setting DYLD_LIBRARY_PATH
like this is not recommended as it is a good way of breaking things. I have tried setting DYLD_FALLBACK_LIBRARY_PATH
but only to get an error message. Hopefully, at some point I will be able to post a robust way of getting the executable to pick up the required dynamic libraries.
I was intrigued by a tweet by the UK Chancellor of the Exchequer stating "exports [to South Korea] have doubled over the last year. Now worth nearly £11bn” and a tweet by a Member of the UK Parliament stating South Korea "our second fastest growing trading partner". Although I have never paid much attention to trade statistics, both these statements seemed surprising. But these days it’s easy enough to verify such statements. It’s also an opportunity to use the techniques I believe data scientists in (computer) game companies use to determine how much impact a new feature has on the game’s consumers.
One has to be slightly careful with trade statistics as they come in many different forms, e.g., just goods or goods and services etc. When I provide software and analyses to US organisations, I am included in the services exports from the UK to the US.
Let’s analyse goods first before moving on to goods and services.
First let’s get hold of the quarterly data from the UK Office of National Statistics.
ukstats <- "https://www.ons.gov.uk"
bop <- "economy/nationalaccounts/balanceofpayments"
ds <- "datasets/tradeingoodsmretsallbopeu2013timeseriesspreadsheet/current/mret.csv"
mycsv <- read.csv(paste(ukstats,"file?uri=",bop,ds,sep="/"),stringsAsFactors=FALSE)
Now we can find the columns that refer to Korea.
ns <- which(grepl("Korea", names(mycsv)))
length(ns)
## [1] 3
names(mycsv[ns[1]])
## [1] "BoP.consistent..South.Korea..Exports..SA................................"
names(mycsv[ns[2]])
## [1] "BoP.consistent..South.Korea..Imports..SA................................"
names(mycsv[ns[3]])
## [1] "BoP.consistent..South.Korea..Balance..SA................................"
Now we can pull out the relevant information and create a data frame of it.
korean <- mycsv[grepl("Korea", names(mycsv))]
imports <- korean[grepl("Imports", names(korean))]
exports <- korean[grepl("Exports", names(korean))]
balance <- korean[grepl("Balance", names(korean))]
df <- data.frame(mycsv[grepl("Title", names(mycsv))],
imports,
exports,
balance)
colnames(df) <- c("Title", "Imports", "Exports", "Balance")
startQ <- which(grepl("1998 Q1",df$Title))
endQ <- which(grepl("2016 Q3",df$Title))
dfQ <- df[startQ:endQ,]
We can now plot the data.
tab <- data.frame(kr=as.numeric(dfQ$Exports),
krLabs=as.numeric(as.Date(as.yearqtr(dfQ$Title,format='%Y Q%q'))))
ggplot(tab, aes(x=as.Date(tab$krLabs), y=tab$kr)) + geom_line() +
theme(legend.position="bottom") +
ggtitle("Goods Exports UK / South Korea (Quarterly)") +
theme(plot.title = element_text(hjust = 0.5)) +
xlab("Date") +
ylab("Value (£m)")
For good measure let’s plot the annual data.
startY <- grep("^1998$",df$Title)
endY <- grep("^2015$",df$Title)
dfYear <- df[startY:endY,]
tabY <- data.frame(kr=as.numeric(dfYear$Exports),
krLabs=as.numeric(dfYear$Title))
ggplot(tabY, aes(x=tabY$krLabs, y=tabY$kr)) + geom_line() +
theme(legend.position="bottom") +
ggtitle("Goods Exports UK / South Korea (Annual)") +
theme(plot.title = element_text(hjust = 0.5)) +
xlab("Date") +
ylab("Value (£m)")
And the monthly data.
startM <- grep("1998 JAN",df$Title)
endM <- grep("2016 OCT",df$Title)
dfMonth <- df[startM:endM,]
tabM <- data.frame(kr=as.numeric(dfMonth$Exports),
krLabs=as.numeric(as.Date(as.yearmon(dfMonth$Title,format='%Y %B'))))
ggplot(tabM, aes(x=as.Date(tabM$krLabs), y=tabM$kr)) + geom_line() +
theme(legend.position="bottom") +
ggtitle("Goods Exports UK / South Korea (Monthly)") +
theme(plot.title = element_text(hjust = 0.5)) +
xlab("Date") +
ylab("Value (£m)")
It looks like some change took place in 2011 but nothing to suggest either that "export have doubled over the last year" or that South Korea is "our second fastest growing partner". That some sort of change did happen is further supported by the fact a Free Trade Agreement between the EU and Korea was put in place in 2011.
But was there really a change? And what sort of change was it? Sometimes it’s easy to imagine patterns where there are none.
With this warning in mind let us see if we can get a better feel from the numbers as to what happened.
Let us assume that the data for exports are approximated by a linear function of time but that there is a change in the slope and the offset at some point during observation.
Since we are going to use stan to infer the parameters for this model and stan cannot handle discrete parameters, we need to marginalize out this (discrete) parameter. I hope to do the same analysis with LibBi which seems more suited to time series analysis and which I believe will not require such a step.
Setting D = {y_{i}}_{i = 1}^{N} we can calculate the likelihood
stan operates on the log scale and thus requires the log likelihood
where
and where the log sum of exponents function is defined by
The log sum of exponents function allows the model to be coded directly in Stan using the built-in function , which provides both arithmetic stability and efficiency for mixture model calculations.
Here’s the model in stan. Sadly I haven’t found a good way of divvying up .stan
files in a .Rmd
file so that it still compiles.
data {
int<lower=1> N;
real x[N];
real y[N];
}
parameters {
real mu1;
real mu2;
real gamma1;
real gamma2;
real<lower=0> sigma1;
real<lower=0> sigma2;
}
transformed parameters {
vector[N] log_p;
real mu;
real sigma;
log_p = rep_vector(-log(N), N);
for (tau in 1:N)
for (i in 1:N) {
mu = i < tau ? (mu1 * x[i] + gamma1) : (mu2 * x[i] + gamma2);
sigma = i < tau ? sigma1 : sigma2;
log_p[tau] = log_p[tau] + normal_lpdf(y[i] | mu, sigma);
}
}
model {
mu1 ~ normal(0, 10);
mu2 ~ normal(0, 10);
gamma1 ~ normal(0, 10);
gamma2 ~ normal(0, 10);
sigma1 ~ normal(0, 10);
sigma2 ~ normal(0, 10);
target += log_sum_exp(log_p);
}
generated quantities {
int<lower=1,upper=N> tau;
tau = categorical_rng(softmax(log_p));
}
The above, although mimicking our mathematical model, has quadratic complexity and we can use the trick in the stan manual to make it linear albeit with less clarity.
data {
int<lower=1> N;
real x[N];
real y[N];
}
parameters {
real mu1;
real mu2;
real gamma1;
real gamma2;
real<lower=0> sigma1;
real<lower=0> sigma2;
}
transformed parameters {
vector[N] log_p;
{
vector[N+1] log_p_e;
vector[N+1] log_p_l;
log_p_e[1] = 0;
log_p_l[1] = 0;
for (i in 1:N) {
log_p_e[i + 1] = log_p_e[i] + normal_lpdf(y[i] | mu1 * x[i] + gamma1, sigma1);
log_p_l[i + 1] = log_p_l[i] + normal_lpdf(y[i] | mu2 * x[i] + gamma2, sigma2);
}
log_p = rep_vector(-log(N) + log_p_l[N + 1], N) + head(log_p_e, N) - head(log_p_l, N);
}
}
model {
mu1 ~ normal(0, 10);
mu2 ~ normal(0, 10);
gamma1 ~ normal(0, 10);
gamma2 ~ normal(0, 10);
sigma1 ~ normal(0, 10);
sigma2 ~ normal(0, 10);
target += log_sum_exp(log_p);
}
generated quantities {
int<lower=1,upper=N> tau;
tau = categorical_rng(softmax(log_p));
}
Let’s run this model with the monthly data.
NM <- nrow(tabM)
KM <- ncol(tabM)
yM <- tabM$kr
XM <- data.frame(tabM,rep(1,NM))[,2:3]
fitM <- stan(
file = "lr-changepoint-ng.stan",
data = list(x = XM$krLabs, y = yM, N = length(yM)),
chains = 4,
warmup = 1000,
iter = 10000,
cores = 4,
refresh = 500,
seed=42
)
## Warning: There were 662 divergent transitions after warmup. Increasing adapt_delta above 0.8 may help. See
## http://mc-stan.org/misc/warnings.html#divergent-transitions-after-warmup
## Warning: Examine the pairs() plot to diagnose sampling problems
Looking at the results below we see a multi-modal distribution so a mean is not of much use.
histData <- hist(extract(fitM)$tau,plot=FALSE,breaks=c(seq(1,length(yM),1)))
histData$counts
## [1] 18000 0 0 0 0 0 0 0 0 0 0
## [12] 0 0 0 0 0 0 0 0 0 0 0
## [23] 0 0 0 0 0 0 0 0 0 0 0
## [34] 0 0 0 0 0 0 0 0 0 0 0
## [45] 0 0 0 0 0 0 0 0 0 0 0
## [56] 0 0 0 0 0 0 0 0 0 0 0
## [67] 0 0 0 0 0 0 0 0 0 0 0
## [78] 0 0 0 0 0 0 0 0 0 0 0
## [89] 0 0 0 0 0 0 0 0 0 0 0
## [100] 0 0 0 0 0 0 0 0 0 0 0
## [111] 0 0 0 0 0 0 0 1 4 12 16
## [122] 16 107 712 8132 0 0 0 0 0 0 0
## [133] 0 0 0 0 0 0 0 0 0 0 0
## [144] 0 0 0 0 0 0 0 0 0 0 0
## [155] 0 0 0 0 0 0 0 0 0 0 25
## [166] 171 2812 0 0 0 0 0 0 0 0 0
## [177] 0 0 0 0 0 0 0 0 0 0 0
## [188] 0 0 0 0 0 0 0 0 0 0 0
## [199] 0 0 0 0 0 0 0 0 0 0 0
## [210] 0 0 0 0 0 0 0 0 0 0 0
## [221] 0 0 0 0 5992
We can get a pictorial representation of the maxima so that the multi-modality is even clearer.
min_indexes = which(diff( sign(diff( c(0,histData$counts,0)))) == 2)
max_indexes = which(diff( sign(diff( c(0,histData$counts,0)))) == -2)
modeData = data.frame(x=1:length(histData$counts),y=histData$counts)
min_locs = modeData[min_indexes,]
max_locs = modeData[max_indexes,]
plot(modeData$y, type="l")
points( min_locs, col="red", pch=19, cex=1 )
points( max_locs, col="green", pch=19, cex=1 )
My interpretation is that the evidence (data) says there is probably no changepoint (a change at the beginning or end is no change) but there might be a change at intermediate data points.
We can see something strange (maybe a large single export?) happened at index 125 which translates to 2008MAY.
The mode at index 167 which translates to 2011NOV corresponds roughly to the EU / Korea trade agreement.
Let us assume that there really was a material difference in trade at this latter point. We can fit a linear regression before this point and one after this point.
Here’s the stan
data {
int<lower=1> N;
int<lower=1> K;
matrix[N,K] X;
vector[N] y;
}
parameters {
vector[K] beta;
real<lower=0> sigma;
}
model {
y ~ normal(X * beta, sigma);
}
And here’s the R to fit the before and after data. We fit the model, pull out the parameters for the regression and pull out the covariates
N <- length(yM)
M <- max_locs$x[3]
fite <- stan(file = 'LR.stan',
data = list(N = M, K = ncol(XM), y = yM[1:M], X = XM[1:M,]),
pars=c("beta", "sigma"),
chains=3,
cores=3,
iter=3000,
warmup=1000,
refresh=-1)
se <- extract(fite, pars = c("beta", "sigma"), permuted=TRUE)
estCovParamsE <- colMeans(se$beta)
fitl <- stan(file = 'LR.stan',
data = list(N = N-M, K = ncol(XM), y = yM[(M+1):N], X = XM[(M+1):N,]),
pars=c("beta", "sigma"),
chains=3,
cores=3,
iter=3000,
warmup=1000,
refresh=-1)
sl <- extract(fitl, pars = c("beta", "sigma"), permuted=TRUE)
estCovParamsL <- colMeans(sl$beta)
Make predictions
linRegPredsE <- data.matrix(XM) %*% estCovParamsE
linRegPredsL <- data.matrix(XM) %*% estCovParamsL
ggplot(tabM, aes(x=as.Date(tabM$krLabs), y=tabM$kr)) +
geom_line(aes(x = as.Date(tabM$krLabs), y = tabM$kr, col = "Actual")) +
geom_line(data=tabM[1:M,], aes(x = as.Date(tabM$krLabs[1:M]), y = linRegPredsE[(1:M),1], col = "Fit (Before FTA)")) +
geom_line(data=tabM[(M+1):N,], aes(x = as.Date(tabM$krLabs[(M+1):N]), y = linRegPredsL[((M+1):N),1], col = "Fit (After FTA)")) +
theme(legend.position="bottom") +
ggtitle("Goods Exports UK / South Korea (Monthly)") +
theme(plot.title = element_text(hjust = 0.5)) +
xlab("Date") +
ylab("Value (£m)")
So we didn’t manage to substantiate either the Chancellor’s claim or the Member of Parliament’s claim.
But it may be that we can if we look at Goods and Services then we might be able to see the numbers resulting in the claims.
pb <- "datasets/pinkbook/current/pb.csv"
pbcsv <- read.csv(paste(ukstats,"file?uri=",bop,pb,sep="/"),stringsAsFactors=FALSE)
This has a lot more information albeit only annually.
pbns <- grep("Korea", names(pbcsv))
length(pbns)
## [1] 21
lapply(pbns,function(x) names(pbcsv[x]))
## [[1]]
## [1] "BoP..Current.Account..Goods...Services..Imports..South.Korea............"
##
## [[2]]
## [1] "BoP..Current.Account..Current.Transfer..Balance..South.Korea............"
##
## [[3]]
## [1] "BoP..Current.Account..Goods...Services..Balance..South.Korea............"
##
## [[4]]
## [1] "IIP..Assets..Total.South.Korea.........................................."
##
## [[5]]
## [1] "Trade.in.Services.replaces.1.A.B....Exports.Credits...South.Korea...nsa."
##
## [[6]]
## [1] "IIP...Liabilities...Total...South.Korea................................."
##
## [[7]]
## [1] "BoP..Total.income..Balance..South.Korea................................."
##
## [[8]]
## [1] "BoP..Total.income..Debits..South.Korea.................................."
##
## [[9]]
## [1] "BoP..Total.income..Credits..South.Korea................................."
##
## [[10]]
## [1] "BoP..Current.account..Balance..South.Korea.............................."
##
## [[11]]
## [1] "BoP..Current.account..Debits..South.Korea..............................."
##
## [[12]]
## [1] "BoP..Current.account..Credits..South.Korea.............................."
##
## [[13]]
## [1] "IIP...Net...Total....South.Korea........................................"
##
## [[14]]
## [1] "Trade.in.Services.replaces.1.A.B....Imports.Debits...South.Korea...nsa.."
##
## [[15]]
## [1] "BoP..Current.Account..Services..Total.Balance..South.Korea.............."
##
## [[16]]
## [1] "Bop.consistent..Balance..NSA..South.Korea..............................."
##
## [[17]]
## [1] "Bop.consistent..Im..NSA..South.Korea...................................."
##
## [[18]]
## [1] "Bop.consistent..Ex..NSA..South.Korea...................................."
##
## [[19]]
## [1] "Current.Transfers...Exports.Credits...South.Korea...nsa................."
##
## [[20]]
## [1] "Current.Transfers...Imports.Debits...South.Korea...nsa.................."
##
## [[21]]
## [1] "BoP..Current.Account..Goods...Services..Exports..South.Korea............"
Let’s just look at exports.
koreanpb <- pbcsv[grepl("Korea", names(pbcsv))]
exportspb <- koreanpb[grepl("Exports", names(koreanpb))]
names(exportspb)
## [1] "Trade.in.Services.replaces.1.A.B....Exports.Credits...South.Korea...nsa."
## [2] "Current.Transfers...Exports.Credits...South.Korea...nsa................."
## [3] "BoP..Current.Account..Goods...Services..Exports..South.Korea............"
The last column gives exports of Goods and Services so let’s draw a chart of it.
pb <- data.frame(pbcsv[grepl("Title", names(pbcsv))],
exportspb[3])
colnames(pb) <- c("Title", "Exports")
startpbY <- which(grepl("1999",pb$Title))
endpbY <- which(grepl("2015",pb$Title))
pbY <- pb[startpbY:endpbY,]
tabpbY <- data.frame(kr=as.numeric(pbY$Exports),
krLabs=as.numeric(pbY$Title))
ggplot(tabpbY, aes(x=tabpbY$krLabs, y=tabpbY$kr)) + geom_line() +
theme(legend.position="bottom") +
ggtitle("Goods and Services Exports UK / South Korea (Annual)") +
theme(plot.title = element_text(hjust = 0.5)) +
xlab("Date") +
ylab("Value (£m)")
No joy here either to any of the claims. Still it’s been an interesting exercise.
In most presentations of Riemannian geometry, e.g. O’Neill (1983) and Wikipedia, the fundamental theorem of Riemannian geometry (“the miracle of Riemannian geometry”) is given: that for any semi-Riemannian manifold there is a unique torsion-free metric connection. I assume partly because of this and partly because the major application of Riemannian geometry is General Relativity, connections with torsion are given little if any attention.
It turns out we are all very familiar with a connection with torsion: the Mercator projection. Some mathematical physics texts, e.g. Nakahara (2003), allude to this but leave the details to the reader. Moreover, this connection respects the metric induced from Euclidean space.
We use SageManifolds to assist with the calculations. We hint at how this might be done more slickly in Haskell.
%matplotlib inline
/Applications/SageMath/local/lib/python2.7/site-packages/traitlets/traitlets.py:770: DeprecationWarning: A parent of InlineBackend._config_changed has adopted the new @observe(change) API
clsname, change_or_name), DeprecationWarning)
import matplotlib
import numpy as np
import matplotlib.pyplot as plt
import cartopy
import cartopy.crs as ccrs
from cartopy.mpl.ticker import LongitudeFormatter, LatitudeFormatter
plt.figure(figsize=(8, 8))
ax = plt.axes(projection=cartopy.crs.Mercator())
ax.gridlines()
ax.add_feature(cartopy.feature.LAND)
ax.add_feature(cartopy.feature.COASTLINE)
plt.show()
We can see Greenland looks much broader at the North than in the middle. But if we use a polar projection (below) then we see this is not the case. Why then is the Mercator projection used in preference to e.g. the polar projection or the once controversial Gall-Peters – see here for more on map projections.
plt.figure(figsize=(8, 8))
bx = plt.axes(projection=cartopy.crs.NorthPolarStereo())
bx.set_extent([-180, 180, 90, 50], ccrs.PlateCarree())
bx.gridlines()
bx.add_feature(cartopy.feature.LAND)
bx.add_feature(cartopy.feature.COASTLINE)
plt.show()
This is written as an Jupyter notebook. In theory, it should be possible to run it assuming you have installed at least sage and Haskell. To publish it, I used
jupyter-nbconvert --to markdown Mercator.ipynb
pandoc -s Mercator.md -t markdown+lhs -o Mercator.lhs \
--filter pandoc-citeproc --bibliography DiffGeom.bib
BlogLiteratelyD --wplatex Mercator.lhs > Mercator.html
Not brilliant but good enough.
Some commands to jupyter
to display things nicely.
%display latex
viewer3D = 'tachyon'
Let us try a simple exercise: finding the connection coefficients of the Levi-Civita connection for the Euclidean metric on in polar co-ordinates.
Define the manifold.
N = Manifold(2, 'N',r'\mathcal{N}', start_index=1)
Define a chart and frame with Cartesian co-ordinates.
ChartCartesianN.<x,y> = N.chart()
FrameCartesianN = ChartCartesianN.frame()
Define a chart and frame with polar co-ordinates.
ChartPolarN.<r,theta> = N.chart()
FramePolarN = ChartPolarN.frame()
The standard transformation from Cartesian to polar co-ordinates.
cartesianToPolar = ChartCartesianN.transition_map(ChartPolarN, (sqrt(x^2 + y^2), arctan(y/x)))
print(cartesianToPolar)
Change of coordinates from Chart (N, (x, y)) to Chart (N, (r, theta))
print(latex(cartesianToPolar.display()))
cartesianToPolar.set_inverse(r * cos(theta), r * sin(theta))
Check of the inverse coordinate transformation:
x == x
y == y
r == abs(r)
theta == arctan(sin(theta)/cos(theta))
Now we define the metric to make the manifold Euclidean.
g_e = N.metric('g_e')
g_e[1,1], g_e[2,2] = 1, 1
We can display this in Cartesian co-ordinates.
print(latex(g_e.display(FrameCartesianN)))
And we can display it in polar co-ordinates
print(latex(g_e.display(FramePolarN)))
Next let us compute the Levi-Civita connection from this metric.
nab_e = g_e.connection()
print(latex(nab_e))
If we use Cartesian co-ordinates, we expect that . Only non-zero entries get printed.
print(latex(nab_e.display(FrameCartesianN)))
Just to be sure, we can print out all the entries.
print(latex(nab_e[:]))
In polar co-ordinates, we get
print(latex(nab_e.display(FramePolarN)))
Which we can rew-rewrite as
with all other entries being 0.
We define a 2 dimensional manifold. We call it the 2-dimensional (unit) sphere but it we are going to remove a meridian to allow us to define the desired connection with torsion on it.
S2 = Manifold(2, 'S^2', latex_name=r'\mathbb{S}^2', start_index=1)
print(latex(S2))
To start off with we cover the manifold with two charts.
polar.<th,ph> = S2.chart(r'th:(0,pi):\theta ph:(0,2*pi):\phi'); print(latex(polar))
mercator.<xi,ze> = S2.chart(r'xi:(-oo,oo):\xi ze:(0,2*pi):\zeta'); print(latex(mercator))
We can now check that we have two charts.
print(latex(S2.atlas()))
We can then define co-ordinate frames.
epolar = polar.frame(); print(latex(epolar))
emercator = mercator.frame(); print(latex(emercator))
And define a transition map and its inverse from one frame to the other checking that they really are inverses.
xy_to_uv = polar.transition_map(mercator, (log(tan(th/2)), ph))
xy_to_uv.set_inverse(2*arctan(exp(xi)), ze)
Check of the inverse coordinate transformation:
th == 2*arctan(sin(1/2*th)/cos(1/2*th))
ph == ph
xi == xi
ze == ze
We can define the metric which is the pullback of the Euclidean metric on .
g = S2.metric('g')
g[1,1], g[2,2] = 1, (sin(th))^2
And then calculate the Levi-Civita connection defined by it.
nab_g = g.connection()
print(latex(nab_g.display()))
We know the geodesics defined by this connection are the great circles.
We can check that this connection respects the metric.
print(latex(nab_g(g).display()))
And that it has no torsion.
print(latex(nab_g.torsion().display()))
0
Let us now define an orthonormal frame.
ch_basis = S2.automorphism_field()
ch_basis[1,1], ch_basis[2,2] = 1, 1/sin(th)
e = S2.default_frame().new_frame(ch_basis, 'e')
print(latex(e))
We can calculate the dual 1-forms.
dX = S2.coframes()[2] ; print(latex(dX))
print(latex((dX[1], dX[2])))
print(latex((dX[1][:], dX[2][:])))
In this case it is trivial to check that the frame and coframe really are orthonormal but we let sage
do it anyway.
print(latex(((dX[1](e[1]).expr(), dX[1](e[2]).expr()), (dX[2](e[1]).expr(), dX[2](e[2]).expr()))))
Let us define two vectors to be parallel if their angles to a given meridian are the same. For this to be true we must have a connection with .
nab = S2.affine_connection('nabla', latex_name=r'\nabla')
nab.add_coef(e)
Displaying the connection only gives the non-zero components.
print(latex(nab.display(e)))
For safety, let us check all the components explicitly.
print(latex(nab[e,:]))
Of course the components are not non-zero in other frames.
print(latex(nab.display(epolar)))
print(latex(nab.display(emercator)))
This connection also respects the metric .
print(latex(nab(g).display()))
Thus, since the Levi-Civita connection is unique, it must have torsion.
print(latex(nab.torsion().display(e)))
The equations for geodesics are
Explicitly for both variables in the polar co-ordinates chart.
We can check that and are solutions although sage
needs a bit of prompting to help it.
t = var('t'); a = var('a')
print(latex(diff(a * log(tan(t/2)),t).simplify_full()))
We can simplify this further by recalling the trignometric identity.
print(latex(sin(2 * t).trig_expand()))
print(latex(diff (a / sin(t), t)))
In the mercator co-ordinates chart this is
In other words: straight lines.
Reparametersing with we obtain
Let us draw such a curve.
R.<t> = RealLine() ; print(R)
Real number line R
print(dim(R))
1
c = S2.curve({polar: [2*atan(exp(-t/10)), t]}, (t, -oo, +oo), name='c')
print(latex(c.display()))
c.parent()
c.plot(chart=polar, aspect_ratio=0.1)
It’s not totally clear this is curved so let’s try with another example.
d = S2.curve({polar: [2*atan(exp(-t)), t]}, (t, -oo, +oo), name='d')
print(latex(d.display()))
d.plot(chart=polar, aspect_ratio=0.2)
Now it’s clear that a straight line is curved in polar co-ordinates.
But of course in Mercator co-ordinates, it is a straight line. This explains its popularity with mariners: if you draw a straight line on your chart and follow that bearing or rhumb line using a compass you will arrive at the end of the straight line. Of course, it is not the shortest path; great circles are but is much easier to navigate.
c.plot(chart=mercator, aspect_ratio=0.1)
d.plot(chart=mercator, aspect_ratio=1.0)
We can draw these curves on the sphere itself not just on its charts.
R3 = Manifold(3, 'R^3', r'\mathbb{R}^3', start_index=1)
cart.<X,Y,Z> = R3.chart(); print(latex(cart))
Phi = S2.diff_map(R3, {
(polar, cart): [sin(th) * cos(ph), sin(th) * sin(ph), cos(th)],
(mercator, cart): [cos(ze) / cosh(xi), sin(ze) / cosh(xi),
sinh(xi) / cosh(xi)]
},
name='Phi', latex_name=r'\Phi')
We can either plot using polar co-ordinates.
graph_polar = polar.plot(chart=cart, mapping=Phi, nb_values=25, color='blue')
show(graph_polar, viewer=viewer3D)
Or using Mercator co-ordinates. In either case we get the sphere (minus the prime meridian).
graph_mercator = mercator.plot(chart=cart, mapping=Phi, nb_values=25, color='red')
show(graph_mercator, viewer=viewer3D)
We can plot the curve with an angle to the meridian of
graph_c = c.plot(mapping=Phi, max_range=40, plot_points=200, thickness=2)
show(graph_polar + graph_c, viewer=viewer3D)
And we can plot the curve at angle of to the meridian.
graph_d = d.plot(mapping=Phi, max_range=40, plot_points=200, thickness=2, color="green")
show(graph_polar + graph_c + graph_d, viewer=viewer3D)
With automatic differentiation and symbolic numbers, symbolic differentiation is straigtforward in Haskell.
> import Data.Number.Symbolic
> import Numeric.AD
>
> x = var "x"
> y = var "y"
>
> test xs = jacobian ((\x -> [x]) . f) xs
> where
> f [x, y] = sqrt $ x^2 + y^2
ghci> test [1, 1]
[[0.7071067811865475,0.7071067811865475]]
ghci> test [x, y]
[[x/(2.0*sqrt (x*x+y*y))+x/(2.0*sqrt (x*x+y*y)),y/(2.0*sqrt (x*x+y*y))+y/(2.0*sqrt (x*x+y*y))]]
Anyone wishing to take on the task of producing a Haskell version of sagemanifolds is advised to look here before embarking on the task.
Agricola and Thier (2004) shows that the geodesics of the Levi-Civita connection of a conformally equivalent metric are the geodesics of a connection with vectorial torsion. Let’s put some but not all the flesh on the bones.
The Koszul formula (see e.g. (O’Neill 1983)) characterizes the Levi-Civita connection
Being more explicit about the metric, this can be re-written as
Let be the Levi-Civita connection for the metric where . Following [Gadea2010] and substituting into the Koszul formula and then applying the product rule
Where as usual the vector field, for , is defined via .
Let’s try an example.
nab_tilde = S2.affine_connection('nabla_t', r'\tilde_{\nabla}')
f = S2.scalar_field(-ln(sin(th)), name='f')
for i in S2.irange():
for j in S2.irange():
for k in S2.irange():
nab_tilde.add_coef()[k,i,j] = \
nab_g(polar.frame()[i])(polar.frame()[j])(polar.coframe()[k]) + \
polar.frame()[i](f) * polar.frame()[j](polar.coframe()[k]) + \
polar.frame()[j](f) * polar.frame()[i](polar.coframe()[k]) + \
g(polar.frame()[i], polar.frame()[j]) * \
polar.frame()[1](polar.coframe()[k]) * cos(th) / sin(th)
print(latex(nab_tilde.display()))
print(latex(nab_tilde.torsion().display()))
0
g_tilde = exp(2 * f) * g
print(latex(g_tilde.parent()))
print(latex(g_tilde[:]))
nab_g_tilde = g_tilde.connection()
print(latex(nab_g_tilde.display()))
It’s not clear (to me at any rate) what the solutions are to the geodesic equations despite the guarantees of Agricola and Thier (2004). But let’s try a different chart.
print(latex(nab_g_tilde[emercator,:]))
In this chart, the geodesics are clearly straight lines as we would hope.
Agricola, Ilka, and Christian Thier. 2004. “The geodesics of metric connections with vectorial torsion.” Annals of Global Analysis and Geometry 26 (4): 321–32. doi:10.1023/B:AGAG.0000047509.63818.4f.
Nakahara, M. 2003. “Geometry, Topology and Physics.” Text 822: 173–204. doi:10.1007/978-3-642-14700-5.
O’Neill, B. 1983. Semi-Riemannian Geometry with Applications to Relativity, 103. Pure and Applied Mathematics. Elsevier Science. https://books.google.com.au/books?id=CGk1eRSjFIIC.
Recall from the previous post that the Hare growth parameter undergoes Brownian motion so that the further into the future we go, the less certain we are about it. In order to ensure that this parameter remains positive, let’s model the log of it to be Brownian motion.
where the final equation is a stochastic differential equation with being a Wiener process.
By Itô we have
Again, we see that the populations become noisier the further into the future we go.
Now let us infer the growth rate using Hamiltonian Monte Carlo and the domain specific probabilistic language Stan (Stan Development Team (2015b), Stan Development Team (2015a), Hoffman and Gelman (2014), Carpenter (2015)). Here’s the model expressed in Stan.
functions {
real f1 (real a, real k1, real b, real p, real z) {
real q;
q = a * p * (1 - p / k1) - b * p * z;
return q;
}
real f2 (real d, real k2, real c, real p, real z) {
real q;
q = -d * z * (1 + z / k2) + c * p * z;
return q;
}
}
data {
int<lower=1> T; // Number of observations
real y[T]; // Observed hares
real k1; // Hare carrying capacity
real b; // Hare death rate per lynx
real d; // Lynx death rate
real k2; // Lynx carrying capacity
real c; // Lynx birth rate per hare
real deltaT; // Time step
}
parameters {
real<lower=0> mu;
real<lower=0> sigma;
real<lower=0> p0;
real<lower=0> z0;
real<lower=0> rho0;
real w[T];
}
transformed parameters {
real<lower=0> p[T];
real<lower=0> z[T];
real<lower=0> rho[T];
p[1] = p0;
z[1] = z0;
rho[1] = rho0;
for (t in 1:(T-1)){
p[t+1] = p[t] + deltaT * f1 (exp(rho[t]), k1, b, p[t], z[t]);
z[t+1] = z[t] + deltaT * f2 (d, k2, c, p[t], z[t]);
rho[t+1] = rho[t] * exp(sigma * sqrt(deltaT) * w[t] - 0.5 * sigma * sigma * deltaT);
}
}
model {
mu ~ uniform(0.0,1.0);
sigma ~ uniform(0.0, 0.5);
p0 ~ lognormal(log(100.0), 0.2);
z0 ~ lognormal(log(50.0), 0.1);
rho0 ~ normal(log(mu), sigma);
w ~ normal(0.0,1.0);
for (t in 1:T) {
y[t] ~ lognormal(log(p[t]),0.1);
}
}
Let’s look at the posteriors of the hyper-parameters for the Hare growth parameter.
Again, the estimate for is pretty decent. For our generated data, and given our observations are quite noisy maybe the estimate for this is not too bad also.
All code including the R below can be downloaded from github.
install.packages("devtools")
library(devtools)
install_github("libbi/RBi",ref="master")
install_github("sbfnk/RBi.helpers",ref="master")
rm(list = ls(all.names=TRUE))
unlink(".RData")
library('RBi')
try(detach(package:RBi, unload = TRUE), silent = TRUE)
library(RBi, quietly = TRUE)
library('RBi.helpers')
library('ggplot2', quietly = TRUE)
library('gridExtra', quietly = TRUE)
endTime <- 50
PP <- bi_model("PP.bi")
synthetic_dataset_PP <- bi_generate_dataset(endtime=endTime,
model=PP,
seed="42",
verbose=TRUE,
add_options = list(
noutputs=500))
rdata_PP <- bi_read(synthetic_dataset_PP)
df <- data.frame(rdata_PP$P$nr,
rdata_PP$P$value,
rdata_PP$Z$value,
rdata_PP$P_obs$value)
ggplot(df, aes(rdata_PP$P$nr, y = Population, color = variable), size = 0.1) +
geom_line(aes(y = rdata_PP$P$value, col = "Hare"), size = 0.1) +
geom_line(aes(y = rdata_PP$Z$value, col = "Lynx"), size = 0.1) +
geom_point(aes(y = rdata_PP$P_obs$value, col = "Observations"), size = 0.1) +
theme(legend.position="none") +
ggtitle("Example Data") +
xlab("Days") +
theme(axis.text=element_text(size=4),
axis.title=element_text(size=6,face="bold")) +
theme(plot.title = element_text(size=10))
ggsave(filename="diagrams/LVdata.png",width=4,height=3)
library(rstan)
rstan_options(auto_write = TRUE)
options(mc.cores = parallel::detectCores())
lvStanModel <- stan_model(file = "SHO.stan",verbose=TRUE)
lvFit <- sampling(lvStanModel,
seed=42,
data=list(T = length(rdata_PP$P_obs$value),
y = rdata_PP$P_obs$value,
k1 = 2.0e2,
b = 2.0e-2,
d = 4.0e-1,
k2 = 2.0e1,
c = 4.0e-3,
deltaT = rdata_PP$P_obs$time[2] - rdata_PP$P_obs$time[1]
),
chains=1)
samples <- extract(lvFit)
gs1 <- qplot(x = samples$mu, y = ..density.., geom = "histogram") + xlab(expression(\mu))
gs2 <- qplot(x = samples$sigma, y = ..density.., geom = "histogram") + xlab(expression(samples$sigma))
gs3 <- grid.arrange(gs1, gs2)
ggsave(plot=gs3,filename="diagrams/LvPosteriorStan.png",width=4,height=3)
synthetic_dataset_PP1 <- bi_generate_dataset(endtime=endTime,
model=PP,
init = list(P = 100, Z=50),
seed="42",
verbose=TRUE,
add_options = list(
noutputs=500))
rdata_PP1 <- bi_read(synthetic_dataset_PP1)
synthetic_dataset_PP2 <- bi_generate_dataset(endtime=endTime,
model=PP,
init = list(P = 150, Z=25),
seed="42",
verbose=TRUE,
add_options = list(
noutputs=500))
rdata_PP2 <- bi_read(synthetic_dataset_PP2)
df1 <- data.frame(hare = rdata_PP$P$value,
lynx = rdata_PP$Z$value,
hare1 = rdata_PP1$P$value,
lynx1 = rdata_PP1$Z$value,
hare2 = rdata_PP2$P$value,
lynx2 = rdata_PP2$Z$value)
ggplot(df1) +
geom_path(aes(x=df1$hare, y=df1$lynx, col = "0"), size = 0.1) +
geom_path(aes(x=df1$hare1, y=df1$lynx1, col = "1"), size = 0.1) +
geom_path(aes(x=df1$hare2, y=df1$lynx2, col = "2"), size = 0.1) +
theme(legend.position="none") +
ggtitle("Phase Space") +
xlab("Hare") +
ylab("Lynx") +
theme(axis.text=element_text(size=4),
axis.title=element_text(size=6,face="bold")) +
theme(plot.title = element_text(size=10))
ggsave(filename="diagrams/PPviaLibBi.png",width=4,height=3)
PPInfer <- bi_model("PPInfer.bi")
bi_object_PP <- libbi(client="sample", model=PPInfer, obs = synthetic_dataset_PP)
bi_object_PP$run(add_options = list(
"end-time" = endTime,
noutputs = endTime,
nsamples = 2000,
nparticles = 128,
seed=42,
nthreads = 1),
verbose = TRUE,
stdoutput_file_name = tempfile(pattern="pmmhoutput", fileext=".txt"))
bi_file_summary(bi_object_PP$result$output_file_name)
mu <- bi_read(bi_object_PP, "mu")$value
g1 <- qplot(x = mu[2001:4000], y = ..density.., geom = "histogram") + xlab(expression(mu))
sigma <- bi_read(bi_object_PP, "sigma")$value
g2 <- qplot(x = sigma[2001:4000], y = ..density.., geom = "histogram") + xlab(expression(sigma))
g3 <- grid.arrange(g1, g2)
ggsave(plot=g3,filename="diagrams/LvPosterior.png",width=4,height=3)
df2 <- data.frame(hareActs = rdata_PP$P$value,
hareObs = rdata_PP$P_obs$value)
ggplot(df, aes(rdata_PP$P$nr, y = value, color = variable)) +
geom_line(aes(y = rdata_PP$P$value, col = "Phyto")) +
geom_line(aes(y = rdata_PP$Z$value, col = "Zoo")) +
geom_point(aes(y = rdata_PP$P_obs$value, col = "Phyto Obs"))
ln_alpha <- bi_read(bi_object_PP, "ln_alpha")$value
P <- matrix(bi_read(bi_object_PP, "P")$value,nrow=51,byrow=TRUE)
Z <- matrix(bi_read(bi_object_PP, "Z")$value,nrow=51,byrow=TRUE)
data50 <- bi_generate_dataset(endtime=endTime,
model=PP,
seed="42",
verbose=TRUE,
add_options = list(
noutputs=50))
rdata50 <- bi_read(data50)
df3 <- data.frame(days = c(1:51), hares = rowMeans(P), lynxes = rowMeans(Z),
actHs = rdata50$P$value, actLs = rdata50$Z$value)
ggplot(df3) +
geom_line(aes(x = days, y = hares, col = "Est Phyto")) +
geom_line(aes(x = days, y = lynxes, col = "Est Zoo")) +
geom_line(aes(x = days, y = actHs, col = "Act Phyto")) +
geom_line(aes(x = days, y = actLs, col = "Act Zoo"))
Carpenter, Bob. 2015. “Stan: A Probabilistic Programming Language.” Journal of Statistical Software.
Hoffman, Matthew D., and Andrew Gelman. 2014. “The No-U-Turn Sampler: Adaptively Setting Path Lengths in Hamiltonian Monte Carlo.” Journal of Machine Learning Research.
Stan Development Team. 2015a. Stan Modeling Language User’s Guide and Reference Manual, Version 2.10.0. http://mc-stan.org/.
———. 2015b. “Stan: A C++ Library for Probability and Sampling, Version 2.10.0.” http://mc-stan.org/.
In the 1920s, Lotka (1909) and Volterra (1926) developed a model of a very simple predator-prey ecosystem.
Although simple, it turns out that the Canadian lynx and showshoe hare are well represented by such a model. Furthermore, the Hudson Bay Company kept records of how many pelts of each species were trapped for almost a century, giving a good proxy of the population of each species.
We can capture the fact that we do not have a complete model by describing our state of ignorance about the parameters. In order to keep this as simple as possible let us assume that log parameters undergo Brownian motion. That is, we know the parameters will jiggle around and the further into the future we look the less certain we are about what values they will have taken. By making the log parameters undergo Brownian motion, we can also capture our modelling assumption that birth, death and predation rates are always positive. A similar approach is taken in Dureau, Kalogeropoulos, and Baguelin (2013) where the (log) parameters of an epidemiological model are taken to be Ornstein-Uhlenbeck processes (which is biologically more plausible although adds to the complexity of the model, something we wish to avoid in an example such as this).
Andrieu, Doucet, and Holenstein (2010) propose a method to estimate the parameters of such models (Particle Marginal Metropolis Hastings aka PMMH) and the domain specific probabilistic language LibBi (Murray (n.d.)) can be used to apply this (and other inference methods).
For the sake of simplicity, in this blog post, we only model one parameter as being unknown and undergoing Brownian motion. A future blog post will consider more sophisticated scenarios.
The above dynamical system is structurally unstable (more on this in a future post), a possible indication that it should not be considered as a good model of predator–prey interaction. Let us modify this to include carrying capacities for the populations of both species.
Let’s generate some data using LibBi.
// Generate data assuming a fixed growth rate for hares rather than
// e.g. a growth rate that undergoes Brownian motion.
model PP {
const h = 0.1; // time step
const delta_abs = 1.0e-3; // absolute error tolerance
const delta_rel = 1.0e-6; // relative error tolerance
const a = 5.0e-1 // Hare growth rate
const k1 = 2.0e2 // Hare carrying capacity
const b = 2.0e-2 // Hare death rate per lynx
const d = 4.0e-1 // Lynx death rate
const k2 = 2.0e1 // Lynx carrying capacity
const c = 4.0e-3 // Lynx birth rate per hare
state P, Z // Hares and lynxes
state ln_alpha // Hare growth rate - we express it in log form for
// consistency with the inference model
obs P_obs // Observations of hares
sub initial {
P ~ log_normal(log(100.0), 0.2)
Z ~ log_normal(log(50.0), 0.1)
}
sub transition(delta = h) {
ode(h = h, atoler = delta_abs, rtoler = delta_rel, alg = 'RK4(3)') {
dP/dt = a * P * (1 - P / k1) - b * P * Z
dZ/dt = -d * Z * (1 + Z / k2) + c * P * Z
}
}
sub observation {
P_obs ~ log_normal(log(P), 0.1)
}
}
We can look at phase space starting with different populations and see they all converge to the same fixed point.
Since at some point in the future, I plan to produce Haskell versions of the methods given in Andrieu, Doucet, and Holenstein (2010), let’s generate the data using Haskell.
> {-# OPTIONS_GHC -Wall #-}
> {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
> module LotkaVolterra (
> solLv
> , solPp
> , h0
> , l0
> , baz
> , logBM
> , eulerEx
> )where
> import Numeric.GSL.ODE
> import Numeric.LinearAlgebra
> import Data.Random.Source.PureMT
> import Data.Random hiding ( gamma )
> import Control.Monad.State
Here’s the unstable model.
> lvOde :: Double ->
> Double ->
> Double ->
> Double ->
> Double ->
> [Double] ->
> [Double]
> lvOde rho1 c1 rho2 c2 _t [h, l] =
> [
> rho1 * h - c1 * h * l
> , c2 * h * l - rho2 * l
> ]
> lvOde _rho1 _c1 _rho2 _c2 _t vars =
> error $ "lvOde called with: " ++ show (length vars) ++ " variable"
> rho1, c1, rho2, c2 :: Double
> rho1 = 0.5
> c1 = 0.02
> rho2 = 0.4
> c2 = 0.004
> deltaT :: Double
> deltaT = 0.1
> solLv :: Matrix Double
> solLv = odeSolve (lvOde rho1 c1 rho2 c2)
> [50.0, 50.0]
> (fromList [0.0, deltaT .. 50])
And here’s the stable model.
> ppOde :: Double ->
> Double ->
> Double ->
> Double ->
> Double ->
> Double ->
> Double ->
> [Double] ->
> [Double]
> ppOde a k1 b d k2 c _t [p, z] =
> [
> a * p * (1 - p / k1) - b * p * z
> , -d * z * (1 + z / k2) + c * p * z
> ]
> ppOde _a _k1 _b _d _k2 _c _t vars =
> error $ "ppOde called with: " ++ show (length vars) ++ " variable"
> a, k1, b, d, k2, c :: Double
> a = 0.5
> k1 = 200.0
> b = 0.02
> d = 0.4
> k2 = 50.0
> c = 0.004
> solPp :: Double -> Double -> Matrix Double
> solPp x y = odeSolve (ppOde a k1 b d k2 c)
> [x, y]
> (fromList [0.0, deltaT .. 50])
> gamma, alpha, beta :: Double
> gamma = d / a
> alpha = a / (c * k1)
> beta = d / (a * k2)
> fp :: (Double, Double)
> fp = ((gamma + beta) / (1 + alpha * beta), (1 - gamma * alpha) / (1 + alpha * beta))
> h0, l0 :: Double
> h0 = a * fst fp / c
> l0 = a * snd fp / b
> foo, bar :: Matrix R
> foo = matrix 2 [a / k1, b, c, negate d / k2]
> bar = matrix 1 [a, d]
> baz :: Maybe (Matrix R)
> baz = linearSolve foo bar
This gives a stable fixed point of
ghci> baz
Just (2><1)
[ 120.00000000000001
, 10.0 ]
Here’s an example of convergence to that fixed point in phase space.
Let us now assume that the Hare growth parameter undergoes Brownian motion so that the further into the future we go, the less certain we are about it. In order to ensure that this parameter remains positive, let’s model the log of it to be Brownian motion.
where the final equation is a stochastic differential equation with being a Wiener process.
By Itô we have
We can use this to generate paths for .
where .
> oneStepLogBM :: MonadRandom m => Double -> Double -> Double -> m Double
> oneStepLogBM deltaT sigma rhoPrev = do
> x <- sample $ rvar StdNormal
> return $ rhoPrev * exp(sigma * (sqrt deltaT) * x - 0.5 * sigma * sigma * deltaT)
> iterateM :: Monad m => (a -> m a) -> m a -> Int -> m [a]
> iterateM f mx n = sequence . take n . iterate (>>= f) $ mx
> logBMM :: MonadRandom m => Double -> Double -> Int -> Int -> m [Double]
> logBMM initRho sigma n m =
> iterateM (oneStepLogBM (recip $ fromIntegral n) sigma) (return initRho) (n * m)
> logBM :: Double -> Double -> Int -> Int -> Int -> [Double]
> logBM initRho sigma n m seed =
> evalState (logBMM initRho sigma n m) (pureMT $ fromIntegral seed)
We can see the further we go into the future the less certain we are about the value of the parameter.
Using this we can simulate the whole dynamical system which is now a stochastic process.
> f1, f2 :: Double -> Double -> Double ->
> Double -> Double ->
> Double
> f1 a k1 b p z = a * p * (1 - p / k1) - b * p * z
> f2 d k2 c p z = -d * z * (1 + z / k2) + c * p * z
> oneStepEuler :: MonadRandom m =>
> Double ->
> Double ->
> Double -> Double ->
> Double -> Double -> Double ->
> (Double, Double, Double) ->
> m (Double, Double, Double)
> oneStepEuler deltaT sigma k1 b d k2 c (rho1Prev, pPrev, zPrev) = do
> let pNew = pPrev + deltaT * f1 (exp rho1Prev) k1 b pPrev zPrev
> let zNew = zPrev + deltaT * f2 d k2 c pPrev zPrev
> rho1New <- oneStepLogBM deltaT sigma rho1Prev
> return (rho1New, pNew, zNew)
> euler :: MonadRandom m =>
> (Double, Double, Double) ->
> Double ->
> Double -> Double ->
> Double -> Double -> Double ->
> Int -> Int ->
> m [(Double, Double, Double)]
> euler stateInit sigma k1 b d k2 c n m =
> iterateM (oneStepEuler (recip $ fromIntegral n) sigma k1 b d k2 c)
> (return stateInit)
> (n * m)
> eulerEx :: (Double, Double, Double) ->
> Double -> Int -> Int -> Int ->
> [(Double, Double, Double)]
> eulerEx stateInit sigma n m seed =
> evalState (euler stateInit sigma k1 b d k2 c n m) (pureMT $ fromIntegral seed)
We see that the populations become noisier the further into the future we go.
Notice that the second order effects of the system are now to some extent captured by the fact that the growth rate of Hares can drift. In our simulation, this is demonstrated by our decreasing lack of knowledge the further we look into the future.
Now let us infer the growth rate using PMMH. Here’s the model expressed in LibBi.
// Infer growth rate for hares
model PP {
const h = 0.1; // time step
const delta_abs = 1.0e-3; // absolute error tolerance
const delta_rel = 1.0e-6; // relative error tolerance
const a = 5.0e-1 // Hare growth rate - superfluous for inference
// but a reminder of what we should expect
const k1 = 2.0e2 // Hare carrying capacity
const b = 2.0e-2 // Hare death rate per lynx
const d = 4.0e-1 // Lynx death rate
const k2 = 2.0e1 // Lynx carrying capacity
const c = 4.0e-3 // Lynx birth rate per hare
state P, Z // Hares and lynxes
state ln_alpha // Hare growth rate - we express it in log form for
// consistency with the inference model
obs P_obs // Observations of hares
param mu, sigma // Mean and standard deviation of hare growth rate
noise w // Noise
sub parameter {
mu ~ uniform(0.0, 1.0)
sigma ~ uniform(0.0, 0.5)
}
sub proposal_parameter {
mu ~ truncated_gaussian(mu, 0.02, 0.0, 1.0);
sigma ~ truncated_gaussian(sigma, 0.01, 0.0, 0.5);
}
sub initial {
P ~ log_normal(log(100.0), 0.2)
Z ~ log_normal(log(50.0), 0.1)
ln_alpha ~ gaussian(log(mu), sigma)
}
sub transition(delta = h) {
w ~ normal(0.0, sqrt(h));
ode(h = h, atoler = delta_abs, rtoler = delta_rel, alg = 'RK4(3)') {
dP/dt = exp(ln_alpha) * P * (1 - P / k1) - b * P * Z
dZ/dt = -d * Z * (1 + Z / k2) + c * P * Z
dln_alpha/dt = -sigma * sigma / 2 - sigma * w / h
}
}
sub observation {
P_obs ~ log_normal(log(P), 0.1)
}
}
Let’s look at the posteriors of the hyper-parameters for the Hare growth parameter.
The estimate for is pretty decent. For our generated data, and given our observations are quite noisy maybe the estimate for this is not too bad also.
All code including the R below can be downloaded from github but make sure you use the straight-libbi branch and not master.
install.packages("devtools")
library(devtools)
install_github("sbfnk/RBi",ref="master")
install_github("sbfnk/RBi.helpers",ref="master")
rm(list = ls(all.names=TRUE))
unlink(".RData")
library('RBi')
try(detach(package:RBi, unload = TRUE), silent = TRUE)
library(RBi, quietly = TRUE)
library('RBi.helpers')
library('ggplot2', quietly = TRUE)
library('gridExtra', quietly = TRUE)
endTime <- 50
PP <- bi_model("PP.bi")
synthetic_dataset_PP <- bi_generate_dataset(endtime=endTime,
model=PP,
seed="42",
verbose=TRUE,
add_options = list(
noutputs=500))
rdata_PP <- bi_read(synthetic_dataset_PP)
df <- data.frame(rdata_PP$P$nr,
rdata_PP$P$value,
rdata_PP$Z$value,
rdata_PP$P_obs$value)
ggplot(df, aes(rdata_PP$P$nr, y = Population, color = variable), size = 0.1) +
geom_line(aes(y = rdata_PP$P$value, col = "Hare"), size = 0.1) +
geom_line(aes(y = rdata_PP$Z$value, col = "Lynx"), size = 0.1) +
geom_point(aes(y = rdata_PP$P_obs$value, col = "Observations"), size = 0.1) +
theme(legend.position="none") +
ggtitle("Example Data") +
xlab("Days") +
theme(axis.text=element_text(size=4),
axis.title=element_text(size=6,face="bold")) +
theme(plot.title = element_text(size=10))
ggsave(filename="diagrams/LVdata.png",width=4,height=3)
synthetic_dataset_PP1 <- bi_generate_dataset(endtime=endTime,
model=PP,
init = list(P = 100, Z=50),
seed="42",
verbose=TRUE,
add_options = list(
noutputs=500))
rdata_PP1 <- bi_read(synthetic_dataset_PP1)
synthetic_dataset_PP2 <- bi_generate_dataset(endtime=endTime,
model=PP,
init = list(P = 150, Z=25),
seed="42",
verbose=TRUE,
add_options = list(
noutputs=500))
rdata_PP2 <- bi_read(synthetic_dataset_PP2)
df1 <- data.frame(hare = rdata_PP$P$value,
lynx = rdata_PP$Z$value,
hare1 = rdata_PP1$P$value,
lynx1 = rdata_PP1$Z$value,
hare2 = rdata_PP2$P$value,
lynx2 = rdata_PP2$Z$value)
ggplot(df1) +
geom_path(aes(x=df1$hare, y=df1$lynx, col = "0"), size = 0.1) +
geom_path(aes(x=df1$hare1, y=df1$lynx1, col = "1"), size = 0.1) +
geom_path(aes(x=df1$hare2, y=df1$lynx2, col = "2"), size = 0.1) +
theme(legend.position="none") +
ggtitle("Phase Space") +
xlab("Hare") +
ylab("Lynx") +
theme(axis.text=element_text(size=4),
axis.title=element_text(size=6,face="bold")) +
theme(plot.title = element_text(size=10))
ggsave(filename="diagrams/PPviaLibBi.png",width=4,height=3)
PPInfer <- bi_model("PPInfer.bi")
bi_object_PP <- libbi(client="sample", model=PPInfer, obs = synthetic_dataset_PP)
bi_object_PP$run(add_options = list(
"end-time" = endTime,
noutputs = endTime,
nsamples = 4000,
nparticles = 128,
seed=42,
nthreads = 1),
## verbose = TRUE,
stdoutput_file_name = tempfile(pattern="pmmhoutput", fileext=".txt"))
bi_file_summary(bi_object_PP$result$output_file_name)
mu <- bi_read(bi_object_PP, "mu")$value
g1 <- qplot(x = mu[2001:4000], y = ..density.., geom = "histogram") + xlab(expression(mu))
sigma <- bi_read(bi_object_PP, "sigma")$value
g2 <- qplot(x = sigma[2001:4000], y = ..density.., geom = "histogram") + xlab(expression(sigma))
g3 <- grid.arrange(g1, g2)
ggsave(plot=g3,filename="diagrams/LvPosterior.png",width=4,height=3)
df2 <- data.frame(hareActs = rdata_PP$P$value,
hareObs = rdata_PP$P_obs$value)
ggplot(df, aes(rdata_PP$P$nr, y = value, color = variable)) +
geom_line(aes(y = rdata_PP$P$value, col = "Phyto")) +
geom_line(aes(y = rdata_PP$Z$value, col = "Zoo")) +
geom_point(aes(y = rdata_PP$P_obs$value, col = "Phyto Obs"))
ln_alpha <- bi_read(bi_object_PP, "ln_alpha")$value
P <- matrix(bi_read(bi_object_PP, "P")$value,nrow=51,byrow=TRUE)
Z <- matrix(bi_read(bi_object_PP, "Z")$value,nrow=51,byrow=TRUE)
data50 <- bi_generate_dataset(endtime=endTime,
model=PP,
seed="42",
verbose=TRUE,
add_options = list(
noutputs=50))
rdata50 <- bi_read(data50)
df3 <- data.frame(days = c(1:51), hares = rowMeans(P), lynxes = rowMeans(Z),
actHs = rdata50$P$value, actLs = rdata50$Z$value)
ggplot(df3) +
geom_line(aes(x = days, y = hares, col = "Est Phyto")) +
geom_line(aes(x = days, y = lynxes, col = "Est Zoo")) +
geom_line(aes(x = days, y = actHs, col = "Act Phyto")) +
geom_line(aes(x = days, y = actLs, col = "Act Zoo"))
Andrieu, Christophe, Arnaud Doucet, and Roman Holenstein. 2010. “Particle Markov chain Monte Carlo methods.” Journal of the Royal Statistical Society. Series B: Statistical Methodology 72 (3): 269–342. doi:10.1111/j.1467-9868.2009.00736.x.
Dureau, Joseph, Konstantinos Kalogeropoulos, and Marc Baguelin. 2013. “Capturing the time-varying drivers of an epidemic using stochastic dynamical systems.” Biostatistics (Oxford, England) 14 (3): 541–55. doi:10.1093/biostatistics/kxs052.
Lotka, Alfred J. 1909. “Contribution to the Theory of Periodic Reactions.” The Journal of Physical Chemistry 14 (3): 271–74. doi:10.1021/j150111a004.
Murray, Lawrence M. n.d. “Bayesian State-Space Modelling on High-Performance Hardware Using LibBi.”
Volterra, Vito. 1926. “Variazioni e fluttuazioni del numero d’individui in specie animali conviventi.” Memorie Della R. Accademia Dei Lincei 6 (2): 31–113. http://www.liberliber.it/biblioteca/v/volterra/variazioni{\_}e{\_}fluttuazioni/pdf/volterra{\_}variazioni{\_}e{\_}fluttuazioni.pdf.
This is a bit different from my usual posts (well apart from my write up of hacking at Odessa) in that it is a log of how I managed to get LibBi (Library for Bayesian Inference) to run on my MacBook and then not totally satisfactorily (as you will see if you read on).
The intention is to try a few more approaches to the same problem, for example, Stan, monad-bayes and hand-crafted.
Kermack and McKendrick (1927) give a simple model of the spread of an infectious disease. Individuals move from being susceptible () to infected () to recovered ().
In 1978, anonymous authors sent a note to the British Medical Journal reporting an influenza outbreak in a boarding school in the north of England (“Influenza in a boarding school” 1978). The chart below shows the solution of the SIR (Susceptible, Infected, Record) model with parameters which give roughly the results observed in the school.
~/LibBi-stable/SIR-master $ ./init.sh
error: 'ncread' undefined near line 6 column 7
The README says this is optional so we can skip over it. Still it would be nice to fit the bridge weight function as described in Moral and Murray (2015).
The README does say that GPML is required but since we don’t (yet) need to do this step, let’s move on.
~/LibBi-stable/SIR-master $ ./run.sh
./run.sh
Error: ./configure failed with return code 77. See
.SIR/build_openmp_cuda_single/configure.log and
.SIR/build_openmp_cuda_single/config.log for details
It seems the example is configured to run on CUDA and it is highly likely that my installation of LibBI was not set up to allow this. We can change config.conf
from
--disable-assert
--enable-single
--enable-cuda
--nthreads 2
to
--nthreads 4
--enable-sse
--disable-assert
On to the next issue.
~/LibBi-stable/SIR-master $ ./run.sh
./run.sh
Error: ./configure failed with return code 1. required QRUpdate
library not found. See .SIR/build_sse/configure.log and
.SIR/build_sse/config.log for details
But QRUpdate is installed!
~/LibBi-stable/SIR-master $ brew info QRUpdate
brew info QRUpdate
homebrew/science/qrupdate: stable 1.1.2 (bottled)
http://sourceforge.net/projects/qrupdate/
/usr/local/Cellar/qrupdate/1.1.2 (3 files, 302.6K)
/usr/local/Cellar/qrupdate/1.1.2_2 (6 files, 336.3K)
Poured from bottle
/usr/local/Cellar/qrupdate/1.1.2_3 (6 files, 337.3K) *
Poured from bottle
From: https://github.com/Homebrew/homebrew-science/blob/master/qrupdate.rb
==> Dependencies
Required: veclibfort ✔
Optional: openblas ✔
==> Options
--with-openblas
Build with openblas support
--without-check
Skip build-time tests (not recommended)
Let’s look in the log as advised. So it seems that a certain symbol cannot be found.
checking for dch1dn_ in -lqrupdate
Let’s try ourselves.
nm -g /usr/local/Cellar/qrupdate/1.1.2_3/lib/libqrupdate.a | grep dch1dn_
0000000000000000 T _dch1dn_
So the symbol is there! What gives? Let’s try setting one of the environment variables.
export LDFLAGS='-L/usr/local/lib'
Now we get further.
./run.sh
Error: ./configure failed with return code 1. required NetCDF header
not found. See .SIR/build_sse/configure.log and
.SIR/build_sse/config.log for details
So we just need to set another environment variable.
export CPPFLAGS='-I/usr/local/include/'
This is more mysterious.
./run.sh
Error: ./configure failed with return code 1. required Boost header
not found. See .SIR/build_sse/configure.log and
.SIR/build_sse/config.log for details ~/LibBi-stable/SIR-master
Let’s see what we have.
brew list | grep -i boost
Nothing! I recall having some problems with boost
when trying to use a completely different package. So let’s install boost
.
brew install boost
Now we get a different error.
./run.sh
Error: make failed with return code 2, see .SIR/build_sse/make.log for details
Fortunately at some time in the past sbfnk took pity on me and advised me here to use boost155
, a step that should not be lightly undertaken.
/usr/local/Cellar/boost155/1.55.0_1: 10,036 files, 451.6M, built in 15 minutes 9 seconds
Even then I had to say
brew link --force boost155
Finally it runs.
./run.sh 2> out.txt
And produces a lot of output
wc -l out.txt
49999 out.txt
ls -ltrh results/posterior.nc
1.7G Apr 30 19:57 results/posterior.nc
Rather worringly, out.txt
has all lines of the form
1: -51.9191 -23.2045 nan beats -inf -inf -inf accept=0.5
nan
beating -inf
does not sound good.
Now we are in a position to analyse the results.
octave --path oct/ --eval "plot_and_print"
error: 'bi_plot_quantiles' undefined near line 23 column 5
I previously found an Octave package(?) called OctBi
so let’s create an .octaverc
file which adds this to the path. We’ll also need to load the netcdf
package which we previously installed.
addpath ("../OctBi-stable/inst")
pkg load netcdf
~/LibBi-stable/SIR-master $ octave --path oct/ --eval "plot_and_print"
octave --path oct/ --eval "plot_and_print"
warning: division by zero
warning: called from
mean at line 117 column 7
read_hist_simulator at line 47 column 11
bi_read_hist at line 85 column 12
bi_hist at line 63 column 12
plot_and_print at line 56 column 5
warning: division by zero
warning: division by zero
warning: division by zero
warning: division by zero
warning: division by zero
warning: print.m: fig2dev binary is not available.
Some output formats are not available.
warning: opengl_renderer: x/y/zdata should have the same dimensions. Not rendering.
warning: opengl_renderer: x/y/zdata should have the same dimensions. Not rendering.
warning: opengl_renderer: x/y/zdata should have the same dimensions. Not rendering.
warning: opengl_renderer: x/y/zdata should have the same dimensions. Not rendering.
warning: opengl_renderer: x/y/zdata should have the same dimensions. Not rendering.
warning: opengl_renderer: x/y/zdata should have the same dimensions. Not rendering.
warning: opengl_renderer: x/y/zdata should have the same dimensions. Not rendering.
warning: opengl_renderer: x/y/zdata should have the same dimensions. Not rendering.
warning: opengl_renderer: x/y/zdata should have the same dimensions. Not rendering.
warning: opengl_renderer: x/y/zdata should have the same dimensions. Not rendering.
warning: opengl_renderer: x/y/zdata should have the same dimensions. Not rendering.
warning: opengl_renderer: x/y/zdata should have the same dimensions. Not rendering.
warning: opengl_renderer: x/y/zdata should have the same dimensions. Not rendering.
warning: opengl_renderer: x/y/zdata should have the same dimensions. Not rendering.
warning: opengl_renderer: x/y/zdata should have the same dimensions. Not rendering.
warning: opengl_renderer: x/y/zdata should have the same dimensions. Not rendering.
warning: opengl_renderer: x/y/zdata should have the same dimensions. Not rendering.
warning: opengl_renderer: x/y/zdata should have the same dimensions. Not rendering.
warning: opengl_renderer: x/y/zdata should have the same dimensions. Not rendering.
warning: opengl_renderer: x/y/zdata should have the same dimensions. Not rendering.
warning: opengl_renderer: x/y/zdata should have the same dimensions. Not rendering.
warning: opengl_renderer: x/y/zdata should have the same dimensions. Not rendering.
warning: opengl_renderer: x/y/zdata should have the same dimensions. Not rendering.
warning: opengl_renderer: x/y/zdata should have the same dimensions. Not rendering.
sh: pdfcrop: command not found
I actually get a chart from this so some kind of success.
This does not look like the chart in the Moral and Murray (2015), the fitted number of infected patients looks a lot smoother and the “rates” parameters also vary in a much smoother manner. For reasons I haven’t yet investigated, it looks like over-fitting. Here’s the charts in the paper.
“Influenza in a boarding school.” 1978. British Medical Journal, March, 587.
Kermack, W. O., and A. G. McKendrick. 1927. “A Contribution to the Mathematical Theory of Epidemics.” Proceedings of the Royal Society of London Series A 115 (August): 700–721. doi:10.1098/rspa.1927.0118.
Moral, Pierre Del, and Lawrence M Murray. 2015. “Sequential Monte Carlo with Highly Informative Observations.”
In their paper Betancourt et al. (2014), the authors give a corollary which starts with the phrase “Because the manifold is paracompact”. It wasn’t immediately clear why the manifold was paracompact or indeed what paracompactness meant although it was clearly something like compactness which means that every cover has a finite sub-cover.
It turns out that every manifold is paracompact and that this is intimately related to partitions of unity.
Most of what I have written below is taken from some hand-written anonymous lecture notes I found by chance in the DPMMS library in Cambridge University. To whomever wrote them: thank you very much.
Let be an open cover of a smooth manifold . A partition of unity on M, subordinate to the cover is a finite collection of smooth functions
where for some such that
and for each there exists such that
We don’t yet know partitions of unity exist.
First define
Techniques of classical analysis easily show that is smooth ( is the only point that might be in doubt and it can be checked from first principles that for all ).
Next define
Finally we can define by . This has the properties
Now take a point centred in a chart so that, without loss of generality, (we can always choose so that the open ball and then define another chart with ).
Define the images of the open and closed balls of radius and respectively
and further define bump functions
Then is smooth and its support lies in .
By compactness, the open cover has a finite subcover . Now define
by
Then is smooth, and . Thus is the required partition of unity.
Because is a manifold, it has a countable basis and for any point , there must exist with . Choose one of these and call it . This gives a countable cover of by such sets.
Now define
where, since is compact, is a finite subcover.
And further define
where again, since is compact, is a finite subcover.
Now define
Then is compact, is open and . Furthermore, and only intersects with and .
Given any open cover of , each can be covered by a finite number of open sets in contained in some member of . Thus every point in can be covered by at most a finite number of sets from and and which are contained in some member of . This is a locally finite refinement of and which is precisely the definition of paracompactness.
To produce a partition of unity we define bump functions as above on this locally finite cover and note that locally finite implies that is well defined. Again, as above, define
to get the required result.
Betancourt, M. J., Simon Byrne, Samuel Livingstone, and Mark Girolami. 2014. “The Geometric Foundations of Hamiltonian Monte Carlo,” October, 45. http://arxiv.org/abs/1410.5110.
In proposition 58 Chapter 1 in the excellent book O’Neill (1983), the author demonstrates that the Lie derivative of one vector field with respect to another is the same as the Lie bracket (of the two vector fields) although he calls the Lie bracket just bracket and does not define the Lie derivative preferring just to use its definition with giving it a name. The proof relies on a prior result where he shows a co-ordinate system at a point can be given to a vector field for which so that .
Here’s a proof seems clearer (to me at any rate) and avoids having to distinguish the case wehere the vector field is zero or non-zero. These notes give a similar proof but, strangely for undergraduate level, elide some of the details.
Let be a smooth mapping and let be a tensor with then define the pullback of by to be
For a tensor the pullback is defined to be .
Standard manipulations show that is a smooth (covariant) tensor field and that is -linear and that .
Let be a diffeomorphism and a vector field on we define the pullback of this field to be
Note that the pullback of a vector field only exists in the case where is a diffeomorphism; in contradistinction, in the case of pullbacks of purely covariant tensors, the pullback always exists.
For the proof below, we only need the pullback of functions and vector fields; the pullback for tensors with is purely to give a bit of context.
From O’Neill (1983) Chapter 1 Definition 20, let be a smooth mapping. Vector fields on and on are –related written if and only if .
By Lemma 21 Chapter 1 of O’Neill (1983), and are -related if and only if .
Recalling that and since
we see that the fields and are -related: . Thus we can apply the Lemma.
Although we don’t need this, we can express the immediately above equivalence in a way similar to the rule for covariant tensors
First let’s calculate the Lie derivative of a function with respect to a vector field where is its flow
Analogously defining the Lie derivative of with respect to
we have
Since we have
Thus
as required.
O’Neill, B. 1983. Semi-Riemannian Geometry with Applications to Relativity, 103. Pure and Applied Mathematics. Elsevier Science. https://books.google.com.au/books?id=CGk1eRSjFIIC.
The equation of motion for a pendulum of unit length subject to Gaussian white noise is
We can discretize this via the usual Euler method
where and
The explanation of the precise form of the covariance matrix will be the subject of another blog post; for the purpose of exposition of forward filtering / backward smoothing, this detail is not important.
Assume that we can only measure the horizontal position of the pendulum and further that this measurement is subject to error so that
where .
Particle Filtering can give us an estimate of where the pendulum is and its velocity using all the observations up to that point in time. But now suppose we have observed the pendulum for a fixed period of time then at times earlier than the time at which we stop our observations we now have observations in the future as well as in the past. If we can somehow take account of these future observations then we should be able to improve our estimate of where the pendulum was at any given point in time (as well as its velocity). Forward Filtering / Backward Smoothing is a technique for doing this.
> {-# OPTIONS_GHC -Wall #-}
> {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
> {-# OPTIONS_GHC -fno-warn-type-defaults #-}
> {-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
> {-# OPTIONS_GHC -fno-warn-missing-methods #-}
> {-# OPTIONS_GHC -fno-warn-orphans #-}
> {-# LANGUAGE MultiParamTypeClasses #-}
> {-# LANGUAGE TypeFamilies #-}
> {-# LANGUAGE ScopedTypeVariables #-}
> {-# LANGUAGE ExplicitForAll #-}
> {-# LANGUAGE DataKinds #-}
> {-# LANGUAGE FlexibleInstances #-}
> {-# LANGUAGE MultiParamTypeClasses #-}
> {-# LANGUAGE FlexibleContexts #-}
> {-# LANGUAGE TypeFamilies #-}
> {-# LANGUAGE BangPatterns #-}
> {-# LANGUAGE GeneralizedNewtypeDeriving #-}
> {-# LANGUAGE TemplateHaskell #-}
> {-# LANGUAGE DataKinds #-}
> {-# LANGUAGE DeriveGeneric #-}
> module PendulumSamples ( pendulumSamples
> , pendulumSamples'
> , testFiltering
> , testSmoothing
> , testFilteringG
> , testSmoothingG
> ) where
> import Data.Random hiding ( StdNormal, Normal )
> import Data.Random.Source.PureMT ( pureMT )
> import Control.Monad.State ( evalState, replicateM )
> import qualified Control.Monad.Loops as ML
> import Control.Monad.Writer ( tell, WriterT, lift,
> runWriterT
> )
> import Numeric.LinearAlgebra.Static
> ( R, vector, Sym,
> headTail, matrix, sym,
> diag
> )
> import GHC.TypeLits ( KnownNat )
> import MultivariateNormal ( MultivariateNormal(..) )
> import qualified Data.Vector as V
> import Data.Bits ( shiftR )
> import Data.List ( transpose )
> import Control.Parallel.Strategies
> import GHC.Generics (Generic)
Let’s first plot some typical trajectories of the pendulum.
> deltaT, g :: Double
> deltaT = 0.01
> g = 9.81
> type PendulumState = R 2
> type PendulumObs = R 1
> pendulumSample :: MonadRandom m =>
> Sym 2 ->
> Sym 1 ->
> PendulumState ->
> m (Maybe ((PendulumState, PendulumObs), PendulumState))
> pendulumSample bigQ bigR xPrev = do
> let x1Prev = fst $ headTail xPrev
> x2Prev = fst $ headTail $ snd $ headTail xPrev
> eta <- sample $ rvar (MultivariateNormal 0.0 bigQ)
> let x1= x1Prev + x2Prev * deltaT
> x2 = x2Prev - g * (sin x1Prev) * deltaT
> xNew = vector [x1, x2] + eta
> x1New = fst $ headTail xNew
> epsilon <- sample $ rvar (MultivariateNormal 0.0 bigR)
> let yNew = vector [sin x1New] + epsilon
> return $ Just ((xNew, yNew), xNew)
Let’s try plotting some samples when we are in the linear region with which we are familiar from school .
In this case we expect the horizontal displacement to be approximately equal to the angle of displacement and thus the observations to be symmetric about the actuals.
> bigQ :: Sym 2
> bigQ = sym $ matrix bigQl
> qc1 :: Double
> qc1 = 0.0001
> bigQl :: [Double]
> bigQl = [ qc1 * deltaT^3 / 3, qc1 * deltaT^2 / 2,
> qc1 * deltaT^2 / 2, qc1 * deltaT
> ]
> bigR :: Sym 1
> bigR = sym $ matrix [0.0001]
> m0 :: PendulumState
> m0 = vector [0.01, 0]
> pendulumSamples :: [(PendulumState, PendulumObs)]
> pendulumSamples = evalState (ML.unfoldrM (pendulumSample bigQ bigR) m0) (pureMT 17)
But if we work in a region in which linearity breaks down then the observations are no longer symmetrical about the actuals.
> bigQ' :: Sym 2
> bigQ' = sym $ matrix bigQl'
> qc1' :: Double
> qc1' = 0.01
> bigQl' :: [Double]
> bigQl' = [ qc1' * deltaT^3 / 3, qc1' * deltaT^2 / 2,
> qc1' * deltaT^2 / 2, qc1' * deltaT
> ]
> bigR' :: Sym 1
> bigR' = sym $ matrix [0.1]
> m0' :: PendulumState
> m0' = vector [1.6, 0]
> pendulumSamples' :: [(PendulumState, PendulumObs)]
> pendulumSamples' = evalState (ML.unfoldrM (pendulumSample bigQ' bigR') m0') (pureMT 17)
We do not give the theory behind particle filtering. The interested reader can either consult Särkkä (2013) or wait for a future blog post on the subject.
> nParticles :: Int
> nParticles = 500
The usual Bayesian update step.
> type Particles a = V.Vector a
> oneFilteringStep ::
> MonadRandom m =>
> (Particles a -> m (Particles a)) ->
> (Particles a -> Particles b) ->
> (b -> b -> Double) ->
> Particles a ->
> b ->
> WriterT [Particles a] m (Particles a)
> oneFilteringStep stateUpdate obsUpdate weight statePrevs obs = do
> tell [statePrevs]
> stateNews <- lift $ stateUpdate statePrevs
> let obsNews = obsUpdate stateNews
> let weights = V.map (weight obs) obsNews
> cumSumWeights = V.tail $ V.scanl (+) 0 weights
> totWeight = V.last cumSumWeights
> vs <- lift $ V.replicateM nParticles (sample $ uniform 0.0 totWeight)
> let js = indices cumSumWeights vs
> stateTildes = V.map (stateNews V.!) js
> return stateTildes
The system state and observable.
> data SystemState a = SystemState { x1 :: a, x2 :: a }
> deriving (Show, Generic)
> instance NFData a => NFData (SystemState a)
> newtype SystemObs a = SystemObs { y1 :: a }
> deriving Show
To make the system state update a bit more readable, let’s introduce some lifted arithmetic operators.
> (.+), (.*), (.-) :: (Num a) => V.Vector a -> V.Vector a -> V.Vector a
> (.+) = V.zipWith (+)
> (.*) = V.zipWith (*)
> (.-) = V.zipWith (-)
The state update itself
> stateUpdate :: Particles (SystemState Double) ->
> Particles (SystemState Double)
> stateUpdate xPrevs = V.zipWith SystemState x1s x2s
> where
> ix = V.length xPrevs
>
> x1Prevs = V.map x1 xPrevs
> x2Prevs = V.map x2 xPrevs
>
> deltaTs = V.replicate ix deltaT
> gs = V.replicate ix g
> x1s = x1Prevs .+ (x2Prevs .* deltaTs)
> x2s = x2Prevs .- (gs .* (V.map sin x1Prevs) .* deltaTs)
and its noisy version.
> stateUpdateNoisy :: MonadRandom m =>
> Sym 2 ->
> Particles (SystemState Double) ->
> m (Particles (SystemState Double))
> stateUpdateNoisy bigQ xPrevs = do
> let xs = stateUpdate xPrevs
>
> x1s = V.map x1 xs
> x2s = V.map x2 xs
>
> let ix = V.length xPrevs
> etas <- replicateM ix $ sample $ rvar (MultivariateNormal 0.0 bigQ)
>
> let eta1s, eta2s :: V.Vector Double
> eta1s = V.fromList $ map (fst . headTail) etas
> eta2s = V.fromList $ map (fst . headTail . snd . headTail) etas
>
> return (V.zipWith SystemState (x1s .+ eta1s) (x2s .+ eta2s))
The function which maps the state to the observable.
> obsUpdate :: Particles (SystemState Double) ->
> Particles (SystemObs Double)
> obsUpdate xs = V.map (SystemObs . sin . x1) xs
And finally a function to calculate the weight of each particle given an observation.
> weight :: forall a n . KnownNat n =>
> (a -> R n) ->
> Sym n ->
> a -> a -> Double
> weight f bigR obs obsNew = pdf (MultivariateNormal (f obsNew) bigR) (f obs)
The variance of the prior.
> bigP :: Sym 2
> bigP = sym $ diag 0.1
Generate our ensemble of particles chosen from the prior,
> initParticles :: MonadRandom m =>
> m (Particles (SystemState Double))
> initParticles = V.replicateM nParticles $ do
> r <- sample $ rvar (MultivariateNormal m0' bigP)
> let x1 = fst $ headTail r
> x2 = fst $ headTail $ snd $ headTail r
> return $ SystemState { x1 = x1, x2 = x2}
run the particle filter,
> runFilter :: Int -> [Particles (SystemState Double)]
> runFilter nTimeSteps = snd $ evalState action (pureMT 19)
> where
> action = runWriterT $ do
> xs <- lift $ initParticles
> V.foldM
> (oneFilteringStep (stateUpdateNoisy bigQ') obsUpdate (weight f bigR'))
> xs
> (V.fromList $ map (SystemObs . fst . headTail . snd)
> (take nTimeSteps pendulumSamples'))
and extract the estimated position from the filter.
> testFiltering :: Int -> [Double]
> testFiltering nTimeSteps = map ((/ (fromIntegral nParticles)). sum . V.map x1)
> (runFilter nTimeSteps)
If we could calculate the marginal smoothing distributions then we might be able to sample from them. Using the Markov assumption of our model that is independent of given , we have
We observe that this is a (continuous state space) Markov process with a non-homogeneous transition function albeit one which goes backwards in time. Apparently for conditionally Gaussian linear state-space models, this is known as RTS, or Rauch-Tung-Striebel smoothing (Rauch, Striebel, and Tung (1965)).
According to Cappé (2008),
It appears to be efficient and stable in the long term (although no proof was available at the time the slides were presented).
It is not sequential (in particular, one needs to store all particle positions and weights).
It has numerical complexity proportional where is the number of particles.
We can use this to sample paths starting at time and working backwards. From above we have
where is some normalisation constant (Z for “Zustandssumme” – sum over states).
From particle filtering we know that
Thus
and we can sample from with probability
Recalling that we have re-sampled the particles in the filtering algorithm so that their weights are all and abstracting the state update and state density function, we can encode this update step in Haskell as
> oneSmoothingStep :: MonadRandom m =>
> (Particles a -> V.Vector a) ->
> (a -> a -> Double) ->
> a ->
> Particles a ->
> WriterT (Particles a) m a
> oneSmoothingStep stateUpdate
> stateDensity
> smoothingSampleAtiPlus1
> filterSamplesAti = do it
> where
> it = do
> let mus = stateUpdate filterSamplesAti
> weights = V.map (stateDensity smoothingSampleAtiPlus1) mus
> cumSumWeights = V.tail $ V.scanl (+) 0 weights
> totWeight = V.last cumSumWeights
> v <- lift $ sample $ uniform 0.0 totWeight
> let ix = binarySearch cumSumWeights v
> xnNew = filterSamplesAti V.! ix
> tell $ V.singleton xnNew
> return $ xnNew
To sample a complete path we start with a sample from the filtering distribution at at time (which is also the smoothing distribution)
> oneSmoothingPath :: MonadRandom m =>
> (Int -> V.Vector (Particles a)) ->
> (a -> Particles a -> WriterT (Particles a) m a) ->
> Int -> m (a, V.Vector a)
> oneSmoothingPath filterEstss oneSmoothingStep nTimeSteps = do
> let ys = filterEstss nTimeSteps
> ix <- sample $ uniform 0 (nParticles - 1)
> let xn = (V.head ys) V.! ix
> runWriterT $ V.foldM oneSmoothingStep xn (V.tail ys)
> oneSmoothingPath' :: (MonadRandom m, Show a) =>
> (Int -> V.Vector (Particles a)) ->
> (a -> Particles a -> WriterT (Particles a) m a) ->
> Int -> WriterT (Particles a) m a
> oneSmoothingPath' filterEstss oneSmoothingStep nTimeSteps = do
> let ys = filterEstss nTimeSteps
> ix <- lift $ sample $ uniform 0 (nParticles - 1)
> let xn = (V.head ys) V.! ix
> V.foldM oneSmoothingStep xn (V.tail ys)
Of course we need to run through the filtering distributions starting at
> filterEstss :: Int -> V.Vector (Particles (SystemState Double))
> filterEstss n = V.reverse $ V.fromList $ runFilter n
> testSmoothing :: Int -> Int -> [Double]
> testSmoothing m n = V.toList $ evalState action (pureMT 23)
> where
> action = do
> xss <- V.replicateM n $
> snd <$> (oneSmoothingPath filterEstss (oneSmoothingStep stateUpdate (weight h bigQ')) m)
> let yss = V.fromList $ map V.fromList $
> transpose $
> V.toList $ V.map (V.toList) $
> xss
> return $ V.map (/ (fromIntegral n)) $ V.map V.sum $ V.map (V.map x1) yss
By eye we can see we get a better fit
and calculating the mean square error for filtering gives against the mean square error for smoothing of ; this confirms the fit really is better as one would hope.
Let us continue with the same example but now assume that is unknown and that we wish to estimate it. Let us also assume that our apparatus is not subject to noise.
Again we have
But now when we discretize it we include a third variable
where
Again we assume that we can only measure the horizontal position of the pendulum so that
where .
> type PendulumStateG = R 3
> pendulumSampleG :: MonadRandom m =>
> Sym 3 ->
> Sym 1 ->
> PendulumStateG ->
> m (Maybe ((PendulumStateG, PendulumObs), PendulumStateG))
> pendulumSampleG bigQ bigR xPrev = do
> let x1Prev = fst $ headTail xPrev
> x2Prev = fst $ headTail $ snd $ headTail xPrev
> x3Prev = fst $ headTail $ snd $ headTail $ snd $ headTail xPrev
> eta <- sample $ rvar (MultivariateNormal 0.0 bigQ)
> let x1= x1Prev + x2Prev * deltaT
> x2 = x2Prev - g * (sin x1Prev) * deltaT
> x3 = x3Prev
> xNew = vector [x1, x2, x3] + eta
> x1New = fst $ headTail xNew
> epsilon <- sample $ rvar (MultivariateNormal 0.0 bigR)
> let yNew = vector [sin x1New] + epsilon
> return $ Just ((xNew, yNew), xNew)
> pendulumSampleGs :: [(PendulumStateG, PendulumObs)]
> pendulumSampleGs = evalState (ML.unfoldrM (pendulumSampleG bigQg bigRg) mG) (pureMT 29)
> data SystemStateG a = SystemStateG { gx1 :: a, gx2 :: a, gx3 :: a }
> deriving Show
The state update itself
> stateUpdateG :: Particles (SystemStateG Double) ->
> Particles (SystemStateG Double)
> stateUpdateG xPrevs = V.zipWith3 SystemStateG x1s x2s x3s
> where
> ix = V.length xPrevs
>
> x1Prevs = V.map gx1 xPrevs
> x2Prevs = V.map gx2 xPrevs
> x3Prevs = V.map gx3 xPrevs
>
> deltaTs = V.replicate ix deltaT
> x1s = x1Prevs .+ (x2Prevs .* deltaTs)
> x2s = x2Prevs .- (x3Prevs .* (V.map sin x1Prevs) .* deltaTs)
> x3s = x3Prevs
and its noisy version.
> stateUpdateNoisyG :: MonadRandom m =>
> Sym 3 ->
> Particles (SystemStateG Double) ->
> m (Particles (SystemStateG Double))
> stateUpdateNoisyG bigQ xPrevs = do
> let ix = V.length xPrevs
>
> let xs = stateUpdateG xPrevs
>
> x1s = V.map gx1 xs
> x2s = V.map gx2 xs
> x3s = V.map gx3 xs
>
> etas <- replicateM ix $ sample $ rvar (MultivariateNormal 0.0 bigQ)
> let eta1s, eta2s, eta3s :: V.Vector Double
> eta1s = V.fromList $ map (fst . headTail) etas
> eta2s = V.fromList $ map (fst . headTail . snd . headTail) etas
> eta3s = V.fromList $ map (fst . headTail . snd . headTail . snd . headTail) etas
>
> return (V.zipWith3 SystemStateG (x1s .+ eta1s) (x2s .+ eta2s) (x3s .+ eta3s))
The function which maps the state to the observable.
> obsUpdateG :: Particles (SystemStateG Double) ->
> Particles (SystemObs Double)
> obsUpdateG xs = V.map (SystemObs . sin . gx1) xs
The mean and variance of the prior.
> mG :: R 3
> mG = vector [1.6, 0.0, 8.00]
> bigPg :: Sym 3
> bigPg = sym $ matrix [
> 1e-6, 0.0, 0.0
> , 0.0, 1e-6, 0.0
> , 0.0, 0.0, 1e-2
> ]
Parameters for the state update; note that the variance is not exactly the same as in the formulation above.
> bigQg :: Sym 3
> bigQg = sym $ matrix bigQgl
> qc1G :: Double
> qc1G = 0.0001
> sigmaG :: Double
> sigmaG = 1.0e-2
> bigQgl :: [Double]
> bigQgl = [ qc1G * deltaT^3 / 3, qc1G * deltaT^2 / 2, 0.0,
> qc1G * deltaT^2 / 2, qc1G * deltaT, 0.0,
> 0.0, 0.0, sigmaG
> ]
The noise of the measurement.
> bigRg :: Sym 1
> bigRg = sym $ matrix [0.1]
Generate the ensemble of particles from the prior,
> initParticlesG :: MonadRandom m =>
> m (Particles (SystemStateG Double))
> initParticlesG = V.replicateM nParticles $ do
> r <- sample $ rvar (MultivariateNormal mG bigPg)
> let x1 = fst $ headTail r
> x2 = fst $ headTail $ snd $ headTail r
> x3 = fst $ headTail $ snd $ headTail $ snd $ headTail r
> return $ SystemStateG { gx1 = x1, gx2 = x2, gx3 = x3}
run the particle filter,
> runFilterG :: Int -> [Particles (SystemStateG Double)]
> runFilterG n = snd $ evalState action (pureMT 19)
> where
> action = runWriterT $ do
> xs <- lift $ initParticlesG
> V.foldM
> (oneFilteringStep (stateUpdateNoisyG bigQg) obsUpdateG (weight f bigRg))
> xs
> (V.fromList $ map (SystemObs . fst . headTail . snd) (take n pendulumSampleGs))
and extract the estimated parameter from the filter.
> testFilteringG :: Int -> [Double]
> testFilteringG n = map ((/ (fromIntegral nParticles)). sum . V.map gx3) (runFilterG n)
Again we need to run through the filtering distributions starting at
> filterGEstss :: Int -> V.Vector (Particles (SystemStateG Double))
> filterGEstss n = V.reverse $ V.fromList $ runFilterG n
> testSmoothingG :: Int -> Int -> ([Double], [Double], [Double])
> testSmoothingG m n = (\(x, y, z) -> (V.toList x, V.toList y, V.toList z)) $
> mkMeans $
> chunks
> where
>
> chunks =
> V.fromList $ map V.fromList $
> transpose $
> V.toList $ V.map (V.toList) $
> chunksOf m $
> snd $ evalState (runWriterT action) (pureMT 23)
>
> mkMeans yss = (
> V.map (/ (fromIntegral n)) $ V.map V.sum $ V.map (V.map gx1) yss,
> V.map (/ (fromIntegral n)) $ V.map V.sum $ V.map (V.map gx2) yss,
> V.map (/ (fromIntegral n)) $ V.map V.sum $ V.map (V.map gx3) yss
> )
>
> action =
> V.replicateM n $
> oneSmoothingPath' filterGEstss
> (oneSmoothingStep stateUpdateG (weight hG bigQg))
> m
Again by eye we get a better fit but note that we are using the samples in which the state update is noisy as well as the observation so we don’t expect to get a very good fit.
> f :: SystemObs Double -> R 1
> f = vector . pure . y1
> h :: SystemState Double -> R 2
> h u = vector [x1 u , x2 u]
> hG :: SystemStateG Double -> R 3
> hG u = vector [gx1 u , gx2 u, gx3 u]
That these are helpers for the inverse CDF is delayed to another blog post.
> indices :: V.Vector Double -> V.Vector Double -> V.Vector Int
> indices bs xs = V.map (binarySearch bs) xs
> binarySearch :: (Ord a) =>
> V.Vector a -> a -> Int
> binarySearch vec x = loop 0 (V.length vec - 1)
> where
> loop !l !u
> | u <= l = l
> | otherwise = let e = vec V.! k in if x <= e then loop l k else loop (k+1) u
> where k = l + (u - l) `shiftR` 1
> chunksOf :: Int -> V.Vector a -> V.Vector (V.Vector a)
> chunksOf n xs = ys
> where
> l = V.length xs
> m = 1 + (l - 1) `div` n
> ys = V.unfoldrN m (\us -> Just (V.take n us, V.drop n us)) xs
Cappé, Olivier. 2008. “An Introduction to Sequential Monte Carlo for Filtering and Smoothing.” http://www-irma.u-strasbg.fr/~guillou/meeting/cappe.pdf.
Rauch, H. E., C. T. Striebel, and F. Tung. 1965. “Maximum Likelihood Estimates of Linear Dynamic Systems.” Journal of the American Institute of Aeronautics and Astronautics 3 (8): 1445–50.
Särkkä, Simo. 2013. Bayesian Filtering and Smoothing. New York, NY, USA: Cambridge University Press.
The equation of motion for a pendulum of unit length subject to Gaussian white noise is
We can discretize this via the usual Euler method
where and
The explanation of the precise form of the covariance matrix will be the subject of another blog post; for the purpose of exposition of using Stan and, in particular, Stan’s ability to handle ODEs, this detail is not important.
Instead of assuming that we know let us take it to be unknown and that we wish to infer its value using the pendulum as our experimental apparatus.
Stan is a probabilistic programming language which should be welll suited to perform such an inference. We use its interface via the R package rstan.
Let’s generate some samples using Stan but rather than generating exactly the model we have given above, instead let’s solve the differential equation and then add some noise. Of course this won’t quite give us samples from the model the parameters of which we wish to estimate but it will allow us to use Stan’s ODE solving capability.
Here’s the Stan
functions {
real[] pendulum(real t,
real[] y,
real[] theta,
real[] x_r,
int[] x_i) {
real dydt[2];
dydt[1] <- y[2];
dydt[2] <- - theta[1] * sin(y[1]);
return dydt;
}
}
data {
int<lower=1> T;
real y0[2];
real t0;
real ts[T];
real theta[1];
real sigma[2];
}
transformed data {
real x_r[0];
int x_i[0];
}
model {
}
generated quantities {
real y_hat[T,2];
y_hat <- integrate_ode(pendulum, y0, t0, ts, theta, x_r, x_i);
for (t in 1:T) {
y_hat[t,1] <- y_hat[t,1] + normal_rng(0,sigma[1]);
y_hat[t,2] <- y_hat[t,2] + normal_rng(0,sigma[2]);
}
}
And here’s the R to invoke it
library(rstan)
library(mvtnorm)
qc1 = 0.0001
deltaT = 0.01
nSamples = 100
m0 = c(1.6, 0)
g = 9.81
t0 = 0.0
ts = seq(deltaT,nSamples * deltaT,deltaT)
bigQ = matrix(c(qc1 * deltaT^3 / 3, qc1 * deltaT^2 / 2,
qc1 * deltaT^2 / 2, qc1 * deltaT
),
nrow = 2,
ncol = 2,
byrow = TRUE
)
samples <- stan(file = 'Pendulum.stan',
data = list (
T = nSamples,
y0 = m0,
t0 = t0,
ts = ts,
theta = array(g, dim = 1),
sigma = c(bigQ[1,1], bigQ[2,2]),
refresh = -1
),
algorithm="Fixed_param",
seed = 42,
chains = 1,
iter =1
)
We can plot the angle the pendulum subtends to the vertical over time. Note that this is not very noisy.
s <- extract(samples,permuted=FALSE)
plot(s[1,1,1:100])
Now let us suppose that we don’t know the value of and we can only observe the horizontal displacement.
zStan <- sin(s[1,1,1:nSamples])
Now we can use Stan to infer the value of .
functions {
real[] pendulum(real t,
real[] y,
real[] theta,
real[] x_r,
int[] x_i) {
real dydt[2];
dydt[1] <- y[2];
dydt[2] <- - theta[1] * sin(y[1]);
return dydt;
}
}
data {
int<lower=1> T;
real y0[2];
real z[T];
real t0;
real ts[T];
}
transformed data {
real x_r[0];
int x_i[0];
}
parameters {
real theta[1];
vector<lower=0>[1] sigma;
}
model {
real y_hat[T,2];
real z_hat[T];
theta ~ normal(0,1);
sigma ~ cauchy(0,2.5);
y_hat <- integrate_ode(pendulum, y0, t0, ts, theta, x_r, x_i);
for (t in 1:T) {
z_hat[t] <- sin(y_hat[t,1]);
z[t] ~ normal(z_hat[t], sigma);
}
}
Here’s the R to invoke it.
estimates <- stan(file = 'PendulumInfer.stan',
data = list (
T = nSamples,
y0 = m0,
z = zStan,
t0 = t0,
ts = ts
),
seed = 42,
chains = 1,
iter = 1000,
warmup = 500,
refresh = -1
)
e <- extract(estimates,pars=c("theta[1]","sigma[1]","lp__"),permuted=TRUE)
This gives an estiamted valeu for of 9.809999 which is what we would hope.
Now let’s try adding some noise to our observations.
set.seed(42)
epsilons <- rmvnorm(n=nSamples,mean=c(0.0),sigma=bigR)
zStanNoisy <- sin(s[1,1,1:nSamples] + epsilons[,1])
estimatesNoisy <- stan(file = 'PendulumInfer.stan',
data = list (T = nSamples,
y0 = m0,
z = zStanNoisy,
t0 = t0,
ts = ts
),
seed = 42,
chains = 1,
iter = 1000,
warmup = 500,
refresh = -1
)
eNoisy <- extract(estimatesNoisy,pars=c("theta[1]","sigma[1]","lp__"),permuted=TRUE)
This gives an estiamted value for of 8.5871024 which is ok but not great.
To build this page, download the relevant files from github and run this in R:
library(knitr)
knit('Pendulum.Rmd')
And this from command line:
pandoc -s Pendulum.md --filter=./Include > PendulumExpanded.html