These are the libraries we will be using
library(pdist)
library(MASS)
library(INLA)
library(reshape2)
library(maptools)
library(ggplot2)
And this is some code that will become handy at some point during the exposition. The files will be uploaded in the course web page.
source("kernels.R")
source("gps.R")
Some initial adjustments to define the plots size, and we are ready to go...
options(repr.plot.width=5, repr.plot.height=3)
#install.packages("Cairo", repos='http://cran.us.r-project.org')
Let , with .
Say and . For a random realization of 's we would have something like this:
num_sims <- 50
beta_0 <- 2
beta_1 <- 1/3
mu = 0
sigma = 1
x <- seq(-10, 10, len = num_sims) # Lets use an evenly spaced set of inputs
f <- rnorm(num_sims, mu, sigma) # random realizations of f
xy <- data.frame(x = x, f = f, y = beta_0 + beta_1 * x + f)
ggplot(xy, aes(x, y)) + geom_point(col = "steelblue") +
geom_line(aes(x,y-f), col = "maroon")+ ylim(-10,10) + theme_bw()
Now we are going to remove and and focus only on what is going on with .
ggplot(xy, aes(x, f)) +
geom_line(linetype=2, col = "gray") +
geom_point(col = "steelblue") +
theme_bw()
Not very interesting since all the are iid.
We can think of the vector as being generated by a Multivariate Normal, with mean zero and covariance matrix: .
The covariance matrix would look like this:
diag(num_sims)[1:5, 1:5]
Let's assume that . This assumption doesn't change anything so far.
But what would happen if were not iid., and their pairwise correlations dependend on the values ?
# First we need some data to use in the explanation
x1 <- matrix(0, nrow = 1, ncol = 1)
x2 <- matrix(seq(- 10, to = 10, length.out = 100), ncol = 1)
k <- rbf_kern(x1, x2, var = 1, lengthscale = 1)
plot_kernel(x1, x2, k)
The plot above is using and . What happens with different values of ?
sigma <- .5
lengthscale <- 1
k <- rbf_kern(x1, x2, var = sigma^2, lengthscale = lengthscale)
plot_kernel(x1, x2, k)
Now different values of .
sigma <- 1
lengthscale <- 3
k <- rbf_kern(x1, x2, var = sigma^2, lengthscale = lengthscale)
plot_kernel(x1, x2, k)
In our initial example, we had these randomly generated errors:
ggplot(xy, aes(x, f)) +
geom_line(linetype=2, col = "gray") +
geom_point(col = "steelblue") +
scale_y_continuous(lim=c(-5,5), name="f") + #In this case we are changing the scale limits
theme_bw()
Think what would happen if instead of a covariance given by , we had a covariance given by the Squared Exponential kernel. How do random realizations of would look like?
x <- as.matrix(seq(-10, 10, len = num_sims), ncol = 1) # These are the inputs of our initial example
# Define the kernel parameters and plot
sigma <- 1
lengthscale <- 1
funk <- function(w) {rbf_kern(w, w, var = sigma^2, lengthscale = lengthscale)}
plot_simulation(x, funk, num_samples = 10)
sigma <- 1
lengthscale <- 2
period <- 1
k <- periodic_kern(x1, x2, var = sigma^2, lengthscale = lengthscale, period = period)
plot_kernel(x1, x2, k)
Let's look at some random realizatios of .
sigma <- 1
lengthscale <- 1
period <- 4
funk <- function(w) {periodic_kern(w, w, var = sigma^2, lengthscale = lengthscale, period = period)}
plot_simulation(x, funk, num_samples = 1)
sigma <- 1
intercept <- .2
slope <- -.1
k <- linear_kern(x1, x2, bias = intercept, var = sigma^2, c = slope)
plot_kernel(x1, x2, k)
sigma <- 1
intercept <- 0
slope <- 0
funk <- function(w) {linear_kern(w, w, bias = intercept, var = sigma^2, c = slope)}
plot_simulation(x, funk, num_samples = 10)
You can find out more about kernels here: http://www.cs.toronto.edu/~duvenaud/cookbook/
This is a class on spatial statistics, so we need to consider at least 2 dimensions.
The kernels we saw before are defined in the same way. The only changes we need are the following:
Consider a grid of points in 2D.
locs1 <- rep(1:20, 20)
x2d <- cbind(locs1, sort(locs1))
ggplot(data.frame(x1 = x2d[,1], x2 = x2d[,2]), aes(x1, x2)) +
geom_point(col = "steelblue") +
theme_bw()
A random realization of under the iid assumption would look like:
sigma <- 1
kern <- iid_kern(x2d, var = sigma^2)
f_rand <- mvrnorm(1, rep(0, nrow(x2d)), kern)
plot_2dsim(x2d, f_rand)
Squared Exponential kernel:
sigma <- 1
lengthscale <- 3
kern <- rbf_kern(x2d, x2d, var = sigma^2, lengthscale = lengthscale)
f_rand <- mvrnorm(1, rep(0, nrow(x2d)), kern)
plot_2dsim(x2d, f_rand)
Periodic kernel:
sigma <- 1
lengthscale <- 2
period <- 50
kern <- periodic_kern(x2d, x2d, var = sigma^2, lengthscale = lengthscale, period = period)
f_rand <- mvrnorm(1, rep(0, nrow(x2d)), kern)
plot_2dsim(x2d, f_rand)
sigma <- 1
intercept <- 1
slope <- c(.5, .1)
kern <- linear_kern(x2d, x2d, bias = intercept, var = sigma^2, c = slope)
f_rand <- mvrnorm(1, rep(0, nrow(x2d)), kern)
plot_2dsim(x2d, f_rand)
Depending on the kernel used (and its parameters) is able to represent different functions across the space.
So far we have only spoken about random realizations of multivariate normals given a kernel, but we haven't actually linked it to an inference method.
Let be a function such that any finite collection of its realizations follows a multivariate Gaussian distribution, with mean and covariance function . Then is known as a Gaussian process.
Say we have some a set of observations and we are interested in knowing which functions are able to represent our observations. We use the following model:
, with .
are never observed. They are latent variables of our model that we need to learn. For every observation , we need to infer the corresponding .
We do this using a Bayesian approach as follows:
As prior we use a multivariate normal with covariance kernel K. The type of kernel depends also on our knowledge or assumptions of the relation between and . Let the mean of our prior be zero, as this simplifies the explication.
Then we have that .
Now if is given, we have that .
And the posterior of becomes:
The proof of this formulation goes beyond the scope of todays discussion, so we will skip it. However you can find out more about the technical details of Gaussian processes here: http://www.gaussianprocess.org/gpml/
The solution of this inference problem is analytically tractable. And this is not only for , but for predictions at new input locations as well. The predictive distribution for is given by:
where and .
Now let's see what this means in terms of the inference process. We will us an exponentiated quadratic kernel for this example.
# This is the dataset we will use
equakes <- read.csv("earthquakes.csv")
equakes
ix <- sample(1:17, 6) # We will just use some observations
ggplot(equakes[ix,], aes(year, all)) +
geom_line(data = equakes, aes(year, all), col = "seagreen2") +
geom_point(col = "steelblue") +
scale_y_continuous(lim=c(800, 2800)) +
scale_x_continuous(lim=c(2000, 2017)) +
theme_bw()
x_ast <- matrix(seq(2000, 2016, length.out = 64), ncol = 1)
x_obs <- matrix(equakes$year[ix], ncol = 1)
y_obs <- matrix(equakes$all[ix], ncol = 1) / 1000
moments <- predictive_rbf(x_obs, y_obs, x_ast, var = 2, lengthscale = 2, noise = .001)
# Generate a number of functions from the process
n_samples <- 100
sims1 <- matrix(rep(0,length(x_ast)*n_samples), ncol = n_samples)
for (i in 1:n_samples) {
sims1[,i] <- mvrnorm(1, moments$pred_mean, moments$pred_var)
}
sims1 <- cbind(x=x_ast,as.data.frame(sims1))
sims1 <- melt(sims1,id = "x")
colnames(sims1)[2] <- "simulation"
ggplot(sims1,aes(x=x,y=value)) +
geom_line(aes(group=simulation), col = "gray", linetype = 1, alpha = .2) +
theme_bw() +
geom_line(data = equakes, aes(year, all/1000), col = "seagreen2") +
geom_point(data = equakes[ix,], aes(year, all / 1000), col = "steelblue") +
scale_y_continuous(lim=c(0.6, 3), name = "thousands of earthquakes") +
scale_x_continuous(lim=c(2000,2017), name = "year")
ix2 <- sample((1:17)[-ix], 1)
x_ast <- matrix(seq(2000, 2016, length.out = 64), ncol = 1)
x_obs <- matrix(equakes$year[c(ix, ix2)], ncol = 1)
y_obs <- matrix(equakes$all[c(ix, ix2)], ncol = 1) / 1000
moments <- predictive_rbf(x_obs, y_obs, x_ast, var = 10, lengthscale = 2, noise = .001)
# Generate a number of functions from the process
n_samples <- 100
sims2 <- matrix(rep(0,length(x_ast)*n_samples), ncol = n_samples)
for (i in 1:n_samples) {
sims2[,i] <- mvrnorm(1, moments$pred_mean, moments$pred_var)
}
sims2 <- cbind(x=x_ast,as.data.frame(sims2))
sims2 <- melt(sims2,id="x")
colnames(sims2)[2] <- "simulation"
ggplot(sims1,aes(x=x,y=value)) +
geom_line(aes(group=simulation), col = "gray", linetype = 1, alpha = .2) +
geom_line(data = sims2, aes(group=simulation), col = "magenta", linetype = 1, alpha = .2) +
theme_bw() +
geom_line(data = equakes, aes(year, all/1000), col = "seagreen2") +
geom_point(data = equakes[ix,], aes(year, all / 1000), col = "steelblue") +
geom_point(data = equakes[ix2,], aes(year, all / 1000), col = "black") +
scale_y_continuous(lim=c(0, 3), name = "thousands of earthquakes") +
scale_x_continuous(lim=c(2000,2017), name = "year")
Things to improve?
We mentioned before that has a Gaussian form. This is the result of it being the product of two Gaussian distributions: and .
If we assume that is not Gaussian (e.g. is positive or discrete), the posterior distribution will no longer be Gaussian. Hence to know of
will require calculating the denominator
which might render intractable.
The Laplace Approximation estimates the posterior distribution with a Gaussian distribution that resembles it the closest.
https://en.wikipedia.org/wiki/Laplace%27s_method
http://www.sumsar.net/blog/2013/11/easy-laplace-approximation/
We can define priors over them:
Although we have a closed analytical expression for computing predictions, one disadvantage of these methods is the computational cost of the algebraic operations where the covariance function is involved.
Both the predictive mean and the predictive covariance, require the computation of the factor:
This is known to have a computational cost of order . Which means a cubic increase in the number of operations needed, related to the number of data points modeled.
In particular, for applications in epidemiology, where we it is needed to make inference on large regions at, but with enough detail at local level, this approach can be infeasible.
In previous sessions, the topic of Gaussian Markov Random Fields (GMRF) has been discussed. GMRF are commonly applied for inference on areal data. The neighboring structure leads to sparse precision matrices, and thus allows computational benefits.
Why?
A continuous field can be represented using a GMRF indexed across space. The countinuous process is replaced by a discrete field using a combination of weights and discrete basis functions :
is found by solving the stocastic partial differential equation (SPDE):
where is the Laplacian, controls the smoothness, is a scale parameter and is a variance rescaling parameter.
The solution to this equation is the a spatial process with Matern covariance:
The core ideas of this approach are:
We will dedicate the rest of the session to show some how to use the INLA package in R to implement geostatistical models. We will just cover some basic steps. A detailed tutorial of R-INLA can be found here: http://www.math.ntnu.no/inla/r-inla.org/tutorials/spde/html/
INLA stands for Integrated Nested Laplace Approximation. The implementation of geostatistical models is done by using the SPDE approximation.
The SPDE representation also makes it possible to use the Integrated Nested Laplace Approximation (INLA) to handle the non-linear transformation on the latent variable. This algorithm computes the posterior marginals of the latent field through a step-wise implementation of a simplified Laplace approximation with a cost of O(n^2 log n).
You can also check these publications:
http://www.statslab.cam.ac.uk/~rjs57/RSS/0708/Rue08.pdf
http://www.maths.ed.ac.uk/~flindgre/rinla/isbaspde.pdf
We will use an example of Malaria prevalence in Burkina Faso. We have data from 109 villages sampled.
obsv_data <- read.table("bf_data/data_bf2_binomial.txt", header = TRUE, sep = ",")
head(obsv_data[,1:4])
ggplot(obsv_data, aes(longitude, latitude)) +
geom_point(aes(col = positives/examined)) +
scale_color_distiller(palette = "Spectral") +
theme_bw()
First we need to define a mesh. A "good" mesh:
options(repr.plot.width=5, repr.plot.height=5) # This will help a better display
mesh1 <- inla.mesh.2d(loc = obsv_data[, c("longitude", "latitude")], max.edge = .5)
plot(mesh1, col = "gray", lw = .2)
points(obsv_data$longitude, obsv_data$latitude, pch = 16, col = "steelblue")
mesh2 <- inla.mesh.2d(loc = obsv_data[, c("longitude", "latitude")], max.edge = c(8, 10))
plot(mesh2, col = "gray", lw = .2)
points(obsv_data$longitude, obsv_data$latitude, pch = 16, col = "steelblue")
mesh3 <- inla.mesh.2d(loc = obsv_data[, c("longitude", "latitude")], max.edge = c(8, 10),
offset = 1.4)
plot(mesh3, col = "gray", lw = .2)
points(obsv_data$longitude, obsv_data$latitude, pch = 16, col = "steelblue")
We define a matern SPDE model based on our mesh with the following:
spde_model <- inla.spde2.matern(mesh = mesh3, alpha = 2)
spde_model$model
spde_model$BLC
Now we define an index on our discretized spatial field.
s_index <- inla.spde.make.index(name = "s.field", n.spde = spde_model$n.spde)
names(s_index)
s_index
We have 109 observation and 734 nodes in our mesh. To project the process at the mesh nodes we use a matrix defined as follows:
print(c("number of data points", nrow(obsv_data)))
print(c("number of nodes", mesh3$n))
# Projector matrix
A_obsv <- inla.spde.make.A(mesh3, as.matrix(obsv_data[, c("longitude", "latitude")]))
print(c("Dimensions of A:", dim(A_obsv)))
INLA provides some functionality ot combine data, effects and projector matrices into a single object. For simple models, this functionality might not be needed, but it becomes handy for more elaborated models.
stack_obsv <- inla.stack(data = list(y = obsv_data$positives),
A = list(A_obsv),
effects = list(s_index),
tag = "obsv")
Our model uses the linear predictor:
The logit transformation will be used by default, when we tell INLA that the model distribution is Binomial. For the moment it suffice to define our linear predictor as follows:
linear_predictor <- y ~ -1 + f(s.field, model = spde_model)
Finally, the model is fitted with the following code:
inla_model <- inla(linear_predictor,
data = inla.stack.data(stack_obsv),
Ntrials = obsv_data$examined,
family = "binomial",
control.predictor = list(A = inla.stack.A(stack_obsv), compute = TRUE),
control.compute = list(dic = TRUE, config = TRUE))
summary(inla_model)
results_df <- data.frame(observed_rate = obsv_data$positives/obsv_data$examined,
fitted_values = inla_model$summary.fitted.values$mean[1:nrow(obsv_data)])
ggplot(results_df, aes(observed_rate, fitted_values)) +
geom_point(col = "steelblue") +
theme_bw()
Our dataset contains some covariates which we can add following the same steps as before.
head(obsv_data)
stack_obsv <- inla.stack(data = list(y = obsv_data$positives),
A = list(A_obsv, 1, 1, 1, 1, 1),
effects = list(s_index,
list(intercept = rep(1, nrow(obsv_data))),
list(alt = obsv_data$alt),
list(temp = obsv_data$temp),
list(rain = obsv_data$rain),
list(ndvi = obsv_data$ndvi)),
tag = "obsv")
linear_predictor <- y ~ -1 + intercept + alt + temp + rain + ndvi + f(s.field, model = spde_model)
inla_model <- inla(linear_predictor,
data = inla.stack.data(stack_obsv),
Ntrials = obsv_data$examined,
family = "binomial",
control.predictor = list(A = inla.stack.A(stack_obsv), compute = TRUE),
control.compute = list(dic = TRUE, config = TRUE))
summary(inla_model)
The usual question here is, "OK, how do I make a map?"
We need to define a grid of points to make predictions. For the points in the grid, we also need the values of the covariates. For this example, we have the needed data stored in another file.
pred_data <- read.table("bf_data//prediction_bf2_binomial.txt", header = TRUE, sep = ",")
head(pred_data)
colnames(pred_data) <- c("longitude", "latitude", "temp", "rain", "ndvi", "alt")
tail(pred_data)
ggplot(pred_data, aes(longitude, latitude)) +
geom_raster(fill = "steelblue") +
theme_bw()
Unlike other models, where we can predict new datapoins once our model has been fitted, INLA needs to fit together the observed points and the points to predict.
We will need a new projector matrix for this dataset, because the grid contains different locations from the observed data. We will also need a data stack.
# Just a part of the country to speed up the live example
pred_data2 <- subset(pred_data, latitude >13)
ggplot(pred_data, aes(longitude, latitude)) +
geom_raster(fill = "steelblue") +
geom_raster(data = pred_data2, fill = "seagreen2") +
theme_bw()
A_pred <- inla.spde.make.A(mesh3, as.matrix(pred_data2[, c("longitude", "latitude")]))
stack_pred <- inla.stack(data = list(y = NA),
A = list(A_pred, 1, 1, 1, 1, 1),
effects = list(s_index,
list(intercept = rep(1, nrow(pred_data2))),
list(alt = pred_data2$alt),
list(temp = pred_data2$temp),
list(rain = pred_data2$rain),
list(ndvi = pred_data2$ndvi)),
tag = "pred")
Here is where the stack utilities become very useful.
stack_both <- inla.stack.join(stack_obsv, stack_pred)
index_obsv <- inla.stack.index(stack_both, tag = "obsv")
index_pred <- inla.stack.index(stack_both, tag = "pred")
inla_model_wp <- inla(linear_predictor,
data = inla.stack.data(stack_both),
Ntrials = c(obsv_data$examined, rep(1, nrow(pred_data2))),
family = "binomial",
control.predictor = list(A = inla.stack.A(stack_both), compute = TRUE),#
control.fixed = list(expand.factor.strategy="inla"))
summary(inla_model_wp)
pred_new <- data.frame(fitted_values = inla_model_wp$summary.fitted.values$mean[index_pred$data])
pred_data2$pred_new <- pred_new
ggplot(pred_data, aes(longitude, latitude)) +
geom_raster(fill = "steelblue") +
geom_raster(data = pred_data2, aes(longitude, latitude, fill = pred_new)) +
scale_fill_distiller(palette = "Spectral") +
geom_point(data = obsv_data, aes(col = positives/examined)) +
scale_color_distiller(palette = "Spectral") +
theme_bw()
# If we have a shapefile of the country
bf_shp <- readShapePoly("BFA_adm_shp/BFA_adm0.shp")
plot(bf_shp)
plot(mesh3, col = "gray", lw = .2)
bf_border <- unionSpatialPolygons(bf_shp, rep(1, nrow(bf_shp)))
bf_segment <- inla.sp2segment(bf_border)
mesh4 <- inla.mesh.2d(loc = obsv_data[, c("longitude", "latitude")],
boundary = bf_segment,
max.edge = c(2, 10), cutoff = .3)
plot(mesh4, col = "gray", lw = .2)
points(obsv_data$longitude, obsv_data$latitude, pch = 16, col = "steelblue")
mesh3$n
mesh4$n
obsv_data2 <- obsv_data
obsv_data2$time <- rep(1:10, 11)[c(-110)]
ggplot(obsv_data2, aes(longitude, latitude)) +
geom_point(aes(col = time)) +
scale_color_distiller(palette = "Spectral") +
theme_bw()
temporal_mesh <- inla.mesh.1d(min(obsv_data2$time):max(obsv_data2$time))
temporal_mesh
s_index <- inla.spde.make.index(name = "s.field", n.spde = spde_model$n.spde,
n.group = temporal_mesh$n)
s_index$s.field.group
linear_predictor <- y ~ -1 + intercept + alt + temp + rain + ndvi +
f(s.field, model = spde_model, group = s.field.group, control.group = list(model = "ar1"))
A_obsv <- inla.spde.make.A(mesh3,
loc = as.matrix(obsv_data2[, c("longitude", "latitude")]),
group = obsv_data2$time,
n.group = temporal_mesh$n)
stack_obsv <- inla.stack(data = list(y = obsv_data2$positives),
A = list(A_obsv, 1, 1, 1, 1, 1),
effects = list(s_index,
list(intercept = rep(1, nrow(obsv_data2))),
list(alt = obsv_data2$alt),
list(temp = obsv_data2$temp),
list(rain = obsv_data2$rain),
list(ndvi = obsv_data2$ndvi)),
tag = "obsv")
inla_model_ar <- inla(linear_predictor,
data = inla.stack.data(stack_obsv),
Ntrials = obsv_data$examined,
family = "binomial",
control.predictor = list(A = inla.stack.A(stack_obsv), compute = TRUE),
control.compute = list(dic = TRUE, config = TRUE))
summary(inla_model_ar)