if (FALSE) {
library(Matrix)
rmvn <- function(n, mu=0, V = matrix(1)){
p <- length(mu)
if(any(is.na(match(dim(V),p))))
stop("Dimension problem!")
D <- chol(V)
t(matrix(rnorm(n*p), ncol=p)%*%D + rep(mu,rep(n,p)))
}
##Assume both columns of X are space-varying and the two GPs don't covary
set.seed(1)
n <- 200
coords <- cbind(runif(n,0,1), runif(n,0,1))
X <- as.matrix(cbind(1, rnorm(n)))
colnames(X) <- c("x.1", "x.2")
Z <- t(bdiag(as.list(as.data.frame(t(X)))))
B <- as.matrix(c(1,5))
p <- length(B)
sigma.sq <- c(1,5)
tau.sq <- 1
phi <- 3/0.5
D <- as.matrix(dist(coords))
C <- exp(-phi*D)%x%diag(sigma.sq)
w <- rmvn(1, rep(0,p*n), C)
mu <- as.vector(X%*%B + Z%*%w)
y <- rnorm(n, mu, sqrt(tau.sq))
##fit a model to the simulated dat
starting <- list("phi"=rep(3/0.5, p), "sigma.sq"=rep(1, p), "tau.sq"=1)
tuning <- list("phi"=rep(0.1, p), "sigma.sq"=rep(0.1, p), "tau.sq"=0.1)
cov.model <- "exponential"
priors <- list("phi.Unif"=list(rep(3/2, p), rep(3/0.0001, p)),
"sigma.sq.IG"=list(rep(2, p), rep(2, p)),
"tau.sq.IG"=c(2, 1))
##fit model
n.samples <- 2000
m.1 <- spSVC(y~X-1, coords=coords, starting=starting, svc.cols=c(1,2),
tuning=tuning, priors=priors, cov.model=cov.model,
n.samples=n.samples, n.omp.threads=4)
plot(m.1$p.theta.samples, density=FALSE)
##recover posterior samples
m.1 <- spRecover(m.1, start=floor(0.75*n.samples), thin=2, n.omp.threads=4)
summary(m.1$p.beta.recover.samples)
summary(m.1$p.theta.recover.samples)
##check fitted values
quant <- function(x){quantile(x, prob=c(0.025, 0.5, 0.975))}
##fitted y
y.hat <- apply(m.1$p.y.samples, 1, quant)
rng <- c(-15, 20)
plot(y, y.hat[2,], pch=19, cex=0.5, xlab="Fitted y", ylab="Observed y",
xlim=rng, ylim=rng)
arrows(y, y.hat[2,], y, y.hat[1,], angle=90, length=0.05)
arrows(y, y.hat[2,], y, y.hat[3,], angle=90, length=0.05)
lines(rng, rng, col="blue")
##recovered w
w.hat <- apply(m.1$p.w.recover.samples, 1, quant)
w.1.indx <- seq(1, p*n, p)
w.2.indx <- seq(2, p*n, p)
par(mfrow=c(1,2))
rng <- c(-5,5)
plot(w[w.1.indx], w.hat[2,w.1.indx], pch=19, cex=0.5, xlab="Fitted w.1", ylab="Observed w.1",
xlim=rng, ylim=rng)
arrows(w[w.1.indx], w.hat[2,w.1.indx], w[w.1.indx], w.hat[1,w.1.indx], angle=90, length=0.05)
arrows(w[w.1.indx], w.hat[2,w.1.indx], w[w.1.indx], w.hat[3,w.1.indx], angle=90, length=0.05)
lines(rng, rng, col="blue")
rng <- c(-10,10)
plot(w[w.2.indx], w.hat[2,w.2.indx], pch=19, cex=0.5, xlab="Fitted w.2", ylab="Observed w.2",
xlim=rng, ylim=rng)
arrows(w[w.2.indx], w.hat[2,w.2.indx], w[w.2.indx], w.hat[1,w.2.indx], angle=90, length=0.05)
arrows(w[w.2.indx], w.hat[2,w.2.indx], w[w.2.indx], w.hat[3,w.2.indx], angle=90, length=0.05)
lines(rng, rng, col="blue")
}
Run the code above in your browser using DataLab