├── README.md ├── lasso ├── INLA_lasso.R ├── lasso.R ├── lasso.bug └── plots_lasso.R ├── linear ├── INLA-MH-biv.R ├── jags.R └── modelbiv.bug ├── missing ├── INLA-MH-nhanes2.R ├── effssize.R ├── jags.R └── modelmis.bug ├── mixture ├── jags.R ├── mixture.bug ├── oldfaith.R └── results.R ├── poisson ├── INLA-MH-bivpo.R ├── effssize.R ├── jags.R └── modelbiv.bug └── spatialeco ├── INLA-MH-speco.R └── summary-speco.R /README.md: -------------------------------------------------------------------------------- 1 | # INLA within MCMC 2 | 3 | Here I have included the R code used in the examples in paper 'Markov Chain 4 | Monte Carlo with the Integrated Nested Laplace Approximation' by V. Gómez-Rubio 5 | and H. Rue. 6 | 7 | The example are: 8 | 9 | * linear 10 | 11 | Linear regression on two covariates using a Gaussian likelihood and 12 | simulated data. 13 | 14 | * poisson 15 | 16 | Linear regression on two covariates using a Poisson likelihood and 17 | simulated data. 18 | 19 | * lasso 20 | 21 | Bayesian Lasso implementation. 22 | 23 | * missing 24 | 25 | Fitting models with missing covariates with INLA. 26 | 27 | * spatialeco 28 | 29 | Spatial econometrics models with INLA. 30 | 31 | * mixture 32 | 33 | Mixture models with INLA. 34 | -------------------------------------------------------------------------------- /lasso/INLA_lasso.R: -------------------------------------------------------------------------------- 1 | # 2 | #Implementation of Bayesian lasso with R-INLA and MCMC 3 | # 4 | 5 | #Load libraries 6 | library(INLA) 7 | INLA:::inla.dynload.workaround() 8 | 9 | #INLAMH() 10 | library(INLABMA) 11 | 12 | library(ISLR) 13 | library(smoothmest)#Laplace distribution 14 | library(mvtnorm) 15 | 16 | #Fit linear model with R-INLA with a fixed beta 17 | #data: list with 'y'y and 'x' (matrix of covariates, not including intercept) 18 | fit.inla <- function(data, b) { 19 | 20 | data$oset <- data$x %*% matrix(b, ncol = 1) 21 | 22 | res <- inla(y ~ -1 + offset(oset), data = data)#, 23 | # control.inla = list(strategy = "laplace", int.strategy = "ccd", 24 | # dz = .1, restart = 10)) 25 | 26 | res <- inla.rerun(res) #Double-check to get th right mlik 27 | # res <- inla.rerun(res) #Double-check to get th right mlik 28 | 29 | return(list(mlik = res$mlik[1,1], model = res)) 30 | 31 | #Do NOT return the full model 32 | # return(list(mlik = res$mlik[1,1], model = NA)) 33 | } 34 | 35 | #Prior for beta (each one is an independent Laplace distribution) 36 | prior.beta <- function(x, mu = 0, lambda = 0.073, log = TRUE) { 37 | res <- sum(log(ddoublex(x, mu = mu, lambda = lambda))) 38 | 39 | if(!log) { res <- exp(res) } 40 | 41 | return(res) 42 | } 43 | 44 | #Conditional marg-likelihood (?) 45 | cond.mlik <- function(b, data) { 46 | res <- - as.vector(fit.inla(data = data, b = b)$mlik + prior.beta (b, 0, 1/.08)) 47 | 48 | print(c(res, b)) 49 | 50 | return(res) 51 | } 52 | 53 | #Optim using a null starting point 54 | #optim(rep(0, 5), cond.mlik, method = "BFGS", data = d) 55 | 56 | #Optim using the solutio of the lasso 57 | #optim(c(0, 1.818961, 0, 0, 4.052350), cond.mlik, method = "SANN", data = d) 58 | 59 | #Load data 60 | data(Hitters) 61 | Hitters <- na.omit(Hitters) 62 | 63 | #Data 64 | x <- model.matrix(Salary ~ ., Hitters)[, -1] 65 | x <- x[, 1:5] #Just for testing: 1, 3, 4 should have a zero coef. 66 | #x <- scale(x)#glmnet scales 'x' by default 67 | y <- Hitters$Salary 68 | #y <- y/sd(y) #glmnet sets 'y' yo have variance 1 (see manual page) 69 | 70 | #Scale x and y 71 | y <- scale(y) 72 | x <- scale(x) 73 | d <- list(y = y, x = x) 74 | 75 | #Test code 76 | n.beta <- ncol(d$x) 77 | summary( fit.inla(d, b = rep(0, n.beta))$model ) 78 | 79 | #LS estimate 80 | x1 <-cbind(1,x) 81 | ML.betas <- solve(t(x1)%*%x1)%*%t(x1)%*%y 82 | ML.betas 83 | # [,1] 84 | # 164.097257 85 | #AtBat -1.802350 86 | #Hits 6.308997 87 | #HmRun -3.431549 88 | #Runs 2.038504 89 | #RBI 6.745761 90 | #b.sim[1, ] <- as.vector(ML.betas)[-1] 91 | 92 | #lasso estimate 93 | #b.sim[1, ] <- c(0, 1.782466e-01, 0, 0, 2.287608e-01) 94 | 95 | #stdev.samp <- 1 * sqrt(diag(solve(t(x)%*%x))) * 96 | # sd(y - x%*%solve(t(x)%*%x)%*%t(x)%*%y) 97 | stdev.samp <- .25 * solve(t(x)%*%x) 98 | 99 | #Proposal x -> y 100 | #density 101 | #dq.beta <- function(x, y, sigma = .01, log =TRUE) { 102 | dq.beta <- function(x, y, sigma = stdev.samp, log =TRUE) { 103 | #sum(dnorm(y, mean = x, sd = sigma, log = log)) 104 | dmvnorm(y, mean = x, sigma = sigma, log = log) 105 | } 106 | #random 107 | #rq.beta <- function(x, sigma = .01) { 108 | rq.beta <- function(x, sigma = stdev.samp) { 109 | #rnorm(length(x), mean = x, sd = sigma) 110 | as.vector(rmvnorm(1, mean = x, sigma = sigma)) 111 | } 112 | 113 | 114 | 115 | #Run simulations 116 | inlamh.res <- INLAMH(d, fit.inla, rep(0, n.beta), rq.beta, dq.beta, prior.beta, 117 | n.sim = 10000, n.burnin = 500, n.thin = 10, verbose = TRUE) 118 | 119 | #Show results 120 | b.sim <- do.call(rbind, inlamh.res$b.sim) 121 | model.sim <- inlamh.res$model.sim 122 | 123 | save(file = "INLA-lasso.RData", list = ls()) 124 | -------------------------------------------------------------------------------- /lasso/lasso.R: -------------------------------------------------------------------------------- 1 | # 2 | #Example on how to combine MCMC and R-INLA for Bayesian lasso 3 | # 4 | 5 | #Examples taken from http://www-bcf.usc.edu/~gareth/ISL/index.html, Ch. 6 6 | 7 | #Load libraries 8 | library(ISLR) 9 | library(glmnet) 10 | 11 | # 12 | #Load data 13 | # 14 | 15 | data(Hitters) 16 | summary(Hitters) 17 | 18 | #Check NA's and fix 19 | sum(is.na(Hitters$Salary)) 20 | Hitters <- na.omit(Hitters) 21 | 22 | # 23 | # The Lasso 24 | # 25 | 26 | #Create variables for lasso 27 | x <- model.matrix(Salary ~ ., Hitters)[, -1] 28 | x <- x[, 1:5] #Just for testing 29 | x <- scale(x) 30 | y <- Hitters$Salary 31 | y <- scale(y) 32 | 33 | #Indices for train/test model 34 | set.seed(1) 35 | train <- sample(1:nrow(x), nrow(x)/2) 36 | test <- (-train) 37 | 38 | 39 | #Grid for lambda parameter in lasso 40 | grid <- 10^seq(10, -2, length = 100) 41 | 42 | #Fit lasso model for several values of lambda 43 | lasso.mod <- glmnet(x[train, ] , y[train], alpha = 1, lambda = grid) 44 | plot(lasso.mod) 45 | 46 | #CV 47 | set.seed(1) 48 | cv.out <- cv.glmnet(x[train, ], y[train], alpha = 1) 49 | plot(cv.out) 50 | 51 | #Take best lambda for lasso model 52 | bestlam <- cv.out$lambda.min 53 | 54 | #Predcit with lasso on test data 55 | lasso.pred <- predict(lasso.mod, s = bestlam, newx = x[test, ]) 56 | mean((lasso.pred - y[test])^2) 57 | 58 | #Fit model to complete dataset 59 | out <- glmnet(x, y, alpha = 1, lambda = grid) 60 | lasso.coef <- predict(out, type = "coefficients", s = bestlam) 61 | 62 | #Check estimated coefficients 63 | lasso.coef 64 | lasso.coef[lasso.coef != 0] 65 | 66 | #Fitted values 67 | lasso.fitted <- predict(out, s = bestlam, newx = x) 68 | 69 | 70 | 71 | #Fit model with JAGS 72 | library(rjags) 73 | 74 | d.jags <- list(y = as.vector(y), x = x, p = 5, n = nrow(y), 75 | lambda = 1/0.073) 76 | init.jags <- list(tau = 1, b = rep(0, 5)) 77 | 78 | lasso.m <- jags.model("lasso.bug", d.jags) 79 | #Burn-in 80 | jags.samples(lasso.m, c("b", "tau"), 500) 81 | #Samples 82 | smp.jags <- jags.samples(lasso.m, c("b", "tau"), 83 | n.iter = 100000, thin = 10) 84 | smp.jags 85 | 86 | apply(smp.jags$b[,,1], 1, quantile) 87 | 88 | lasso.coef 89 | 90 | 91 | save(file = "lasso.RData", list = ls()) 92 | 93 | 94 | -------------------------------------------------------------------------------- /lasso/lasso.bug: -------------------------------------------------------------------------------- 1 | model { 2 | 3 | for(i in 1:n) { 4 | y[i] ~ dnorm(mu[i], tau) 5 | mu[i] <- inprod(x[i, ], b[]) 6 | } 7 | 8 | tt <- lambda 9 | for(j in 1:p) { 10 | b[j] ~ ddexp(0, tt) 11 | } 12 | 13 | tau ~ dgamma(1, 0.00005) 14 | 15 | } 16 | -------------------------------------------------------------------------------- /lasso/plots_lasso.R: -------------------------------------------------------------------------------- 1 | # 2 | #Load data and plot 3 | # 4 | 5 | 6 | library(INLA) 7 | library(rjags) 8 | library(glmnet) 9 | 10 | 11 | #Load data 12 | load("lasso.RData") 13 | load("INLA-lasso.RData") 14 | 15 | 16 | #Summary stats for coefficients 17 | apply(b.sim, 2, mean) 18 | apply(b.sim, 2, sd) 19 | 20 | 21 | #Plot with different estimates 22 | pdf(file = "lasso.pdf") 23 | 24 | #Bandwidths 25 | bws <- c(0.01, 0.05, 0.01, 0.02, 0.03) 26 | 27 | pos <- rep("topleft", 5) 28 | pos[2] <- "topright" 29 | pos[4] <- "topright" 30 | pos[5] <- "topright" 31 | 32 | par(mfrow = c(3, 2)) 33 | for(i in 1:5) { 34 | #INLA-MCMC estimates 35 | plot(density(b.sim[, i], bw = bws[i]), main = colnames(x)[i], xlab = "") 36 | #MCMC estimates 37 | lines(density(smp.jags$b[i, , ], bw = bws[i]), lty = 2) 38 | #Lasso estimates 39 | abline(v = (as.vector(lasso.coef)[-1])[i], lty = 3) 40 | 41 | legend(pos[i], lty = 1:3, bty = "n", 42 | legend = c("INLA w/ MCMC", "MCMC", "Lasso")) 43 | } 44 | 45 | ##INLA-MCMC 46 | #plot(density(1/smp.jags$tau[, , 1]), type = "n", main = "Residual variance") 47 | ##MCMC estimates 48 | #lines(density(1/smp.jags$tau[, , 1])) 49 | ##Lasso estimates (??) 50 | #abline(v = var(y - lasso.fitted), lty = 2) 51 | #legend("topleft", lty = c(1, 1, 2), bty = "n", 52 | # legend = c("INLA", "MCMC", "Lasso"), col = c("red", "black", "black")) 53 | # 54 | dev.off() 55 | 56 | 57 | -------------------------------------------------------------------------------- /linear/INLA-MH-biv.R: -------------------------------------------------------------------------------- 1 | #Implementation of INLA within M-H for Bayesian Inference 2 | #Bivariate inference 3 | 4 | #Load libraries 5 | library(INLA) 6 | #INLA:::inla.dynload.workaround() 7 | 8 | #INLAMH() 9 | library(INLABMA) 10 | 11 | 12 | #Simulate data 13 | n <- 100 14 | set.seed(123) 15 | x1 <- runif(n) 16 | x2 <- runif(n) 17 | err <- rnorm(n) 18 | y <- 3 + 2*x1-2*x2+err 19 | 20 | d <- data.frame(y = y, x1 = x1, x2 = x2) 21 | 22 | save(file="databiv.RData", list = c("d")) 23 | 24 | #INLA models 25 | m1 <- inla(y ~ 1+x1+x2, data = d) 26 | 27 | #Fit linear model with R-INLA with a fixed beta 28 | #b Vector of length 2 29 | fit.inla <- function(data, b) { 30 | 31 | data$oset <- b[1] * data$x1 +b[2]*data$x2 32 | 33 | res <- inla(y ~1+offset(oset), data = data) 34 | 35 | return(list(mlik = res$mlik[1,1], model = res)) 36 | } 37 | 38 | #Test model fitting 39 | fit.inla(d, c(1,1)) 40 | 41 | 42 | #Proposal x -> y 43 | #density 44 | dq.beta <- function(x, y, sigma = .75, log =TRUE) { 45 | sum(dnorm(y, mean = x, sd = sigma, log = log)) 46 | } 47 | #random 48 | rq.beta <- function(x, sigma = .75) { 49 | rnorm(length(x), mean = x, sd = sigma) 50 | } 51 | 52 | #Prior for beta 53 | prior.beta <- function(x, sigma = sqrt(1/.001), log = TRUE) { 54 | sum(dnorm(x, mean = 0, sd= sigma, log = log)) 55 | } 56 | 57 | 58 | #Run simulations 59 | inlamh.res <- INLAMH(d, fit.inla, c(0, 0), rq.beta, dq.beta, prior.beta, 60 | n.sim = 10000, n.burnin = 500, n.thin = 10) 61 | 62 | 63 | #Show results 64 | b.sim <- do.call(rbind, inlamh.res$b.sim) 65 | model.sim <- inlamh.res$model.sim 66 | 67 | save(file = "INLA-MHbiv.RData", list = ls()) 68 | 69 | #Load JAGS results 70 | # 71 | #Run source("jags.R", echo = TRUE) first... 72 | # 73 | library(rjags) 74 | load("jags.RData") 75 | 76 | #Compute conturs 77 | library(MASS) 78 | z.inla <- kde2d(b.sim[, 1], b.sim[, 2]) 79 | z.mcmc <- kde2d(jm2.samp$beta1[1, , ], jm2.samp$beta2[1, , ]) 80 | 81 | 82 | pdf(file = "INLA-MHbiv.pdf", width = 10, height = 5) 83 | par(mfrow = c(1, 3)) 84 | plot(b.sim) 85 | #abline(h = 2, col = "red") 86 | 87 | #Density beta1 88 | plot(density(b.sim[, 1])) 89 | lines(m1$marginals.fixed[[2]], col ="red") 90 | legend("topleft", lty = 1, legend = c("INLA", "MCMC"), col = c("red", "black")) 91 | 92 | #Density beta2 93 | plot(density(b.sim[, 2])) 94 | lines(m1$marginals.fixed[[3]], col ="red") 95 | legend("topleft", lty = 1, legend = c("INLA", "MCMC"), col = c("red", "black")) 96 | 97 | dev.off() 98 | 99 | 100 | print(c("Acceptance rate:", mean(inlamh.res$acc.sim))) 101 | 102 | #Summary statistics 103 | print("Summary statistics of beta:") 104 | c(mean(b.sim[, 1]), sd(b.sim[, 1]), quantile(b.sim[, 1], c(0.025, .5, .975)) ) 105 | c(mean(b.sim[, 2]), sd(b.sim[, 2]), quantile(b.sim[, 2], c(0.025, .5, .975)) ) 106 | m1$summary.fixed[-1,] 107 | 108 | #We need to add the prior of the paramaters 109 | mliks <- sapply(model.sim, function(X){ X$mlik }) 110 | mliks <- mliks + sapply(b.sim, prior.beta) 111 | 112 | probs <- exp(mliks - min(mliks)) 113 | probs <- probs / sum(probs) 114 | 115 | 116 | save(file = "INLA-MHbiv.RData", list = ls()) 117 | 118 | #BMA models 119 | library(INLABMA) 120 | 121 | #bma.model <- INLABMA(model.sim[-(1:n.burnin)], 1:(n.sim-n.burnin)) 122 | 123 | models <- lapply(model.sim, function(X){X$model}) 124 | ws <- rep(1/length(models), length(models)) 125 | 126 | listmarg <- c("marginals.fixed", "marginals.hyperpar") 127 | margeff <- mclapply(listmarg, function(X) { 128 | INLABMA:::fitmargBMA2(models, ws, X) 129 | }) 130 | 131 | 132 | #Bandwidth for densities 133 | bandw <- 0.08 134 | 135 | pdf(file = "INLA-MHbiv2.pdf", width = 7.5, height = 7.5) 136 | par(plt = c(.15, .95, .15, .9)) 137 | par(mfcol = c(2,3)) 138 | #Contour plots: INLA+MCMC 139 | #plot(b.sim[idx,], xlab = "", ylab = "", main = "Markov Chain") 140 | contour(z.inla, lty = 1, xlab = expression(beta[1]), ylab = expression(beta[2])) 141 | points(c(2, -2), col = "black", pch = 4, cex = 2, lwd = 3) 142 | 143 | legend("topright", lty = 1:2, legend = c("INLA+MCMC", "MCMC"), 144 | bty = "n", cex = .8) 145 | legend("right", pch = 4, legend = "Value", bty = "n", cex = 0.8) 146 | 147 | #Contour plot: MCMC 148 | contour(z.mcmc, lty = 2, xlab = expression(beta[1]), ylab = expression(beta[2])) 149 | 150 | points(c(2, -2), col = "black", pch = 4, cex = 2, lwd = 3) 151 | 152 | legend("topright", lty = 1:2, legend = c("INLA+MCMC", "MCMC"), 153 | bty = "n", cex = .8) 154 | legend("right", pch = 4, legend = "Value", bty = "n", cex = 0.8) 155 | 156 | #Density beta1 157 | plot(density(b.sim[, 1], bw = bandw), main = expression(beta[1]), 158 | xlab = "") 159 | lines(m1$marginals.fixed[[2]], lty = 2) 160 | #JAGS 161 | lines(density(jm2.samp$beta1[1,,], bw = bandw), lty = 3) 162 | 163 | legend("topright", lty = 1:3, legend = c("INLA+MCMC", "INLA", "MCMC"), 164 | bty = "n", cex = .8) 165 | 166 | #Density beta2 167 | plot(density(b.sim[, 2], bw = bandw), main = expression(beta[2]), 168 | xlab = "") 169 | lines(m1$marginals.fixed[[3]], lty = 2) 170 | #JAGS 171 | lines(density(jm2.samp$beta2[1, , ], bw = bandw), lty = 3) 172 | 173 | legend("topright", lty = 1:3, legend = c("INLA+MCMC", "INLA", "MCMC"), 174 | bty = "n", cex = .8) 175 | 176 | #Fixed effects 177 | plot(margeff[[1]][[1]], type = "l", xlab ="", ylab = "", main = expression(alpha)) 178 | lines(m1$marginals.fixed[[1]], lty = 2) 179 | #JAGS 180 | lines(density(jm2.samp$alpha[1,,], bw = 0.06), lty = 3) 181 | 182 | legend("topright", lty = 1:3, legend = c("INLA+MCMC", "INLA", "MCMC"), bty = "n", cex = .8) 183 | 184 | #Hyperparameters 185 | plot(margeff[[2]][[1]], type = "l", xlab ="", ylab = "", main = expression(tau)) 186 | lines(m1$marginals.hyper[[1]], lty = 2) 187 | #JAGS 188 | lines(density(jm2.samp$prec[1,,], bw = 0.02), lty = 3) 189 | 190 | legend("topright", lty = 1:3, legend = c("INLA+MCMC", "INLA", "MCMC"), 191 | bty = "n", cex = .8) 192 | 193 | 194 | dev.off() 195 | -------------------------------------------------------------------------------- /linear/jags.R: -------------------------------------------------------------------------------- 1 | #Run mdoels with JAGS 2 | library(rjags) 3 | 4 | #Load data 5 | #y <- 3 + 2*x+err 6 | #err <- rnorm(n) 7 | load("data.RData") 8 | 9 | d <- as.list(d) 10 | 11 | d$N <- length(d$y) 12 | 13 | #1 COVARIATE DATA 14 | jm1 <- jags.model('model.bug', 15 | data = d, 16 | n.chains = 1, 17 | n.adapt = 100) 18 | 19 | update(jm1, 500) 20 | 21 | jm1.samp <- jags.samples(jm1, 22 | c('alpha', 'beta', 'prec', 'mu'), 23 | n.iter = 100000, thin = 10) 24 | 25 | print(jm1.samp) 26 | 27 | 28 | #TWO COVARIATES DATA 29 | #y <- 3 + 2*x1-2*x2+err 30 | #err <- rnorm(n) 31 | load("databiv.RData") 32 | 33 | d <- as.list(d) 34 | d$N <- length(d$y) 35 | 36 | jm2 <- jags.model('modelbiv.bug', 37 | data = d, 38 | n.chains = 1, 39 | n.adapt = 100) 40 | 41 | update(jm2, 500) 42 | 43 | jm2.samp <- jags.samples(jm2, 44 | c('alpha', 'beta1', 'beta2', 'prec', 'mu'), 45 | n.iter = 100000, thin = 10) 46 | 47 | print(jm2.samp) 48 | 49 | 50 | save(file = "jags.RData", list = c("jm1.samp", "jm2.samp")) 51 | 52 | 53 | -------------------------------------------------------------------------------- /linear/modelbiv.bug: -------------------------------------------------------------------------------- 1 | model { 2 | 3 | for(i in 1:N) { 4 | y[i] ~ dnorm(mu[i], prec) 5 | mu[i] <- alpha + beta1 * x1[i] + beta2 * x2[i] 6 | } 7 | 8 | alpha ~ dunif(-1000, 1000) 9 | beta1 ~ dnorm(0, .001) 10 | beta2 ~ dnorm(0, .001) 11 | prec ~ dgamma(1, 0.00005) 12 | 13 | } 14 | -------------------------------------------------------------------------------- /missing/INLA-MH-nhanes2.R: -------------------------------------------------------------------------------- 1 | #Implementation of INLA within M-H for Bayesian Inference 2 | #Sampling of missing covariates 3 | 4 | library(mice) 5 | data(nhanes2) 6 | 7 | 8 | #Load libraries 9 | library(INLA) 10 | # INLA:::inla.dynload.workaround() 11 | #INLAMH() 12 | library(INLABMA) 13 | 14 | #INLA models 15 | m1 <- inla(chl ~ 1 + bmi + age, data = nhanes2) 16 | 17 | #Generic variables for model fitting 18 | d.mis <- nhanes2 19 | idx.mis <- which(is.na(d.mis$bmi)) 20 | n.mis <- length(idx.mis) 21 | 22 | save(file = "nhanes2.RData", list = c("nhanes2", "d.mis")) 23 | 24 | 25 | #Fit linear model with R-INLA with a fixed beta 26 | fit.inla <- function(data, x.mis) { #, idx.mis) { 27 | 28 | data$bmi[idx.mis] <- x.mis 29 | 30 | res <- inla(chl ~ 1 + bmi + age, data = data) 31 | 32 | return(list(mlik = res$mlik[1,1], model = res)) 33 | } 34 | 35 | 36 | #Proposal x -> y 37 | #density 38 | dq.beta <- function(x, y, sigma = sqrt(10), log =TRUE) { 39 | res <- dnorm(y, mean = x, sd = sigma, log = log) 40 | 41 | if(log) { 42 | return(sum(res)) 43 | } else { 44 | return(prod(res)) 45 | } 46 | 47 | 48 | } 49 | #random 50 | rq.beta <- function(x, sigma = sqrt(10) ) { 51 | rnorm(length(x), mean = x, sd = sigma) 52 | } 53 | 54 | #Prior for beta 55 | prior.beta <- function(x, mu = mean(d.mis$bmi, na.rm = TRUE), 56 | sigma = 2*sd(d.mis$bmi, na.rm = TRUE), log = TRUE) { 57 | res <- dnorm(x, mean = mu, sd= sigma, log = log) 58 | 59 | if(log) { 60 | return(sum(res)) 61 | } else { 62 | return(prod(res)) 63 | } 64 | } 65 | 66 | 67 | 68 | #Run simulations 69 | inlamh.res <- INLAMH(d.mis, fit.inla, rep(mean(d.mis$bmi, na.rm = TRUE), n.mis), 70 | rq.beta, dq.beta, prior.beta, 71 | n.sim = 10000, n.burnin = 500, n.thin = 10) 72 | 73 | #Show results 74 | x.sim <- do.call(rbind, inlamh.res$b.sim) 75 | model.sim <- inlamh.res$model.sim 76 | 77 | save(file = "INLA-MH-nhanes2.RData", list = ls()) 78 | 79 | 80 | #Load JAGS results 81 | # 82 | #Run source("jags.R", echo = TRUE) to get jags.RData 83 | # 84 | library(rjags) 85 | load("jags.RData") 86 | 87 | #Summary jags 88 | mean(jm1.samp$alpha); sd(jm1.samp$alpha) 89 | mean(jm1.samp$beta); sd(jm1.samp$beta) 90 | mean(jm1.samp$b.age2); sd(jm1.samp$b.age2) 91 | mean(jm1.samp$b.age3); sd(jm1.samp$b.age3) 92 | mean(jm1.samp$prec); sd(jm1.samp$prec) 93 | 94 | #This some of the observations 95 | # x.sim <- x.sim[1:8646, ]; model.sim <- model.sim[1:8646] 96 | 97 | pdf(file = "INLA-MH-missing.pdf", width = 10, height = 10) 98 | par(mfrow = c(3,3)) 99 | 100 | for(i in 1:n.mis) { 101 | plot(x.sim[,i], type = "l", main = idx.mis[i]) 102 | #JAGS 103 | lines(jm1.samp$bmi[idx.mis[i],,], col ="blue") 104 | } 105 | dev.off() 106 | 107 | 108 | #Density 109 | pdf(file = "INLA-MH-missing-dens.pdf", width = 10, height = 10) 110 | par(mfrow = c(3,3)) 111 | 112 | for(i in 1:n.mis) { 113 | plot(density(x.sim[,i], bw = 1.75), type = "l", 114 | main = paste0("Observation ", idx.mis[i]), lty = 1, 115 | xlab = "") 116 | #JAGS 117 | lines(density(jm1.samp$bmi[idx.mis[i],,], bw = 1.75), col ="black", lty = 2) 118 | 119 | legend("topleft", lty = 1:2, legend = c("INLA within MCMC", "MCMC"), 120 | col = c("black", "black"), cex = .8, bty = "n") 121 | } 122 | 123 | dev.off() 124 | 125 | 126 | print(c("Acceptance rate:", mean(inlamh.res$acc.sim))) 127 | 128 | 129 | #Summary statistics 130 | #print("Summary statistics of beta:") 131 | #c(mean(b.sim[idx]), sd(b.sim[idx]), quantile(b.sim[idx], c(0.025, .5, .975)) ) 132 | #m1$summary.fixed[2,] 133 | 134 | #We need to add the prior of the paramaters 135 | mliks <- sapply(model.sim, function(X){ X$mlik}) 136 | mliks <- mliks + apply(x.sim, 1, prior.beta) 137 | 138 | probs <- exp(mliks - min(mliks)) 139 | probs <- probs/sum(probs) 140 | 141 | #BMA models 142 | library(INLABMA) 143 | l.models <- lapply(model.sim, function(X){ X$model}) 144 | #m.final <- INLABMA(l.models, length(l.models), 0) 145 | 146 | #Fixed effects 147 | n.sim <- length(l.models) 148 | ws <- rep(1/n.sim, n.sim) 149 | INLABMA:::fitmatrixBMA(l.models, ws, "summary.fixed") 150 | #> INLABMA:::fitmatrixBMA(l.models, ws, "summary.fixed") 151 | # mean sd 0.025quant 0.5quant 0.975quant mode 152 | #(Intercept) 43.471216 56.853046 -63.2769647 41.297175 162.666847 37.351921 153 | #bmi 4.864194 2.007569 0.6950043 4.924653 8.686571 5.032377 154 | #age40-59 29.500952 17.396997 -6.9732350 30.253022 61.739292 31.721176 155 | #age60-99 49.448805 20.980671 5.1430652 50.527989 87.752216 52.721400 156 | # kld 157 | #(Intercept) 4.211303e-11 158 | #bmi 2.744941e-11 159 | #age40-59 5.957370e-11 160 | #age60-99 3.403575e-11 161 | 162 | #Hyperparameters 163 | INLABMA:::fitmatrixBMA(l.models, ws, "summary.hyperpar") 164 | #> INLABMA:::fitmatrixBMA(l.models, ws, "summary.hyperpar") 165 | # mean sd 0.025quant 166 | #Precision for the Gaussian observations 0.00108211 0.002121901 0.0004104344 167 | # 0.5quant 0.975quant mode 168 | #Precision for the Gaussian observations 0.001005999 0.002113539 0.0008709942 169 | 170 | #Marginals of fitted values 171 | marg.fixed <- INLABMA:::fitmargBMA2(l.models, ws, "marginals.fixed") 172 | 173 | 174 | warning("Here constaint to the interval 0.005 using debug().") 175 | marg.hyperpar <- INLABMA:::fitmargBMA2(l.models, ws, "marginals.hyperpar") 176 | 177 | 178 | #Summary statistics using inla.zmarginal 179 | do.call(rbind, lapply(c(marg.fixed, marg.hyperpar), inla.zmarginal)) 180 | 181 | #Diplay fitted 182 | pdf(file = "post_param.pdf", width = 7.5, height = 5) 183 | 184 | par(mfrow = c(2, 3)) 185 | par(plt = c(.1, .95, .15, .85)) 186 | 187 | 188 | plot(marg.fixed[[1]], type = "l", main = expression(beta[0]), xlab = "") 189 | lines(density(jm1.samp$alpha), lty = 2) 190 | legend("topleft", legend = c("INLAMCMC", "MCMC"), lty = 1:2, bty = "n", 191 | cex = .7) 192 | 193 | plot(marg.fixed[[2]], type = "l", main = expression(beta[1]), xlab = "") 194 | lines(density(jm1.samp$beta), lty = 2) 195 | legend("topleft", legend = c("INLAMCMC", "MCMC"), lty = 1:2, bty = "n", 196 | cex = .7) 197 | 198 | plot(marg.fixed[[3]], type = "l", main = expression(beta[2]), xlab = "") 199 | lines(density(jm1.samp$b.age2), lty = 2) 200 | legend("topleft", legend = c("INLAMCMC", "MCMC"), lty = 1:2, bty = "n", 201 | cex = .7) 202 | 203 | plot(marg.fixed[[4]], type = "l", main = expression(beta[3]), xlab = "") 204 | lines(density(jm1.samp$b.age3), lty = 2) 205 | legend("topleft", legend = c("INLAMCMC", "MCMC"), lty = 1:2, bty = "n", 206 | cex = .7) 207 | 208 | plot(marg.hyperpar[[1]], type = "l", main = expression(tau), 209 | xlim = c(0, .004), xlab = "" ) 210 | lines(density(jm1.samp$prec), lty = 2) 211 | legend("topright", legend = c("INLAMCMC", "MCMC"), lty = 1:2, bty = "n", 212 | cex = .7) 213 | dev.off() 214 | 215 | 216 | save(file = "INLA-MH-nhanes2.RData", list = ls()) 217 | -------------------------------------------------------------------------------- /missing/effssize.R: -------------------------------------------------------------------------------- 1 | #Test effective sample size 2 | 3 | library(INLA) 4 | library(rjags) 5 | library(coda) 6 | 7 | #Load data 8 | load("INLA-MH-missing.RData") 9 | load("jags.RData") 10 | 11 | 12 | #Create mcmc object from INLA+MCMC 13 | b.sim.mcmc <- as.mcmc(x.sim) 14 | 15 | #Compute eff. s.size for different number of iterations 16 | n.iter <- seq(100, 10000, by = 100) 17 | 18 | #INLA+MCMC 19 | #samples: mcmc object 20 | 21 | get.ess <- function(samples) { 22 | unlist(lapply(n.iter, function(X) { 23 | min(effectiveSize(samples[1:X, ])) 24 | })) 25 | } 26 | 27 | effsize.inlamcmc <- get.ess(b.sim.mcmc) 28 | 29 | #JAGS 30 | jags.mcmc <- as.mcmc(t(jm1.samp$x[idx.mis,,])) 31 | 32 | effsize.jags <- get.ess(jags.mcmc) 33 | 34 | 35 | #Display results 36 | pdf(file = "effssize-missing.pdf") 37 | 38 | plot(n.iter, effsize.inlamcmc, type = "l", 39 | xlab = "Number of iterations", 40 | ylab = "Effective sample size", 41 | main = "Minimum effective sample size (linear regression)") 42 | lines(n.iter, effsize.jags, lty = 2) 43 | 44 | legend("topleft", legend = c("INLA within MCMC", "MCMC"), 45 | lty = 1:2, bty = "n") 46 | 47 | dev.off() 48 | 49 | -------------------------------------------------------------------------------- /missing/jags.R: -------------------------------------------------------------------------------- 1 | #Run mdoels with JAGS 2 | library(rjags) 3 | 4 | #Load data 5 | #y <- 3 + 2*x+err 6 | #err <- rnorm(n) 7 | load("data.RData") 8 | 9 | d.mis <- as.list(d.mis) 10 | 11 | #Age as categorical 12 | d.mis$agecat <- model.matrix (~ -1 + age, data = data.frame(age = d.mis$age)) 13 | 14 | d.mis$N <- length(d.mis$chl) 15 | 16 | d.mis$idx.mis <- which(is.na(d.mis$bmi)) 17 | d.mis$n.mis <- length(d.mis$idx.mis) 18 | 19 | #Mean and precision for prior on the missing values 20 | d.mis$mean.mis <- mean(d.mis$bmi, na.rm = TRUE) 21 | d.mis$prec.mis <- 1/(4*var(d.mis$bmi, na.rm = TRUE))#2 times the s.d. 22 | 23 | #MISSING VALUES MODEL 24 | jm1 <- jags.model('modelmis.bug', 25 | data = d.mis, 26 | n.chains = 1, 27 | n.adapt = 100) 28 | 29 | update(jm1, 500) 30 | 31 | jm1.samp <- jags.samples(jm1, 32 | c('alpha', 'beta', 'b.age2', 'b.age3', 'prec', 'mu', 'bmi', 'chl'), 33 | n.iter = 100000, thin = 10) 34 | 35 | print(jm1.samp) 36 | 37 | save(file = "jags.RData", list = c("jm1.samp")) 38 | 39 | -------------------------------------------------------------------------------- /missing/modelmis.bug: -------------------------------------------------------------------------------- 1 | model { 2 | 3 | for(i in 1:N) { 4 | chl[i] ~ dnorm(mu[i], prec) 5 | mu[i] <- alpha + beta * bmi[i] + b.age2 * agecat[i, 2] + b.age3 * agecat[i, 3] 6 | } 7 | 8 | for(j in 1:n.mis) { 9 | bmi[idx.mis[j]] ~ dnorm(mean.mis, prec.mis) 10 | } 11 | 12 | alpha ~ dunif(-1000, 1000) 13 | beta ~ dnorm(0, .001) 14 | b.age2 ~ dnorm(0, .001) 15 | b.age3 ~ dnorm(0, .001) 16 | prec ~ dgamma(1, 0.00005) 17 | 18 | } 19 | -------------------------------------------------------------------------------- /mixture/jags.R: -------------------------------------------------------------------------------- 1 | ## Example: Classification with INLA within MCMC 2 | 3 | library(MASS)#For 'geyser' dataset 4 | library(MCMCpack)#For dirichlet distribution 5 | library(INLA) 6 | library(INLABMA) 7 | library(parallel) 8 | options(mc.cores = 2) 9 | library(rjags) 10 | 11 | 12 | #Get data 13 | yy <- faithful$eruptions 14 | 15 | #Number of data 16 | n <- length(yy) 17 | 18 | n.grp <- 2 19 | 20 | #Create jags data 21 | jags.data <- list(y = yy, N = length(yy), 22 | K = n.grp, alpha = rep(1, n.grp), 23 | mean.grp = c(2, 4.5), prec.grp = c(1, 1), 24 | gamma.a = 1, gamma.b = 5e-05) 25 | 26 | 27 | #Initial grouping 28 | grp <- rep(2, n) 29 | grp[order(yy)[1:floor(n/3)]] <- 1 30 | 31 | jags.inits <- list(Z = grp, #Z = sample(1:n.grp, jags.data$N, TRUE), 32 | mu.orig = seq(min(jags.data$y), max(jags.data$y), length.out = n.grp) 33 | #, sigma = rep(1, n.grp) 34 | ) 35 | 36 | # This model uses Gamma priors on the precisions and 37 | # the results match thoser obtained with INLA 38 | m.jags <- jags.model("mixture.bug", jags.data, jags.inits) 39 | update(m.jags, 200) 40 | res.jags <- jags.samples(m.jags, c("mu", "prec", "Z", "w"), 41 | n.iter = 10000, thin = 10 ) 42 | 43 | res.jags 44 | 45 | save(file = paste0("jags-gaussian-ngrp-", n.grp, ".RData"), list = ls()) 46 | -------------------------------------------------------------------------------- /mixture/mixture.bug: -------------------------------------------------------------------------------- 1 | model { 2 | 3 | #Observations 4 | for(i in 1:N) { 5 | y[i] ~ dnorm(mu[Z[i]], prec[Z[i]]) 6 | } 7 | 8 | #Components 9 | #Mu[i] re-ordered mean of group 10 | for(k in 1:K) { 11 | #sigma[k] ~ dunif(s.min, s.max) 12 | mu.orig[k] ~ dnorm (mean.grp[k], prec.grp[k])#I(0, 10) 13 | prec.orig[k] ~ dgamma(gamma.a, gamma.b) #<- 1/(sigma[k] * sigma[k]) 14 | } 15 | 16 | grp.rank <- order(mu.orig[])#JAGS specific 17 | for(k in 1:K) { 18 | mu[k] <- mu.orig[grp.rank[k]] 19 | prec[k] <- prec.orig[grp.rank[k]] 20 | } 21 | 22 | #Distribution of Z 23 | for(i in 1:N) { 24 | Z[i] ~ dcat (w[]) 25 | } 26 | 27 | #Prior on the proportion of observations in each group 28 | w[1:K] ~ ddirch(alpha[]) 29 | } 30 | 31 | -------------------------------------------------------------------------------- /mixture/oldfaith.R: -------------------------------------------------------------------------------- 1 | ## Example: Classification with INLA within MCMC 2 | 3 | library(MASS)#For 'geyser' dataset 4 | library(MCMCpack)#For dirichlet distribution 5 | library(INLA) 6 | INLA:::inla.dynload.workaround() 7 | 8 | library(INLABMA) 9 | library(parallel) 10 | options(mc.cores = 2) 11 | 12 | 13 | #Get data 14 | yy <- faithful$eruptions 15 | 16 | #Number of data 17 | n <- length(yy) 18 | 19 | #PLot density 20 | pdf(file = "geyser.pdf", width = 10, height = 5) 21 | par(mfrow = c(1, 2)) 22 | 23 | plot(faithful$eruptions, faithful$waiting, 24 | xlab = "Eruption time", ylab = "Waiting time", pch = 19) 25 | plot(density(yy), xlab = "Eruption time", main = "") 26 | dev.off() 27 | 28 | ## Initial split 29 | 30 | #Number of groups 31 | n.grp <- 2 32 | 33 | # Using 3 as a cut-off point 34 | #grp <- 1 + (yy >=3) 35 | 36 | # 50-50 random assignment 37 | #grp <- sample(rep(1:n.grp, length.out = n)) 38 | 39 | #1/3, 2/3's at random 40 | #grp <- sample(1:2, n, rep = TRUE, prob = c(1/3, 2/3)) 41 | #Grouping using values 42 | #grp <- 1 + as.integer(yy > 3) 43 | 44 | #1/3, 2/3's in increasing order 45 | grp <- rep(2, n) 46 | grp[order(yy)[1:floor(n/3)]] <- 1 47 | 48 | 49 | #The sampled values takes two parameters: 50 | #z: the sampled index 51 | #m: The fitted model 52 | 53 | fit.inla <- function(yy, grp) { 54 | return(grp$m) 55 | } 56 | 57 | fit.inla.internal <- function(yy, grp) { 58 | 59 | #Data in two-column format 60 | y <- matrix(NA, ncol = n.grp, nrow = n) 61 | for(i in 1:n.grp) { 62 | idx <- which(grp == i) 63 | y[idx, i] <- yy[idx] 64 | } 65 | 66 | #X stores the intercept in the model 67 | x <- y 68 | x[!is.na(x)] <- 1 69 | 70 | d <- list(y = y, x = x) 71 | 72 | #Initial group 73 | m1 <- inla(y ~ -1 + x, data = d, 74 | family = rep("gaussian", n.grp), 75 | control.fixed = list(mean = list(x1 = 2, x2 = 4.5), prec = 1) 76 | ) 77 | 78 | 79 | res<- list(model = m1, mlik = m1$mlik[1, 1]) 80 | return(res) 81 | } 82 | 83 | 84 | #Completely at random 85 | #x --> y 86 | dq.z <- function(x, y, log = TRUE) { 87 | res <- log(0.5) * length(x) 88 | if(log) { 89 | return(res) 90 | } 91 | else { 92 | return(exp(res)) 93 | } 94 | } 95 | 96 | rq.z <- function(z) { 97 | return(sample(1:n.grp, length(z), rep = TRUE)) 98 | } 99 | 100 | #Probabilities of belonging to each group 101 | get.probs <- function(z) { 102 | probs <- rep(0, n.grp) 103 | tab <- table(z) #+ 1 #Dirichlet prior 104 | probs[as.integer(names(tab))] <- tab/sum(tab) 105 | return(probs) 106 | } 107 | 108 | #Using means of conditional marginals 109 | #FIXME: We do not consider possble label switching here 110 | dq.z <- function(x, y, log = TRUE) { 111 | m.aux <- x$m$model #fit.inla(yy, x)$model 112 | means <- m.aux$summary.fixed[, "mean"] 113 | precs <- m.aux$summary.hyperpar[, "mean"] 114 | 115 | ww <- get.probs(x$z) 116 | 117 | z.probs <- sapply(1:n, function (X) { 118 | aux <- ww * dnorm(yy[X], means, sqrt(1/precs)) 119 | (aux/sum(aux))[y$z[X]] 120 | }) 121 | 122 | if(log) { 123 | return(sum(log(z.probs))) 124 | } else { 125 | return(prod(z.probs)) 126 | } 127 | } 128 | 129 | #FIXME: We do not consider possible label switching here 130 | rq.z <- function(z) { 131 | m.aux <- z$m$model #fit.inla(yy, z)$model#model.cur # 132 | means <- m.aux$summary.fixed[, "mean"] 133 | precs <- m.aux$summary.hyperpar[, "mean"] 134 | 135 | probs <- get.probs(z$z) 136 | 137 | #Sample 138 | #ww <- NA 139 | #ww <- (n * probs + 1)/(n + n.grp) 140 | #ww <- as.vector(rmultinom(1, n, ww)/n) 141 | 142 | #Re-sample probs 143 | #probs <- rmultinom(1, length(z$z), probs) 144 | #probs <- probs/sum(probs) 145 | 146 | z.sim <- sapply(1:n, function (X) { 147 | aux <- probs * dnorm(yy[X], means, sqrt(1/precs)) 148 | sample(1:n.grp, 1, prob = aux/sum(aux)) 149 | }) 150 | 151 | #Fit model 152 | z.model <- fit.inla.internal(yy, z.sim) 153 | 154 | #Ne value 155 | z.new <- list(z = z.sim, m = z.model)#, w = ww) 156 | 157 | #Remove later 158 | #print("----------------------") 159 | #print(means) 160 | #print(precs) 161 | #print(ww) 162 | #print(z$m$mlik) 163 | #print(z.model$mlik) 164 | #print(dq.z(z.new, z) - dq.z(z, z.new)) 165 | 166 | return(z.new) 167 | } 168 | 169 | 170 | prior.z <- function(z, log = TRUE) { 171 | 172 | res <- log(0.5) * length(z$z) 173 | if(log) { 174 | return(res) 175 | } 176 | else { 177 | return(exp(res)) 178 | } 179 | } 180 | 181 | grp.init <- list(z = grp, m = fit.inla.internal(yy, grp), 182 | w = as.vector((table(grp) + 1) /(n + n.grp)) 183 | ) 184 | 185 | grp.init <- rq.z(grp.init) 186 | 187 | #Run simulations 188 | inlamh.res <- INLAMH(faithful$eruptions, fit.inla, grp.init, rq.z, dq.z, 189 | prior.z, n.sim = 10000, n.burnin = 500, n.thin = 10, verbose = TRUE) 190 | 191 | zz <- do.call(rbind, lapply(inlamh.res$b.sim, function(X){X$z})) 192 | 193 | zz.probs <- apply(zz, 2, get.probs) 194 | 195 | #Display probabilities 196 | plot(zz.probs[1,], yy) 197 | 198 | save(file = "oldfaith.RData", list = ls()) 199 | 200 | -------------------------------------------------------------------------------- /mixture/results.R: -------------------------------------------------------------------------------- 1 | #Compare results 2 | 3 | library(INLA) 4 | library(rjags) 5 | 6 | 7 | #Load results 8 | load("oldfaith.RData") 9 | load("jags-gaussian-ngrp-2.RData") 10 | 11 | 12 | #Display mean of the labels 13 | plot(apply(res.jags$Z, 1, mean), apply(zz, 2, mean), 14 | xlab = "MCMC", ylab = "INLA within MCMC" 15 | ) 16 | abline(0, 1) 17 | 18 | 19 | #Marginals of the fixed effects and hyperparameters 20 | margs.fixed <- lapply(inlamh.res$model.sim, function(X) { 21 | X$model$marginals.fixed}) 22 | 23 | margs.hyper <- lapply(inlamh.res$model.sim, function(X) { 24 | X$model$marginals.hyperpar}) 25 | 26 | n.margs <- length(margs.fixed) 27 | 28 | ws <- rep(1/n.margs, n.margs) 29 | 30 | get.margs <- function(margs, ws) { 31 | lapply(1:length(margs[[1]]), function(X) { 32 | aux <- lapply(margs, function(Y){ Y[[X]]}) 33 | INLABMA:::fitmargBMA(aux, ws) 34 | }) 35 | } 36 | 37 | margs.fixed <- get.margs(margs.fixed, ws) 38 | margs.hyper <- get.margs(margs.hyper, ws) 39 | 40 | 41 | #Probabilites 42 | probs.mcmc <- apply(res.jags$Z == 1, 1, mean) 43 | probs.inlamcmc <- apply(zz == 1, 2, mean) 44 | 45 | idx <- order (yy) 46 | 47 | pdf(file = "class.pdf") 48 | 49 | plot(yy[idx], probs.inlamcmc[idx], main = "Probability of being in group 1", 50 | xlab = "Eruption time", ylab = "Probability", type = "l") 51 | 52 | lines(yy[idx], probs.mcmc [idx], lty = 2) 53 | legend("topright", lty = 1:2, legend = c("INLA wihin MCMC", "MCMC"), bty = "n", 54 | cex = 1) 55 | 56 | dev.off() 57 | 58 | 59 | pdf(file = "mixtures.pdf") 60 | 61 | par(mfrow = c(2, 2)) 62 | 63 | for(i in 1:2) { 64 | plot(margs.fixed[[i]], type = "l", xlab = "", ylab = "", 65 | main = substitute(mu[i], list (i = i))) 66 | lines(density(res.jags$mu[i,,]), lty = 2) 67 | legend("topright", lty = 1:2, legend = c("INLA w/ MCMC", "MCMC"), bty = "n", 68 | cex = 0.8) 69 | 70 | plot(margs.hyper[[i]], type = "l", xlab = "", ylab = "", 71 | main = substitute(tau[i], list (i = i))) 72 | lines(density(res.jags$prec[i,,]), lty = 2) 73 | legend("topright", lty = 1:2, legend = c("INLA within MCMC", "MCMC"), bty = "n", 74 | cex = 0.8) 75 | 76 | } 77 | 78 | dev.off() 79 | 80 | -------------------------------------------------------------------------------- /poisson/INLA-MH-bivpo.R: -------------------------------------------------------------------------------- 1 | #Implementation of INLA within M-H for Bayesian Inference 2 | #Bivariate inference 3 | 4 | #Load libraries 5 | library(INLA) 6 | source("../linear/INLAMH_function.R") 7 | #To use static version on cluster 8 | INLA:::inla.dynload.workaround() 9 | 10 | 11 | #Simulate data 12 | n <- 100 13 | set.seed(123) 14 | x1 <- runif(n) 15 | x2 <- runif(n) 16 | #err <- rnorm(n) 17 | y <- rpois(n, exp(.5 + 2*x1-2*x2) ) 18 | 19 | d <- data.frame(y = y, x1 = x1, x2 = x2) 20 | 21 | save(file="databivpo.RData", list = c("d")) 22 | 23 | #INLA models 24 | m1 <- inla(y ~ 1+x1+x2, data = d, family = "poisson") 25 | summary(m1) 26 | 27 | #Fit linear model with R-INLA with a fixed beta 28 | #b Vector of length 2 29 | fit.inla <- function(data, b) { 30 | 31 | data$oset <- b[1] * data$x1 +b[2]*data$x2 32 | 33 | res <- inla(y ~1+offset(oset), data = data, family = "poisson") 34 | 35 | return(list(mlik = res$mlik[1,1], model = res)) 36 | } 37 | 38 | #Test model fitting 39 | fit.inla(d, c(1,1)) 40 | 41 | 42 | #Proposal x -> y 43 | #density 44 | dq.beta <- function(x, y, sigma = .75, log =TRUE) { 45 | sum(dnorm(y, mean = x, sd = sigma, log = log)) 46 | } 47 | #random 48 | rq.beta <- function(x, sigma = .75) { 49 | rnorm(length(x), mean = x, sd = sigma) 50 | } 51 | 52 | #Prior for beta 53 | prior.beta <- function(x, sigma = sqrt(1/.001), log = TRUE) { 54 | sum(dnorm(x, mean = 0, sd= sigma, log = log)) 55 | } 56 | 57 | 58 | 59 | #Prior for beta 60 | prior.beta <- function(x, sigma = sqrt(1/.001), log = TRUE) { 61 | sum(dnorm(x, mean = 0, sd= sigma, log = log)) 62 | } 63 | 64 | 65 | #Run simulations 66 | inlamh.res <- INLAMH(d, fit.inla, c(0, 0), rq.beta, dq.beta, prior.beta, 67 | n.sim = 10000, n.burnin = 500, n.thin = 10) 68 | 69 | 70 | #Show results 71 | b.sim <- do.call(rbind, inlamh.res$b.sim) 72 | model.sim <- inlamh.res$model.sim 73 | 74 | save(file = "INLA-MHbivpo.RData", list = ls()) 75 | 76 | 77 | #Load JAGS results 78 | # 79 | # 80 | # Run source("jags.R", echo = TRUE) to get the results from jags. 81 | library(rjags) 82 | load("jags.RData") 83 | 84 | #Compute conturs 85 | library(MASS) 86 | z.inla <- kde2d(b.sim[, 1], b.sim[, 2]) 87 | z.mcmc <- kde2d(jm2.samp$beta1[1,,], jm2.samp$beta2[1,,]) 88 | 89 | 90 | pdf(file = "INLA-MHbivpo.pdf", width = 10, height = 5) 91 | par(mfrow = c(1,3)) 92 | plot(b.sim[, ]) 93 | #abline(h = 2, col = "red") 94 | 95 | #Density beta1 96 | plot(density(b.sim[, 1], bw = 0.07)) 97 | lines(m1$marginals.fixed[[2]], col ="red") 98 | legend("topleft", lty = 1, legend = c("INLA", "MCMC"), col = c("red", "black")) 99 | 100 | #Density beta2 101 | plot(density(b.sim[, 2], bw = 0.07)) 102 | lines(m1$marginals.fixed[[3]], col ="red") 103 | legend("topleft", lty = 1, legend = c("INLA", "MCMC"), col = c("red", "black")) 104 | 105 | dev.off() 106 | 107 | 108 | print(c("Acceptance rate:", mean(acc.sim[-1]))) 109 | 110 | #Summary statistics 111 | print("Summary statistics of beta:") 112 | c(mean(b.sim[, 1]), sd(b.sim[, 1]), quantile(b.sim[, 1], c(0.025, .5, .975)) ) 113 | c(mean(b.sim[, 2]), sd(b.sim[, 2]), quantile(b.sim[, 2], c(0.025, .5, .975)) ) 114 | m1$summary.fixed[-1,] 115 | 116 | #We need to add the prior of the paramaters 117 | mliks <- sapply(model.sim, function(X){ X$mlik }) 118 | mliks <- mliks + sapply(b.sim, prior.beta) 119 | 120 | probs <- exp(mliks-min(mliks)) 121 | probs <- probs/sum(probs) 122 | 123 | 124 | save(file = "INLA-MHbivpo.RData", list = ls()) 125 | 126 | #BMA models 127 | library(INLABMA) 128 | 129 | #bma.model <- INLABMA(model.sim[-(1:n.burnin)], 1:(n.sim-n.burnin)) 130 | 131 | models <- lapply(model.sim, function(X){X$model}) 132 | ws <- rep(1/length(models), length(models)) 133 | 134 | listmarg <- c("marginals.fixed", "marginals.hyperpar") 135 | margeff <- mclapply(listmarg, function(X) { 136 | INLABMA:::fitmargBMA2(models, ws, X) 137 | }) 138 | 139 | 140 | pdf(file = "INLA-MHbivpo2.pdf", width = 7.5, height = 7.5) 141 | par(mfcol = c(2,3)) 142 | par(plt = c(.15, .95, .15, .9)) 143 | 144 | #Contour plots: INLA 145 | #plot(b.sim[idx,], xlab = "", ylab = "", main = "Markov Chain") 146 | contour(z.inla, xlab = expression(beta[1]), ylab = expression(beta[2])) 147 | points(c(2, -2), col = "black", pch = 4, cex = 2, lwd = 3) 148 | 149 | legend("topright", lty = 1:2, legend = c("INLA+MCMC", "MCMC"), 150 | bty = "n", cex = .8) 151 | legend("bottomleft", pch = 4, legend = "Value", bty = "n", cex = 0.8) 152 | 153 | #Contour plots: MCMC 154 | contour(z.mcmc, lty = 2, xlab = expression(beta[1]), ylab = expression(beta[2])) 155 | points(c(2, -2), col = "black", pch = 4, cex = 2, lwd = 3) 156 | 157 | legend("topright", lty = 1:2, legend = c("INLA+MCMC", "MCMC"), 158 | bty = "n", cex = .8) 159 | legend("bottomleft", pch = 4, legend = "Value", bty = "n", cex = 0.8) 160 | 161 | 162 | 163 | #Density beta1 164 | plot(density(b.sim[, 1], bw = 0.08), main = expression(beta[1]), 165 | xlab = "") 166 | lines(m1$marginals.fixed[[2]], lty = 2) 167 | #JAGS 168 | lines(density(jm2.samp$beta1[1,,], bw = 0.08), lty = 3) 169 | 170 | legend("topright", lty = 1:3, legend = c("INLA+MCMC", "INLA", "MCMC"), 171 | bty = "n", cex = .8) 172 | 173 | #Density beta2 174 | plot(density(b.sim[, 2], bw = 0.08), main = expression(beta[2]), 175 | xlab = "") 176 | lines(m1$marginals.fixed[[3]], lty = 2) 177 | #JAGS 178 | lines(density(jm2.samp$beta2[1,,], bw = 0.08), lty = 3) 179 | 180 | legend("topright", lty = 1:3, legend = c("INLA+MCMC", "INLA", "MCMC"), 181 | bty = "n", cex = .8) 182 | 183 | #Fixed effects 184 | plot(margeff[[1]][[1]], type = "l", xlab = "", ylab = "", 185 | main = expression(alpha)) 186 | lines(m1$marginals.fixed[[1]], lty = 2) 187 | #JAGS 188 | lines(density(jm2.samp$alpha[1,,], bw = 0.03), lty = 3) 189 | 190 | legend("topright", lty = 1:3, legend = c("INLA+MCMC", "INLA", "MCMC"), 191 | bty = "n", cex = .8) 192 | 193 | #NO Hyperparameters 194 | 195 | dev.off() 196 | 197 | 198 | -------------------------------------------------------------------------------- /poisson/effssize.R: -------------------------------------------------------------------------------- 1 | #Test effective sample size 2 | 3 | library(INLA) 4 | library(rjags) 5 | library(coda) 6 | 7 | #Load data 8 | load("INLA-MHbivpo.RData") 9 | load("jags.RData") 10 | 11 | 12 | #Create mcmc object from INLA+MCMC 13 | b.sim.mcmc <- as.mcmc(b.sim) 14 | 15 | #Compute eff. s.size for different number of iterations 16 | n.iter <- seq(100, 10000, by = 100) 17 | 18 | #INLA+MCMC 19 | #samples: mcmc object 20 | 21 | get.ess <- function(samples) { 22 | unlist(lapply(n.iter, function(X) { 23 | min(effectiveSize(samples[1:X, ])) 24 | })) 25 | } 26 | 27 | effsize.inlamcmc <- get.ess(b.sim.mcmc) 28 | 29 | #JAGS 30 | jags.mcmc <- do.call(cbind, 31 | lapply(c("alpha", "beta1", "beta2"), function(X) { 32 | as.vector(jm2.samp[[X]]) 33 | }) 34 | ) 35 | effsize.jags <- get.ess(jags.mcmc) 36 | effsize.jags2 <- get.ess(jags.mcmc[, 2:3]) 37 | 38 | 39 | 40 | #Display results 41 | pdf(file = "effssize-poisson.pdf") 42 | 43 | plot(n.iter, effsize.inlamcmc, type = "l", xlab = "Number of iterations", 44 | ylab = "Effective sample size", 45 | main = "Minimum effective sample size (Poisson regression)") 46 | lines(n.iter, effsize.jags, lty = 2) 47 | lines(n.iter, effsize.jags2, lty = 3) 48 | 49 | 50 | legend("topleft", legend = c( 51 | expression(paste("INLA within MCMC (", beta[1], ", ", beta[2], ")")), 52 | expression(paste("MCMC (", beta[1], ", ", beta[2], ", ", alpha, ")")), 53 | expression(paste("MCMC (", beta[1], ", ", beta[2], ")"))), lty = 1:3, 54 | bty = "n") 55 | 56 | 57 | dev.off() 58 | 59 | -------------------------------------------------------------------------------- /poisson/jags.R: -------------------------------------------------------------------------------- 1 | #Run mdoels with JAGS 2 | library(rjags) 3 | 4 | #Load data 5 | #y <- 3 + 2*x+err 6 | #err <- rnorm(n) 7 | load("data.RData") 8 | 9 | d <- as.list(d) 10 | 11 | d$N <- length(d$y) 12 | 13 | #1 COVARIATE DATA 14 | jm1 <- jags.model('model.bug', 15 | data = d, 16 | n.chains = 1, 17 | n.adapt = 100) 18 | 19 | update(jm1, 500) 20 | 21 | jm1.samp <- jags.samples(jm1, 22 | c('alpha', 'beta', 'mu'), 23 | n.iter = 100000, thin = 10) 24 | 25 | print(jm1.samp) 26 | 27 | 28 | #TWO COVARIATES DATA 29 | #y <- 3 + 2*x1-2*x2+err 30 | #err <- rnorm(n) 31 | load("databiv.RData") 32 | 33 | d <- as.list(d) 34 | d$N <- length(d$y) 35 | 36 | jm2 <- jags.model('modelbiv.bug', 37 | data = d, 38 | n.chains = 1, 39 | n.adapt = 100) 40 | 41 | update(jm2, 500) 42 | 43 | jm2.samp <- jags.samples(jm2, 44 | c('alpha', 'beta1', 'beta2', 'mu'), 45 | n.iter = 100000, thin = 10) 46 | 47 | print(jm2.samp) 48 | 49 | 50 | save(file = "jags.RData", list = c("jm1.samp", "jm2.samp")) 51 | 52 | 53 | -------------------------------------------------------------------------------- /poisson/modelbiv.bug: -------------------------------------------------------------------------------- 1 | model { 2 | 3 | for(i in 1:N) { 4 | y[i] ~ dpois(mu[i]) 5 | log(mu[i]) <- alpha + beta1 * x1[i] + beta2 * x2[i] 6 | } 7 | 8 | alpha ~ dunif(-1000, 1000) 9 | beta1 ~ dnorm(0, .001) 10 | beta2 ~ dnorm(0, .001) 11 | } 12 | -------------------------------------------------------------------------------- /spatialeco/INLA-MH-speco.R: -------------------------------------------------------------------------------- 1 | #Implementation of INLA within M-H for Bayesian Inference 2 | # SPATIAL ERROR MODEL (see INLABMA::sem.inla) 3 | 4 | #Load libraries 5 | library(INLA) 6 | library(spdep) 7 | library(INLABMA) 8 | 9 | INLA:::inla.dynload.workaround() 10 | #INLAMH() 11 | source("INLAMH_function.R") 12 | 13 | 14 | #Load data and compute adjacency matrix 15 | data(columbus) 16 | lw <- nb2listw(col.gal.nb, style="W") 17 | 18 | #FIT model using ML 19 | colsemml <- errorsarlm(CRIME ~ INC + HOVAL, data=columbus, lw, method="eigen", 20 | quiet=FALSE) 21 | 22 | 23 | #Adjacency matrix 24 | W <- as(as_dgRMatrix_listw(nb2listw(col.gal.nb)), "CsparseMatrix") 25 | #Index for spatial random effects 26 | columbus$idx<-1:nrow(columbus) 27 | 28 | 29 | 30 | #Formula 31 | form<- CRIME ~ INC + HOVAL 32 | 33 | zero.variance = list(prec=list(initial = 25, fixed=TRUE)) 34 | 35 | 36 | #Fit model for a given rho 37 | fit.inla <- function(data, rho) { 38 | #, form = form, W = W, 39 | # zero.variance = zero.variance) { 40 | res <- sem.inla(form, d = data, W = W, rho = rho, 41 | family = "gaussian", impacts = FALSE, 42 | control.family = list(hyper = zero.variance), 43 | #control.predictor = list(compute = TRUE), 44 | #control.compute = list(dic = TRUE, cpo = TRUE), 45 | #control.inla = list(print.joint.hyper = TRUE), 46 | ##tolerance=1e-20, h=1e-6), 47 | verbose = FALSE) 48 | 49 | return(list(mlik = res$mlik[1,1], model = res)) 50 | } 51 | 52 | 53 | #Proposal x -> y 54 | #density 55 | dq.rho <- function(x, y, sigma = .15, log =TRUE) { 56 | dnorm(y, mean = x, sd = sigma, log = log) 57 | } 58 | #random 59 | rq.rho <- function(x, sigma = .15) { 60 | rnorm(1, mean = x, sd = sigma) 61 | } 62 | 63 | #Prior for beta#Uniform [-1.5, 1] using eigenvalues 64 | prior.rho <- function(x, log = TRUE) { 65 | dunif(x, -1.5, 1, log = log) 66 | } 67 | 68 | #Data as 'd' 69 | d <- columbus 70 | 71 | #Run simulations 72 | inlamh.res <- INLAMH(d, fit.inla, 0, rq.rho, dq.rho, prior.rho, 73 | n.sim = 10000, n.burnin = 500, n.thin = 10) 74 | 75 | #Show results 76 | b.sim <- do.call(rbind, inlamh.res$b.sim) 77 | model.sim <- inlamh.res$model.sim 78 | 79 | save(file = "INLA-MH-speco.RData", list = ls()) 80 | 81 | #Compute model with JAGS 82 | library(SEjags) 83 | 84 | if(!file.exists("SEjags.RData")) { 85 | sem.mcmc <- SEjags(CRIME ~ INC + HOVAL, data = columbus, W = listw2mat(lw), 86 | model = "sem", n.burnin = 500, n.iter = 10000, n.thin = 10) 87 | 88 | save(file = "SEjags.RData", list = c("sem.mcmc")) 89 | } else { 90 | load("SEjags.RData") 91 | } 92 | 93 | #Using Bivand et al. (2014) 94 | library(parallel) 95 | options(mc.cores = 4) 96 | 97 | #Define grid on rho 98 | rrho<-seq(-1, .95, length.out=40) 99 | 100 | seminla<-mclapply(rrho, function(rho){ 101 | 102 | sem.inla(form, d=columbus, W=W, rho=rho, 103 | family = "gaussian", impacts=FALSE, 104 | control.family = list(hyper = zero.variance), 105 | control.predictor=list(compute=TRUE), 106 | control.compute=list(dic=TRUE, cpo=TRUE), 107 | control.inla=list(print.joint.hyper=TRUE, 108 | tolerance=1e-20, h=1e-6), 109 | verbose=FALSE 110 | ) 111 | 112 | }) 113 | sembma <- INLABMA(seminla, rrho, 0, usenormal = TRUE) 114 | 115 | 116 | pdf(file = "INLA-MH.pdf", width = 10, height = 5) 117 | par(mfrow = c(1,2)) 118 | plot(b.sim, type = "l") 119 | abline(h = colsemml$lambda, col = "red") 120 | abline(h = sembma$rho$mean, col = "red", lty = 2) 121 | legend("topleft", legend = c("INLA+MCMC", "Bivand et al.", "Max. Lik."), 122 | lty = c(1, 2, 1), col = c("black", "red", "red"), bty = "n") 123 | 124 | #Density 125 | plot(density(b.sim)) 126 | lines(density(sem.mcmc$lambda), lty = 2) 127 | lines(sembma$rho$marginal, lty = 3) 128 | abline(v = colsemml$lambda, lty = 4) 129 | 130 | legend("topleft", legend = c("INLA+MCMC", "MCMC", "Bivand et al.", "Max. Lik."), 131 | lty = 1:4, bty = "n") 132 | #MCMC 133 | 134 | dev.off() 135 | 136 | 137 | print(c("Acceptance rate:", mean(inlamh.res$acc.sim))) 138 | 139 | #Summary statistics 140 | print("Summary statistics of rho:") 141 | c(mean(b.sim), sd(b.sim), 142 | quantile(b.sim, c(0.025, .5, .975)) ) 143 | inla.zmarginal(sembma$rho$marginal) 144 | 145 | #We need to add the prior of the paramaters 146 | mliks <- sapply(model.sim, function(X){ X$mlik }) 147 | mliks <- mliks + sapply(b.sim, prior.rho) 148 | 149 | probs <- exp(mliks-min(mliks)) 150 | probs <- probs/sum(probs) 151 | 152 | 153 | #BMA models 154 | library(INLABMA) 155 | 156 | #bma.model <- INLABMA(model.sim[-(1:n.burnin)], 1:(n.sim-n.burnin)) 157 | 158 | models <- lapply(model.sim, function(X){X$model}) 159 | n.sim <- length(models) 160 | ws <- rep(1/n.sim, n.sim) 161 | 162 | listmarg <- c("marginals.fixed", "marginals.hyperpar") 163 | margeff <- mclapply(listmarg, function(X) { 164 | INLABMA:::fitmargBMA2(models, ws, X) 165 | }) 166 | 167 | #Summary estimates of fixed effects 168 | do.call(rbind, lapply(margeff[[1]], inla.zmarginal)) 169 | sembma$summary.fixed 170 | 171 | #Summary estimates 172 | do.call(rbind, lapply(margeff[[2]], inla.zmarginal)) 173 | sembma$summary.hyperpar 174 | sembma.hyper <- do.call(rbind, lapply(seminla, function(X){X$summary.hyperpar[,1:2]})) 175 | mean(sembma.hyper[, 1]) #Mean 176 | sqrt(mean(sembma.hyper[, 2]^2)) #Standard deviation 177 | 178 | 179 | #MCMC summary 180 | #-->rho 181 | print(c("RHO MCMC (mean, sd)", mean(sem.mcmc$lambda[1,,1]), 182 | sd(sem.mcmc$lambda[1,,1]))) 183 | #--->betas 184 | apply(sem.mcmc$b[,1,,1], 1, mean) 185 | #[1] 58.8026027 -0.9171711 -0.2978022 186 | apply(sem.mcmc$b[,1,,1], 1, sd) 187 | #[1] 6.4571607 0.4061325 0.1017372 188 | #--->1/sigma^2_u 189 | mean(sem.mcmc$tau[,,1]) 190 | sd(sem.mcmc$tau[,,1]) 191 | 192 | 193 | 194 | 195 | 196 | 197 | save(file = "INLA-MH-speco.RData", list = ls()) 198 | 199 | 200 | 201 | -------------------------------------------------------------------------------- /spatialeco/summary-speco.R: -------------------------------------------------------------------------------- 1 | #Implementation of INLA within M-H for Bayesian Inference 2 | # SPATIAL ERROR MODEL (see INLABMA::sem.inla) 3 | 4 | #Load libraries 5 | library(INLA) 6 | 7 | INLA:::inla.dynload.workaround() 8 | 9 | 10 | library(spdep) 11 | library(INLABMA) 12 | 13 | load("INLA-MH-speco.RData") 14 | 15 | #Using Bivand et al. (2014) 16 | library(parallel) 17 | options(mc.cores = 4) 18 | 19 | #Define grid on rho 20 | rrho<-seq(-1, .95, length.out=40) 21 | 22 | seminla<-mclapply(rrho, function(rho){ 23 | 24 | sem.inla(form, d=columbus, W=W, rho=rho, 25 | family = "gaussian", impacts=FALSE, 26 | control.family = list(hyper = zero.variance), 27 | control.predictor=list(compute=TRUE), 28 | control.compute=list(dic=TRUE, cpo=TRUE), 29 | control.inla=list(print.joint.hyper=TRUE, 30 | tolerance=1e-20, h=1e-6), 31 | verbose=FALSE 32 | ) 33 | 34 | }) 35 | sembma<-INLABMA(seminla, rrho, 0, usenormal = TRUE) 36 | 37 | 38 | print(c("Acceptance rate:", mean(inlamh.res$acc.sim))) 39 | 40 | #Summary statistics 41 | print("Summary statistics of rho:") 42 | c(mean(b.sim), sd(b.sim), 43 | quantile(b.sim, c(0.025, .5, .975)) ) 44 | inla.zmarginal(sembma$rho$marginal) 45 | 46 | #We need to add the prior of the paramaters 47 | mliks <- sapply(model.sim, function(X){ X$mlik }) 48 | mliks <- mliks + sapply(b.sim, prior.rho) 49 | 50 | probs <- exp(mliks-min(mliks)) 51 | probs <- probs/sum(probs) 52 | 53 | 54 | #BMA models 55 | library(INLABMA) 56 | 57 | #bma.model <- INLABMA(model.sim[-(1:n.burnin)], 1:(n.sim-n.burnin)) 58 | 59 | models <- lapply(model.sim, function(X){X$model}) 60 | n.sim <- length(models) 61 | ws <- rep(1/n.sim, n.sim) 62 | 63 | listmarg <- c("marginals.fixed", "marginals.hyperpar") 64 | margeff <- mclapply(listmarg, function(X) { 65 | INLABMA:::fitmargBMA2(models, ws, X) 66 | }) 67 | 68 | #Summary estimates of fixed effects 69 | do.call(rbind, lapply(margeff[[1]], inla.zmarginal)) 70 | sembma$summary.fixed 71 | 72 | #Summary estimates 73 | do.call(rbind, lapply(margeff[[2]], inla.zmarginal)) 74 | sembma$summary.hyperpar 75 | 76 | rm(inlamh.res) 77 | rm(model.sim) 78 | rm(b.sim) 79 | rm(models) 80 | save(file = "summary-speco.RData", list = ls()) 81 | 82 | 83 | --------------------------------------------------------------------------------