if (FALSE) {
if (require("fmesher")) {
## Generate mesh and SPDE model
n.lattice <- 20 # increase for more interesting, but slower, examples
x <- seq(from = 0, to = 10, length.out = n.lattice)
lattice <- fm_lattice_2d(x = x, y = x)
mesh <- fm_rcdt_2d_inla(lattice = lattice, extend = FALSE, refine = FALSE)
## Generate an artificial sample
sigma2.e <- 0.1
n.obs <- 1000
obs.loc <- cbind(
runif(n.obs) * diff(range(x)) + min(x),
runif(n.obs) * diff(range(x)) + min(x)
)
Q <- fm_matern_precision(mesh, alpha = 2, rho = 3, sigma = 1)
x <- fm_sample(n = 1, Q = Q)
A <- fm_basis(mesh, loc = obs.loc)
Y <- as.vector(A %*% x + rnorm(n.obs) * sqrt(sigma2.e))
## Calculate posterior
Q.post <- (Q + (t(A) %*% A) / sigma2.e)
mu.post <- as.vector(solve(Q.post, (t(A) %*% Y) / sigma2.e))
## Calculate continuous contours
tric <- tricontour(mesh,
z = mu.post,
levels = as.vector(quantile(x, c(0.25, 0.75)))
)
## Discrete domain contours
map <- contourmap(
n.levels = 2, mu = mu.post, Q = Q.post,
alpha = 0.1, compute = list(F = FALSE), max.threads = 1
)
## Calculate continuous contour map
setsc <- tricontourmap(mesh,
z = mu.post,
levels = as.vector(quantile(x, c(0.25, 0.75)))
)
## Plot the results
reo <- mesh$idx$lattice
idx.setsc <- setdiff(names(setsc$map), "-1")
cols2 <- contourmap.colors(map,
col = heat.colors(100, 0.5, rev = TRUE),
credible.col = grey(0.5, 0)
)
names(cols2) <- as.character(-1:2)
par(mfrow = c(1, 2))
image(matrix(mu.post[reo], n.lattice, n.lattice),
main = "mean", axes = FALSE, asp = 1
)
plot(setsc$map[idx.setsc], col = cols2[idx.setsc])
par(mfrow = c(1, 1))
}
}
Run the code above in your browser using DataLab