Nothing
R/LaplacesDemon.R
In LaplacesDemon: Complete Environment for Bayesian Inference
Defines functions
.mcmcusmwg
.mcmcusamwg
.mcmcuess
.mcmctwalk
.mcmcthmc
.mcmcsmwg
.mcmcslice
.mcmcsgld
.mcmcsamwg
.mcmcrwm
.mcmcrss
.mcmcrj
.mcmcrefractive
.mcmcrdmh
.mcmcram
.mcmcpcn
.mcmcohss
.mcmcnuts
.mcmcmwg
.mcmcmtm
.mcmcmcmcmc
.mcmcmala
.mcmcinca
.mcmcim
.mcmchmcda
.mcmchmc
.mcmcharm
.mcmcggdpp
.mcmcggdp
.mcmcggcpp
.mcmcggcp
.mcmcgg
.mcmcgibbs
.mcmcess
.mcmcdrm
.mcmcdram
.mcmcdemc
.mcmccharm
.mcmcamwg
.mcmcamm.b
.mcmcamm
.mcmcam
.mcmcaies
.mcmcahmc
.mcmcagg
.mcmcafss
.mcmcadmg
LaplacesDemon
Documented in
LaplacesDemon
.mcmcadmg
.mcmcafss
.mcmcagg
.mcmcahmc
.mcmcaies
.mcmcam
.mcmcamm
.mcmcamm.b
.mcmcamwg
.mcmccharm
.mcmcdemc
.mcmcdram
.mcmcdrm
.mcmcess
.mcmcgg
.mcmcggcp
.mcmcggcpp
.mcmcggdp
.mcmcggdpp
.mcmcgibbs
.mcmcharm
.mcmchmc
.mcmchmcda
.mcmcim
.mcmcinca
.mcmcmala
.mcmcmcmcmc
.mcmcmtm
.mcmcmwg
.mcmcnuts
.mcmcohss
.mcmcram
.mcmcrdmh
.mcmcrefractive
.mcmcrj
.mcmcrss
.mcmcrwm
.mcmcsamwg
.mcmcsgld
.mcmcslice
.mcmcsmwg
.mcmcthmc
.mcmctwalk
.mcmcuess
.mcmcusamwg
.mcmcusmwg
###########################################################################
# LaplacesDemon #
# #
# The purpose of the LaplacesDemon function is to use MCMC on the #
# logarithm of the unnormalized joint posterior density of a Bayesian #
# model. #
###########################################################################
LaplacesDemon <- function(Model, Data, Initial.Values, Covar=NULL,
Iterations=10000, Status=100, Thinning=10, Algorithm="MWG",
Specs=list(B=NULL), Debug=list(DB.chol=FALSE, DB.eigen=FALSE,
DB.MCSE=FALSE, DB.Model=TRUE), LogFile="", ...)
{
cat("\nLaplace's Demon was called on ", date(), "\n", sep="",
file=LogFile, append=TRUE)
time1 <- proc.time()
LDcall <- match.call()
########################## Initial Checks ##########################
cat("\nPerforming initial checks...\n", file=LogFile, append=TRUE)
if(missing(Model))
stop("A function must be entered for Model.", file=LogFile,
append=TRUE)
if(!is.function(Model))
stop("Model must be a function.", file=LogFile, append=TRUE)
if(missing(Data))
stop("A list containing data must be entered for Data.",
file=LogFile, append=TRUE)
if(is.null(Data[["mon.names"]]))
stop("In Data, mon.names is NULL.", file=LogFile, append=TRUE)
if(is.null(Data[["parm.names"]]))
stop("In Data, parm.names is NULL.", file=LogFile, append=TRUE)
for (i in 1:length(Data)) {
if(is.matrix(Data[[i]])) {
if(all(is.finite(Data[[i]]))) {
mat.rank <- qr(Data[[i]], tol=1e-10)$rank
if(mat.rank < ncol(Data[[i]])) {
cat("WARNING: Matrix", names(Data)[[i]],
"may be rank-deficient.\n", file=LogFile,
append=TRUE)}}}}
if(missing(Initial.Values)) {
cat("WARNING: Initial Values were not supplied.\n", file=LogFile,
append=TRUE)
Initial.Values <- rep(0, length(Data[["parm.names"]]))}
if(!identical(length(Initial.Values), length(Data[["parm.names"]]))) {
cat("WARNING: The length of Initial Values differed from",
"Data$parm.names.\n", file=LogFile, append=TRUE)
Initial.Values <- rep(0, length(Data[["parm.names"]]))}
if(any(!is.finite(Initial.Values))) {
cat("WARNING: Initial Values contain non-finite values.\n",
file=LogFile, append=TRUE)
Initial.Values <- rep(0, length(Data[["parm.names"]]))}
Iterations <- round(abs(Iterations))
if(Iterations < 11) {
Iterations <- 11
cat("'Iterations' has been changed to ", Iterations, ".\n",
sep="", file=LogFile, append=TRUE)}
Status <- round(abs(Status))
if({Status < 1} || {Status > Iterations}) {
Status <- Iterations
cat("'Status' has been changed to ", Status, ".\n",
sep="", file=LogFile, append=TRUE)}
Thinning <- round(abs(Thinning))
if({Thinning < 1} || {Thinning > Iterations}) {
Thinning <- 1
cat("'Thinning' has been changed to ", Thinning, ".\n",
sep="", file=LogFile, append=TRUE)}
if(Algorithm %in% c("ADMG","AFSS","AGG","AHMC","AIES","AM","AMM",
"AMWG","CHARM","DEMC","DRAM","DRM","ESS","Experimental","GG",
"Gibbs","HARM","HMC","HMCDA","IM","INCA","MALA","MCMCMC","MTM",
"MWG","NUTS","OHSS","pCN","RAM","Refractive","RDMH","RJ","RSS",
"RWM","SAMWG","SGLD","Slice","SMWG","THMC","twalk","UESS",
"USAMWG","USMWG")) {
if(Algorithm == "ADMG") {
Algorithm <- "Adaptive Directional Metropolis-within-Gibbs"
if(missing(Specs) | is.null(Specs))
Specs <- list(n=0, Periodicity=1)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("n","Periodicity") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["n"]] <- abs(round(Specs[["n"]]))
Specs[["Periodicity"]] <- max(abs(round(Specs[["Periodicity"]])),
length(Initial.Values))
}
else if(Algorithm == "AFSS") {
Algorithm <- "Automated Factor Slice Sampler"
if(missing(Specs) | is.null(Specs))
Specs <- list(A=Inf, B=NULL, m=Inf, n=0, w=1)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("A","B","m","n","w") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["A"]] <- min(round(abs(Specs[["A"]])), Iterations)
Specs[["m"]] <- abs(round(Specs[["m"]]))
if(!identical(length(Specs[["m"]]), length(Initial.Values)))
Specs[["m"]] <- rep(Specs[["m"]],
length(Initial.Values))
Specs[["n"]] <- abs(round(Specs[["n"]]))
Specs[["w"]] <- abs(Specs[["w"]])
if(!identical(length(Specs[["w"]]), length(Initial.Values)))
Specs[["w"]] <- rep(Specs[["w"]],
length(Initial.Values))
}
else if(Algorithm == "AGG") {
Algorithm <- "Adaptive Griddy-Gibbs"
if(missing(Specs))
stop("The Specs argument is required.", file=LogFile,
append=TRUE)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("Grid","dparm","smax","CPUs","Packages","Dyn.libs")
%in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
if(is.list(Specs[["Grid"]])) {
if(length(Specs[["Grid"]]) != length(Initial.Values)) {
Specs[["Grid"]] <- list(NULL)
for (i in 1:length(Initial.Values))
Specs[["Grid"]][[i]] <- GaussHermiteQuadRule(3)$nodes
cat("\nGrid was misspecified and changed to default.\n",
file=LogFile, append=TRUE)}
}
else {
temp <- as.vector(Specs[["Grid"]])
Specs[["Grid"]] <- list(NULL)
for (i in 1:length(Initial.Values))
Specs[["Grid"]][[i]] <- temp}
if(!is.null(Specs[["dparm"]])) {
Specs[["dparm"]] <- unique(interval(round(Specs[["dparm"]]), 1,
length(Initial.Values)))
Specs[["dparm"]] <- Specs[["dparm"]][order(Specs[["dparm"]])]}
else Specs[["dparm"]] <- 0
Specs[["smax"]] <- abs(Specs[["smax"]])
Specs[["CPUs"]] <- max(1, abs(round(Specs[["CPUs"]])))
}
else if(Algorithm == "AHMC") {
Algorithm <- "Adaptive Hamiltonian Monte Carlo"
if(missing(Specs) | is.null(Specs))
Specs=list(epsilon=rep(1/length(Initial.Values),
length(Initial.Values)), L=2, m=rep(1,
length(Initial.Values)), Periodicity=1)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("epsilon","L","m","Periodicity") %in% names(Specs)))
if(!identical(names(Specs),
c("epsilon","L","m","Periodicity")))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
if(is.null(Specs[["epsilon"]]))
Specs[["epsilon"]] <- rep(1/length(Initial.Values),
length(Initial.Values))
Specs[["epsilon"]] <- as.vector(abs(Specs[["epsilon"]]))
if(length(Specs[["epsilon"]]) != length(Initial.Values)) {
cat("\nLength of epsilon is incorrect.\n",
file=LogFile, append=TRUE)
Specs[["epsilon"]] <- rep(Specs[["epsilon"]][1],
length(Initial.Values))}
Specs[["L"]] <- abs(round(Specs[["L"]]))
if(Specs[["L"]] < 1) {
cat("\nL has been increased to its minimum: 1.\n",
file=LogFile, append=TRUE)
Specs[["L"]] <- 1}
if(is.null(Specs[["m"]]))
Specs[["m"]] <- diag(length(Initial.Values))
}
else if(Algorithm == "AIES") {
Algorithm <- "Affine-Invariant Ensemble Sampler"
if(missing(Specs))
stop("The Specs argument is required.", file=LogFile,
append=TRUE)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("Nc","Z","beta","CPUs","Packages","Dyn.libs") %in%
names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["Nc"]] <- max(abs(round(Specs[["Nc"]])), 3)
if(!is.null(Specs[["Z"]])) {
if(is.matrix(Specs[["Z"]])) {
if(ncol(Specs[["Z"]]) != length(Initial.Values))
stop("Z has the wrong number of columns.",
file=LogFile, append=TRUE)
if(nrow(Specs[["Z"]]) != Specs[["Nc"]])
stop("Z has the wrong number of rows.",
file=LogFile, append=TRUE)}}
if(length(Specs[["beta"]]) != 1) {
cat("\nLength of beta is wrong. Changed to 1.\n",
file=LogFile, append=TRUE)
Specs[["beta"]] <- as.vector(Specs[["beta"]])[1]}
if(Specs[["beta"]] <= 1) {
cat("\nbeta must be > 1. Changed to 2.\n",
file=LogFile, append=TRUE)
Specs[["beta"]] <- 2}
Specs[["CPUs"]] <- max(1, abs(round(Specs[["CPUs"]])))
if(Specs[["CPUs"]] > 1 & Specs[["Nc"]] %% 2 != 0)
stop("For CPUs > 1, Nc must be even.", file=LogFile,
append=TRUE)
}
else if(Algorithm == "AM") {
Algorithm <- "Adaptive Metropolis"
if(missing(Specs) | is.null(Specs))
Specs=list(Adaptive=floor(Iterations/2),
Periodicity=1)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("Adaptive","Periodicity") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
}
else if(Algorithm == "AMM") {
Algorithm <- "Adaptive-Mixture Metropolis"
if(missing(Specs) | is.null(Specs))
Specs=list(Adaptive=floor(Iterations/2), B=NULL,
n=0, Periodicity=1, w=0.05)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("Adaptive","B","n","Periodicity","w") %in%
names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
if(!is.null(Specs[["B"]])) {
if(is.null(Covar)) {
Covar <- list(NULL)
for (b in 1:length(Specs[["B"]])) {
Covar[[b]] <- diag(length(Specs[["B"]][[b]]))}}}
Specs[["n"]] <- round(abs(Specs[["n"]]))
Specs[["w"]] <- abs(Specs[["w"]])
if(Specs[["w"]] <= 0 || Specs[["w"]] >= 1) {
Specs[["w"]] <- 0.05
cat("\nw was misspecified and changed to 0.05.\n",
file=LogFile, append=TRUE)}
}
else if(Algorithm == "AMWG") {
Algorithm <- "Adaptive Metropolis-within-Gibbs"
if(missing(Specs) | is.null(Specs))
Specs=list(B=NULL, n=0, Periodicity=50)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("B","n","Periodicity") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
}
else if(Algorithm == "CHARM") {
Algorithm <- "Componentwise Hit-And-Run Metropolis"
if(missing(Specs) | is.null(Specs))
Specs <- list(alpha.star=NA)
else {
if(!is.list(Specs))
stop("The Specs argument is not a list.",
file=LogFile, append=TRUE)
if(!all(c("alpha.star") %in% names(Specs)))
stop("The Specs argument is incorrect",
file=LogFile, append=TRUE)
Specs[["alpha.star"]] <- abs(as.vector(Specs[["alpha.star"]])[1])
if(Specs[["alpha.star"]] <= 0 | Specs[["alpha.star"]] >= 1) {
cat("\nalpha.star not in (0,1), set to 0.44.\n",
file=LogFile, append=TRUE)
alpha.star <- 0.44}}
}
else if(Algorithm == "DEMC") {
Algorithm <- "Differential Evolution Markov Chain"
if(missing(Specs))
stop("The Specs argument is required.", file=LogFile,
append=TRUE)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("Nc","Z","gamma","w") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["Nc"]] <- max(abs(round(Specs[["Nc"]])), 3)
if(!is.null(Specs[["Z"]])) {
if(is.matrix(Specs[["Z"]])) {
if(ncol(Specs[["Z"]]) != length(Initial.Values))
stop("Z has the wrong number of columns.",
file=LogFile, append=TRUE)
if(nrow(Specs[["Z"]]) != (floor(Iterations/Thinning)+1)) {
Z.temp <- Specs[["Z"]][nrow(Specs[["Z"]]),]
if(nrow(Specs[["Z"]]) < (floor(Iterations/Thinning)+1)) {
Specs[["Z"]] <- rbind(Specs[["Z"]],
Specs[["Z"]][1:(floor(Iterations/Thinning)+1-nrow(Specs[["Z"]])),])
}
else if(nrow(Specs[["Z"]]) > (floor(Iterations/Thinning)+1))
Specs[["Z"]] <- Specs[["Z"]][1:(floor(Iterations/Thinning)+1),]
Specs[["Z"]][1,] <- Z.temp
}
Specs[["Z"]] <- array(Specs[["Z"]], dim=c(floor(Iterations/Thinning)+1,
length(Initial.Values), Specs[["Nc"]]))}
if(dim(Specs[["Z"]])[1] != floor(Iterations/Thinning)+1)
stop("The first dimension of Z is incorrect.",
file=LogFile, append=TRUE)
if(dim(Specs[["Z"]])[2] != length(Initial.Values))
stop("The second dimension of Z is incorrect.",
file=LogFile, append=TRUE)
if(dim(Specs[["Z"]])[3] != Specs[["Nc"]])
stop("The third dimension of Z is incorrect.",
file=LogFile, append=TRUE)}
if(is.null(Specs[["gamma"]]))
Specs[["gamma"]] <- 2.381204 /
sqrt(2*length(Initial.Values))
else Specs[["gamma"]] <- abs(Specs[["gamma"]])
Specs[["w"]] <- interval(Specs[["w"]], 0, 1)
}
else if(Algorithm == "DRAM") {
Algorithm <- "Delayed Rejection Adaptive Metropolis"
if(missing(Specs) | is.null(Specs))
Specs=list(Adaptive=floor(Iterations/2),
Periodicity=1)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("Adaptive","Periodicity") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
}
else if(Algorithm == "DRM") {
Algorithm <- "Delayed Rejection Metropolis"
Specs <- NULL
}
else if(Algorithm == "ESS") {
Algorithm <- "Elliptical Slice Sampler"
if(missing(Specs) | is.null(Specs))
Specs=list(B=NULL)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("B") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
if(is.null(Specs[["B"]])) Specs[["B"]] <- list()
}
else if(Algorithm == "Experimental") {
Specs=NULL
}
else if(Algorithm == "GG") {
Algorithm <- "Griddy-Gibbs"
if(missing(Specs))
stop("The Specs argument is required.", file=LogFile,
append=TRUE)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("Grid","dparm","CPUs","Packages","Dyn.libs") %in%
names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
if(is.list(Specs[["Grid"]])) {
if(length(Specs[["Grid"]]) != length(Initial.Values)) {
Specs[["Grid"]] <- list(NULL)
for (i in 1:length(Initial.Values))
Specs[["Grid"]][[i]] <- seq(from=-0.1, to=0.1, len=5)
cat("\nGrid was misspecified and changed to default.\n",
file=LogFile, append=TRUE)}
}
else {
temp <- as.vector(Specs[["Grid"]])
Specs[["Grid"]] <- list(NULL)
for (i in 1:length(Initial.Values))
Specs[["Grid"]][[i]] <- temp}
if(!is.null(Specs[["dparm"]])) {
Specs[["dparm"]] <- unique(interval(round(Specs[["dparm"]]), 1,
length(Initial.Values)))
Specs[["dparm"]] <- Specs[["dparm"]][order(Specs[["dparm"]])]}
else Specs[["dparm"]] <- 0
Specs[["CPUs"]] <- max(1, abs(round(Specs[["CPUs"]])))
}
else if(Algorithm == "Gibbs") {
Algorithm <- "Gibbs Sampler"
if(missing(Specs) | is.null(Specs)) {
cat("\nSpecs missing or null, Algorithm changed to MWG.\n",
file=LogFile, append=TRUE)
Algorithm == "MWG"
Specs <- NULL
}
else {
if(!is.list(Specs))
stop("The Specs argument is not a list.",
file=LogFile, append=TRUE)
if(!all(c("FC","MWG") %in% names(Specs)))
stop("The Specs argument is incorrect",
file=LogFile, append=TRUE)
if(!is.function(Specs[["FC"]]))
stop("FC must be a function.", file=LogFile,
append=TRUE)
FCtest <- try(Specs[["FC"]](Initial.Values, Data),
silent=TRUE)
if(inherits(FCtest, "try-error"))
stop("Error in FC.", file=LogFile, append=TRUE)
if(!is.vector(FCtest))
stop("FC must return a vector.", file=LogFile,
append=TRUE)
if(length(FCtest) != length(Initial.Values))
stop("Length of parameters to/from FC differs.",
file=LogFile, append=TRUE)
if(!is.null(Specs[["MWG"]]) &
!is.vector(Specs[["MWG"]]) &
!is.numeric(Specs[["MWG"]]))
stop("MWG must be a numeric vector.",
file=LogFile, append=TRUE)}
}
else if(Algorithm == "HARM") {
Algorithm <- "Hit-And-Run Metropolis"
if(missing(Specs) | is.null(Specs))
Specs <- list(alpha.star=NA, B=NULL)
else {
if(!is.list(Specs))
stop("The Specs argument is not a list.",
file=LogFile, append=TRUE)
if(!all(c("alpha.star","B") %in% names(Specs)))
stop("The Specs argument is incorrect",
file=LogFile, append=TRUE)
Specs[["alpha.star"]] <- abs(as.vector(Specs[["alpha.star"]])[1])
if(Specs[["alpha.star"]] <= 0 | Specs[["alpha.star"]] >= 1) {
cat("\nalpha.star not in (0,1), set to 0.234.\n",
file=LogFile, append=TRUE)
alpha.star <- 0.234}
if(is.na(Specs[["alpha.star"]]) & !is.null(Specs[["B"]]))
alpha.star <- 0.234}
if(is.null(Specs[["B"]])) Specs[["B"]] <- list()
}
else if(Algorithm == "HMC") {
Algorithm <- "Hamiltonian Monte Carlo"
if(missing(Specs) | is.null(Specs))
Specs=list(epsilon=rep(1/length(Initial.Values),
length(Initial.Values)), L=2, m=rep(1,
length(Initial.Values)))
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("epsilon","L","m") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["epsilon"]] <- abs(Specs[["epsilon"]])
if(length(Specs[["epsilon"]]) != length(Initial.Values)) {
Specs[["epsilon"]] <- rep(Specs[["epsilon"]][1],
length(Initial.Values))}
Specs[["L"]] <- abs(round(Specs[["L"]]))
if(Specs[["L"]] < 1) {
cat("\nL has been increased to its minimum: 1.\n",
file=LogFile, append=TRUE)
L <- 1}
if(is.null(Specs[["m"]]))
Specs[["m"]] <- diag(length(Initial.Values))
}
else if(Algorithm == "HMCDA") {
Algorithm <- "Hamiltonian Monte Carlo with Dual-Averaging"
if(missing(Specs))
stop("The Specs argument is required.", file=LogFile,
append=TRUE)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("A","delta","epsilon","Lmax","lambda") %in%
names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["A"]] <- min(round(abs(Specs[["A"]])), Iterations)
Specs[["delta"]] <- max(min(abs(Specs[["delta"]]), 1),
1/Iterations)
if(!is.null(Specs[["epsilon"]]))
Specs[["epsilon"]] <- abs(Specs[["epsilon"]][1])
Specs[["Lmax"]] <- abs(round(Specs[["Lmax"]]))
Specs[["lambda"]] <- abs(Specs[["lambda"]])
if(!is.null(Specs[["epsilon"]]))
if(Specs[["lambda"]] < Specs[["epsilon"]])
Specs[["lambda"]] <- Specs[["epsilon"]]
}
else if(Algorithm == "IM") {
Algorithm <- "Independence Metropolis"
if(missing(Specs))
stop("The Specs argument is required.", file=LogFile,
append=TRUE)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("mu") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["mu"]] <- as.vector(Specs[["mu"]])
if(length(Specs[["mu"]]) != length(Initial.Values))
stop("length(mu) != length(Initial.Values).",
file=LogFile, append=TRUE)
}
else if(Algorithm == "INCA") {
Algorithm <- "Interchain Adaptation"
if(missing(Specs) | is.null(Specs))
Specs=list(Adaptive=floor(Iterations/2),
Periodicity=1)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("Adaptive","Periodicity") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
}
else if(Algorithm == "MALA") {
Algorithm <- "Metropolis-Adjusted Langevin Algorithm"
if(missing(Specs) | is.null(Specs))
Specs=list(A=1e7, alpha.star=0.574, delta=1,
epsilon=c(1e-6,1e-7))
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("A","alpha.star","gamma","delta","epsilon") %in%
names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["A"]] <- abs(Specs[["A"]][1])
Specs[["gamma"]] <- min(max(Specs[["gamma"]][1], 0),
Iterations)
Specs[["delta"]] <- min(max(Specs[["delta"]][1], 1e-10),
1000)
Specs[["epsilon"]] <- abs(Specs[["epsilon"]][1:2])
}
else if(Algorithm == "MCMCMC") {
Algorithm <- "Metropolis-Coupled Markov Chain Monte Carlo"
if(missing(Specs) | is.null(Specs))
Specs <- list(lambda=1, CPUs=1, Packages=NULL,
Dyn.libs=NULL)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("lambda","CPUs","Packages","Dyn.libs") %in%
names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["lambda"]] <- abs(Specs[["lambda"]])
if(Specs[["CPUs"]] <= 1)
cat("\nCPUs must be at least 2. Attempting 2 CPUs...\n",
file=LogFile, append=TRUE)
Specs[["CPUs"]] <- max(2, abs(round(Specs[["CPUs"]])))
}
else if(Algorithm == "MTM") {
Algorithm <- "Multiple-Try Metropolis"
if(missing(Specs) | is.null(Specs))
Specs <- list(K=4, CPUs=1, Packages=NULL, Dyn.libs=NULL)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("K","CPUs","Packages","Dyn.libs") %in%
names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["K"]] <- abs(round(Specs[["K"]]))
if(Specs[["CPUs"]] < 1)
cat("\nCPUs must be at least 1.\n", file=LogFile,
append=TRUE)
Specs[["CPUs"]] <- max(1, abs(round(Specs[["CPUs"]])))
}
else if(Algorithm == "MWG") {
Algorithm <- "Metropolis-within-Gibbs"
if(missing(Specs) | is.null(Specs))
Specs <- list(B=NULL)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("B") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
}
else if(Algorithm == "NUTS") {
Algorithm <- "No-U-Turn Sampler"
if(missing(Specs))
stop("The Specs argument is required.", file=LogFile,
append=TRUE)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("A","delta","epsilon","Lmax") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["A"]] <- max(min(round(abs(Specs[["A"]])),
Iterations),1)
Specs[["delta"]] <- max(min(abs(Specs[["delta"]]),
1), 1/Iterations)
if(!is.null(Specs[["epsilon"]]))
Specs[["epsilon"]] <- abs(Specs[["epsilon"]][1])
Specs[["Lmax"]] <- round(abs(Specs[["Lmax"]]))
}
else if(Algorithm == "OHSS") {
Algorithm <- "Oblique Hyperrectangle Slice Sampler"
if(missing(Specs) | is.null(Specs))
Specs <- list(A=Iterations+1, n=0)
else {
if(!is.list(Specs))
stop("The Specs argument is not a list.",
file=LogFile, append=TRUE)
if(!all(c("A", "n") %in% names(Specs)))
stop("The Specs argument is incorrect.",
file=LogFile, append=TRUE)
Specs[["A"]] <- round(abs(Specs[["A"]]))
Specs[["n"]] <- round(abs(Specs[["n"]]))}
}
else if(Algorithm == "pCN") {
Algorithm <- "Preconditioned Crank-Nicolson"
if(missing(Specs) | is.null(Specs))
Specs <- list(beta=0.01)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("beta") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["beta"]] <- max(min(Specs[["beta"]], 1), 0)
}
else if(Algorithm == "RAM") {
Algorithm <- "Robust Adaptive Metropolis"
if(missing(Specs) | is.null(Specs))
Specs=list(alpha.star=0.234, B=NULL, Dist="N",
gamma=0.66, n=0)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("alpha.star","B","Dist","gamma","n") %in%
names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["alpha.star"]] <- Specs[["alpha.star"]][1]
if(Specs[["alpha.star"]] <= 0 ||
Specs[["alpha.star"]] >= 1) {
cat("\nalpha.star not in (0,1). Changed to 0.234.\n",
file=LogFile, append=TRUE)
Specs[["alpha.star"]] <- 0.234}
if(!is.null(Specs[["B"]])) {
if(is.null(Covar)) {
Covar <- list(NULL)
for (b in 1:length(Specs[["B"]])) {
Covar[[b]] <- diag(length(Specs[["B"]][[b]]))}}}
if(Specs[["Dist"]] != "t" & Specs[["Dist"]] != "N") {
cat("\nDist was not t or N, and changed to N.\n",
file=LogFile, append=TRUE)
Specs[["Dist"]] <- "N"}
Specs[["gamma"]] <- Specs[["gamma"]][1]
if(Specs[["gamma"]] <= 0.5 || Specs[["gamma"]] > 1) {
cat("\ngamma not in (0.5,1]. Changed to 0.66.\n",
file=LogFile, append=TRUE)
Specs[["gamma"]] <- 0.66}
Specs[["n"]] <- abs(Specs[["n"]][1])
}
else if(Algorithm == "RDMH") {
Algorithm <- "Random Dive Metropolis-Hastings"
Specs <- NULL
}
else if(Algorithm == "Refractive") {
Algorithm <- "Refractive Sampler"
if(missing(Specs) | is.null(Specs))
Specs=list(Adaptive=1, m=2, w=0.1, r=1.3)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("Adaptive","m","w","r") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["m"]] <- abs(round(Specs[["m"]]))
if(length(Specs[["m"]]) != 1)
Specs[["m"]] <- Specs[["m"]][1]
if(Specs[["m"]] < 2) {
cat("\nm was misspecified, and is replaced with 2.\n",
file=LogFile, append=TRUE)
Specs[["m"]] <- 2}
Specs[["w"]] <- abs(Specs[["w"]])
if(length(Specs[["w"]]) != 1)
Specs[["w"]] <- Specs[["w"]][1]
Specs[["r"]] <- abs(Specs[["r"]])
if(length(Specs[["r"]]) != 1)
Specs[["r"]] <- Specs[["r"]][1]
}
else if(Algorithm == "RJ") {
Algorithm <- "Reversible-Jump"
if(missing(Specs))
stop("The Specs argument is required.", file=LogFile,
append=TRUE)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("bin.n","bin.p","parm.p","selectable","selected") %in%
names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["bin.n"]] <- round(Specs[["bin.n"]])
if(Specs[["bin.n"]] > length(Initial.Values))
Specs[["bin.n"]] <- length(Initial.Values)
if(Specs[["bin.n"]] < 1) Specs[["bin.n"]] <- 1
if(Specs[["bin.p"]] < 0 | Specs[["bin.p"]] > 1) {
Specs[["bin.p"]] <- interval(Specs[["bin.p"]],
0, 1, reflect=FALSE)
cat("\nbin.p must be in [0,1]. It's now",
round(Specs[["bin.p"]],5), "\n", file=LogFile,
append=TRUE)}
Specs[["parm.p"]] <- as.vector(Specs[["parm.p"]])
if(length(Specs[["parm.p"]]) != length(Initial.Values)) {
Specs[["parm.p"]] <- rep(Specs[["parm.p"]][1],
length(Initial.Values))
cat("\nparm.p now has the correct length, all equal to parm.p[1].\n",
file=LogFile, append=TRUE)}
Specs[["selectable"]] <- as.vector(Specs[["selectable"]])
if(length(Specs[["selectable"]]) != length(Initial.Values)) {
Specs[["selectable"]] <- rep(1, length(Initial.Values))
cat("\nselectable now has the correct length, all set to 1.\n",
file=LogFile, append=TRUE)}
Specs[["selected"]] <- as.vector(Specs[["selected"]])
if(length(Specs[["selected"]]) != length(Initial.Values)) {
Specs[["selected"]] <- rep(1, length(Initial.Values))
cat("\nselected now has the correct length, all set to 1.\n",
file=LogFile, append=TRUE)}
}
else if(Algorithm == "RSS") {
Algorithm <- "Reflective Slice Sampler"
if(missing(Specs))
stop("The Specs argument is required.", file=LogFile,
append=TRUE)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("m","w") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["m"]] <- abs(round(Specs[["m"]]))
if(length(Specs[["m"]]) != 1)
Specs[["m"]] <- Specs[["m"]][1]
if(Specs[["m"]] < 1) {
cat("\nm was misspecified, and is replaced with 1.\n",
file=LogFile, append=TRUE)
Specs[["m"]] <- 1}
Specs[["w"]] <- abs(Specs[["w"]])
if(length(Specs[["w"]]) != length(Initial.Values))
Specs[["w"]] <- rep(Specs[["w"]],
len=length(Initial.Values))
if(any(Specs[["w"]] <= 0)) {
cat("\nw was misspecified, and is replaced with 1.\n",
file=LogFile, append=TRUE)
Specs[["w"]][which(Specs[["w"]] <= 0)] <- 1}
}
else if(Algorithm == "RWM") {
Algorithm <- "Random-Walk Metropolis"
if(missing(Specs) | is.null(Specs))
Specs <- list(B=list())
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("B") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
}
else if(Algorithm == "SAMWG") {
Algorithm <- "Sequential Adaptive Metropolis-within-Gibbs"
if(missing(Specs))
stop("The Specs argument is required.", file=LogFile,
append=TRUE)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("Dyn","Periodicity") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
if(!is.matrix(Specs[["Dyn"]]))
Specs[["Dyn"]] <- as.matrix(Specs[["Dyn"]])
}
else if(Algorithm == "SGLD") {
Algorithm <- "Stochastic Gradient Langevin Dynamics"
if(missing(Specs))
stop("The Specs argument is required.", file=LogFile,
append=TRUE)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("epsilon","file","Nr","Nc","size") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["Nr"]] <- abs(round(Specs[["Nr"]]))
Specs[["Nc"]] <- abs(round(Specs[["Nc"]]))
Specs[["size"]] <- abs(round(Specs[["size"]]))
if(Specs[["size"]] >= Specs[["Nr"]])
stop("size must be less than nr.")
if(any(is.na(Specs[["epsilon"]])))
Specs[["epsilon"]] <- 1 / Specs[["Nr"]]
if(length(Specs[["epsilon"]]) == 1)
Specs[["epsilon"]] <- rep(Specs[["epsilon"]],
Iterations)
if(length(Specs[["epsilon"]]) > Iterations)
Specs[["epsilon"]] <- Specs[["epsilon"]][1:Iterations]
}
else if(Algorithm == "Slice") {
Algorithm <- "Slice Sampler"
if(missing(Specs) | is.null(Specs))
Specs <- list(B=NULL, Bounds=c(-Inf,Inf), m=Inf,
Type="Continuous", w=1)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("B","Bounds","m","Type","w") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
if(is.null(Specs[["B"]])) {
B <- list()
B[[1]] <- 1:length(Initial.Values)
Bounds <- list()
Bounds[[1]] <- Specs[["Bounds"]]
m <- list()
m[[1]] <- Specs[["m"]]
Type <- list()
Type[[1]] <- Specs[["Type"]]
w <- list()
w[[1]] <- Specs[["w"]]
Specs[["B"]] <- B
Specs[["Bounds"]] <- Bounds
Specs[["m"]] <- m
Specs[["Type"]] <- Type
Specs[["w"]] <- w}
if(!is.list(Specs[["B"]]))
stop("B must be a list.", file=LogFile, append=TRUE)
if(!is.list(Specs[["Bounds"]])) {
Bounds <- list()
for (i in 1:length(Initial.Values))
Bounds[[i]] <- Specs[["Bounds"]]
Specs[["Bounds"]] <- Bounds}
if(!is.list(Specs[["m"]])) {
Specs[["m"]] <- abs(Specs[["m"]][1])
m <- list()
for (i in 1:length(Initial.Values))
m[[i]] <- Specs[["m"]]
Specs[["m"]] <- m}
if(!is.list(Specs[["Type"]])) {
Specs[["Type"]] <- Specs[["Type"]][1]
if(!Specs[["Type"]] %in% c("Continuous", "Nominal",
"Ordinal"))
Specs[["Type"]] <- "Continuous"
Type <- list()
for (i in 1:length(Initial.Values))
Type[[i]] <- Specs[["Type"]]
Specs[["Type"]] <- Type}
if(!is.list(Specs[["w"]])) {
Specs[["w"]] <- abs(Specs[["w"]][1])
w <- list()
for (i in 1:length(Initial.Values))
w[[i]] <- Specs[["w"]]
Specs[["w"]] <- w}
}
else if(Algorithm == "SMWG") {
Algorithm <- "Sequential Metropolis-within-Gibbs"
if(missing(Specs))
stop("The Specs argument is required.", file=LogFile,
append=TRUE)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("Dyn") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
if(!is.matrix(Specs[["Dyn"]]))
Specs[["Dyn"]] <- as.matrix(Specs[["Dyn"]])
}
else if(Algorithm == "THMC") {
Algorithm <- "Tempered Hamiltonian Monte Carlo"
if(missing(Specs))
stop("The Specs argument is required.", file=LogFile,
append=TRUE)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("epsilon","L","m", "Temperature") %in%
names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["epsilon"]] <- as.vector(abs(Specs[["epsilon"]]))
if(length(Specs[["epsilon"]]) != length(Initial.Values)) {
cat("\nLength of epsilon is incorrect.\n", file=LogFile,
append=TRUE)
Specs[["epsilon"]] <- rep(Specs[["epsilon"]][1],
length(Initial.Values))}
Specs[["L"]] <- abs(round(Specs[["L"]]))
if(Specs[["L"]] < 2) {
cat("\nL has been increased to its minimum: 2.\n",
file=LogFile, append=TRUE)
Specs[["L"]] <- 2}
if(is.null(Specs[["m"]]))
Specs[["m"]] <- diag(length(Initial.Values))
if(Specs[["Temperature"]] <= 0) {
cat("\nTemperature is incorrect, changed to 1.\n",
file=LogFile, append=TRUE)
Specs[["Temperature"]] <- 1}
}
else if(Algorithm == "twalk") {
Algorithm <- "t-walk"
if(missing(Specs) | is.null(Specs))
Specs=list(SIV=NULL, n1=4, at=6, aw=1.5)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("SIV","n1","at","aw") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
if(is.null(Specs[["SIV"]])) {
cat("\nGenerating SIV...\n", file=LogFile, append=TRUE)
if(!is.null(Data[["PGF"]]))
Specs[["SIV"]] <- GIV(Model, Data, PGF=TRUE)
else Specs[["SIV"]] <- GIV(Model, Data)}
if(!identical(length(Specs[["SIV"]]),
length(Initial.Values))) {
cat("\nGenerating SIV due to length mismatch.\n",
file=LogFile, append=TRUE)
if(!is.null(Data[["PGF"]]))
Specs[["SIV"]] <- GIV(Model, Data, PGF=TRUE)
else Specs[["SIV"]] <- GIV(Model, Data)}
Mo2 <- Model(Specs[["SIV"]], Data)
if(!is.finite(Mo2[["LP"]]))
stop("SIV results in a non-finite posterior.",
file=LogFile, append=TRUE)
if(!is.finite(Mo2[["Dev"]]))
stop("SIV results in a non-finite deviance.",
file=LogFile, append=TRUE)
Specs[["SIV"]] <- Mo2[["parm"]]
rm(Mo2)
if(Specs[["n1"]] < 1) {
cat("\nn1 must be at least 1. Changed to 4.\n",
file=LogFile, append=TRUE)
Specs[["n1"]] <- 4}
if(Specs[["at"]] <= 0) {
cat("\nat must be positive. Changed to 6.\n",
file=LogFile, append=TRUE)
Specs[["at"]] <- 6}
if(Specs[["aw"]] <= 0) {
cat("\naw must be positive. Changed to 1.5.\n",
file=LogFile, append=TRUE)
Specs[["aw"]] <- 1.5}
}
else if(Algorithm == "UESS") {
Algorithm = "Univariate Eigenvector Slice Sampler"
if(missing(Specs) | is.null(Specs))
Specs=list(A=Inf, B=NULL, m=100, n=0)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("A","B","m","n") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["A"]] <- abs(round(Specs[["A"]]))
if(!is.null(Specs[["B"]])) {
if(is.null(Covar)) {
Covar <- list(NULL)
for (b in 1:length(Specs[["B"]])) {
Covar[[b]] <- diag(length(Specs[["B"]][[b]]))}}}
Specs[["m"]] <- abs(round(Specs[["m"]]))
Specs[["n"]] <- abs(round(Specs[["n"]]))
}
else if(Algorithm == "USAMWG") {
Algorithm <- "Updating Sequential Adaptive Metropolis-within-Gibbs"
if(missing(Specs))
stop("The Specs argument is required.", file=LogFile,
append=TRUE)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("Dyn","Periodicity","Fit","Begin") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
if(!is.matrix(Specs[["Dyn"]]))
Specs[["Dyn"]] <- as.matrix(Specs[["Dyn"]])
}
else if(Algorithm == "USMWG") {
Algorithm <- "Updating Sequential Metropolis-within-Gibbs"
if(missing(Specs))
stop("The Specs argument is required.", file=LogFile,
append=TRUE)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("Dyn","Fit","Begin") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
if(!is.matrix(Specs[["Dyn"]]))
Specs[["Dyn"]] <- as.matrix(Specs[["Dyn"]])
}
}
else {cat("Unknown algorithm has been changed to Metropolis-within-Gibbs.\n",
file=LogFile, append=TRUE)
Algorithm <- "Metropolis-within-Gibbs"
Specs <- NULL}
if(!is.null(Specs[["Adaptive"]])) {
Specs[["Adaptive"]] <- abs(Specs[["Adaptive"]])
if({Specs[["Adaptive"]] < 1} |
{Specs[["Adaptive"]] > Iterations})
Specs[["Adaptive"]] <- Iterations + 1}
if(!is.null(Specs[["B"]])) {
if(length(Specs[["B"]]) > 0) {
if(any(!is.finite(unlist(Specs[["B"]]))))
stop("Non-finite values in specification B.",
file=LogFile, append=TRUE)
if(!identical(as.vector(as.numeric(unlist(Specs[["B"]]))),
round(abs(as.vector(as.numeric(unlist(Specs[["B"]])))))))
stop("Specification B must have only positive integers.",
file=LogFile, append=TRUE)
if(!identical(length(unlist(Specs[["B"]])),
length(Initial.Values)))
stop("Non-integer values in specification B.",
file=LogFile, append=TRUE)}}
if(!is.null(Specs[["Periodicity"]])) {
Specs[["Periodicity"]] <- abs(Specs[["Periodicity"]])
if({Specs[["Periodicity"]] < 1} |
{Specs[["Periodicity"]] > Iterations})
Specs[["Periodicity"]] <- Iterations + 1}
Mo0 <- Model(Initial.Values, Data)
if(!is.list(Mo0))
stop("Model must return a list.", file=LogFile, append=TRUE)
if(length(Mo0) != 5)
stop("Model must return five components.", file=LogFile,
append=TRUE)
if(any(names(Mo0) != c("LP","Dev","Monitor","yhat","parm")))
stop("Name mismatch in returned list of Model function.",
file=LogFile, append=TRUE)
if(length(Mo0[["LP"]]) > 1)
stop("Multiple joint posteriors exist!", file=LogFile,
append=TRUE)
if(!identical(length(Mo0[["Monitor"]]), length(Data[["mon.names"]])))
stop("Length of mon.names differs from length of monitors.",
file=LogFile, append=TRUE)
as.character.function <- function(x, ... )
{
fname <- deparse(substitute(x))
f <- match.fun(x)
out <- c(sprintf('"%s" <- ', fname), capture.output(f))
if(grepl("^[<]", tail(out, 1))) out <- head(out, -1)
return(out)
}
acount <- length(grep("apply", as.character.function(Model)))
if(acount > 0) {
cat("Suggestion:", acount, "possible instance(s) of apply functions\n",
file=LogFile, append=TRUE)
cat(" were found in the Model specification. Iteration speed will\n",
file=LogFile, append=TRUE)
cat(" increase if apply functions are vectorized in R or coded\n",
file=LogFile, append=TRUE)
cat(" in a faster language such as C++ via the Rcpp package.\n",
file=LogFile, append=TRUE)}
acount <- length(grep("for", as.character.function(Model)))
if(acount > 0) {
cat("Suggestion:", acount, "possible instance(s) of for loops\n",
file=LogFile, append=TRUE)
cat(" were found in the Model specification. Iteration speed will\n",
file=LogFile, append=TRUE)
cat(" increase if for loops are vectorized in R or coded in a\n",
file=LogFile, append=TRUE)
cat(" faster language such as C++ via the Rcpp package.\n",
file=LogFile, append=TRUE)}
rm(acount)
if(!identical(Model(Mo0[["parm"]], Data)[["LP"]], Mo0[["LP"]])) {
cat("WARNING: LP differs when initial values are held constant.\n",
file=LogFile, append=TRUE)
cat(" Derivatives may be problematic if used.\n",
file=LogFile, append=TRUE)}
######################### Initial Settings #########################
Acceptance <- 0
if(!is.finite(Mo0[["LP"]])) {
cat("Generating initial values due to a non-finite posterior.\n",
file=LogFile, append=TRUE)
if(!is.null(Data[["PGF"]]))
Initial.Values <- GIV(Model, Data, PGF=TRUE)
else Initial.Values <- GIV(Model, Data)
Mo0 <- Model(Initial.Values, Data)
}
if(is.infinite(Mo0[["LP"]]))
stop("The posterior is infinite!", file=LogFile, append=TRUE)
if(is.nan(Mo0[["LP"]]))
stop("The posterior is not a number!", file=LogFile, append=TRUE)
if(is.na(Mo0[["Dev"]]))
stop("The deviance is a missing value!", file=LogFile,
append=TRUE)
if(is.infinite(Mo0[["Dev"]]))
stop("The deviance is infinite!", file=LogFile, append=TRUE)
if(is.nan(Mo0[["Dev"]]))
stop("The deviance is not a number!", file=LogFile, append=TRUE)
if(any(is.na(Mo0[["Monitor"]])))
stop("Monitored variable(s) have a missing value!",
file=LogFile, append=TRUE)
if(any(is.infinite(Mo0[["Monitor"]])))
stop("Monitored variable(s) have an infinite value!",
file=LogFile, append=TRUE)
if(any(is.nan(Mo0[["Monitor"]])))
stop("Monitored variable(s) include a value that is not a number!",
file=LogFile, append=TRUE)
if(Algorithm == "t-walk") {
Mo0 <- Model(Initial.Values, Data)
if(any(Mo0[["parm"]] == Specs[["SIV"]]))
stop("Initial.Values and SIV not unique after model update.",
file=LogFile, append=TRUE)}
###################### Laplace Approximation #######################
### Sample Size of Data
if(!is.null(Data[["n"]])) if(length(Data[["n"]]) == 1) N <- Data[["n"]]
if(!is.null(Data[["N"]])) if(length(Data[["N"]]) == 1) N <- Data[["N"]]
if(!is.null(Data[["y"]])) N <- nrow(matrix(Data[["y"]]))
if(!is.null(Data[["Y"]])) N <- nrow(matrix(Data[["Y"]]))
if(is.null(N))
stop("Sample size of Data not found in n, N, y, or Y.",
file=LogFile, append=TRUE)
if({all(Initial.Values == 0)} & {N >= 5*length(Initial.Values)}) {
cat("\nLaplace Approximation will be used on initial values.\n",
file=LogFile, append=TRUE)
LIV <- length(Initial.Values)
Fit.LA <- LaplaceApproximation(Model, Initial.Values, Data,
Method="SPG", CovEst="Identity", sir=FALSE)
Covar <- 2.381204 * 2.381204 / length(Initial.Values) *
Fit.LA$Covar
Initial.Values <- Fit.LA$Summary1[1:length(Initial.Values),1]
cat("The covariance matrix from Laplace Approximation has been scaled\n",
file=LogFile, append=TRUE)
cat("for Laplace's Demon, and the posterior modes are now the initial\n",
file=LogFile, append=TRUE)
cat("values for Laplace's Demon.\n\n", file=LogFile, append=TRUE)}
######################### Prepare for MCMC #########################
Mo0 <- Model(Initial.Values, Data)
Dev <- matrix(Mo0[["Dev"]], floor(Iterations/Thinning)+1, 1)
Mon <- matrix(Mo0[["Monitor"]], floor(Iterations/Thinning)+1,
length(Mo0[["Monitor"]]), byrow=TRUE)
LIV <- length(Initial.Values)
thinned <- matrix(Initial.Values, floor(Iterations/Thinning)+1,
length(Initial.Values), byrow=TRUE)
ScaleF <- 2.381204 * 2.381204 / LIV
if(Algorithm %in% c("Adaptive Metropolis",
"Adaptive-Mixture Metropolis",
"Delayed Rejection Adaptive Metropolis",
"Delayed Rejection Metropolis", "Interchain Adaptation",
"Metropolis-Coupled Markov Chain Monte Carlo",
"Random-Walk Metropolis")) {
### Algorithms that require both VarCov and tuning
if(is.list(Covar) & Algorithm != "Adaptive-Mixture Metropolis" &
Algorithm != "Random-Walk Metropolis") {
Covar <- NULL}
else if(is.matrix(Covar) & !is.list(Covar)) {
diag(Covar)[which(diag(Covar) < 1e-100)] <- 1e-100
tuning <- sqrt(diag(Covar))
VarCov <- Covar
}
else if(is.vector(Covar) & !is.list(Covar)) {
tuning <- abs(as.vector(Covar))
if(length(tuning) != LIV) tuning <- rep(ScaleF, LIV)
tuning[which(tuning < 1e-100)] <- 1e-100
VarCov <- matrix(0, LIV, LIV)
diag(VarCov) <- tuning
}
else if(is.null(Covar)) {
tuning <- rep(ScaleF, LIV)
VarCov <- matrix(0, LIV, LIV)
diag(VarCov) <- tuning
}
else if(is.list(Covar)) {
tuning <- Covar
for (i in 1:length(tuning)) {
tuning[[i]] <- sqrt(diag(tuning[[i]]))}
VarCov <- Covar}
if(is.matrix(VarCov) & !is.list(VarCov)) {
DiagCovar <- matrix(diag(VarCov), 1, LIV)}
else if(is.list(VarCov)) {
DiagCovar <- matrix(1, 1, LIV)
for (b in 1:length(Specs[["B"]])) {
DiagCovar[Specs[["B"]][[b]]] <- diag(VarCov[[b]])}}
}
else if(Algorithm %in% c("Adaptive Directional Metropolis-within-Gibbs",
"Automated Factor Slice Sampler",
"Elliptical Slice Sampler",
"Independence Metropolis",
"Metropolis-Adjusted Langevin Algorithm",
"Oblique Hyperrectangle Slice Sampler",
"Preconditioned Crank-Nicolson",
"Robust Adaptive Metropolis",
"Univariate Eigenvector Slice Sampler")) {
### Algorithms that require VarCov, but not tuning
if(is.list(Covar)) VarCov <- Covar
else if(is.matrix(Covar) & !is.list(Covar)) VarCov <- Covar
else if(is.vector(Covar) & !is.list(Covar)) {
VarCov <- matrix(0, LIV, LIV)
diag(VarCov) <- abs(as.vector(Covar))
diag(VarCov)[which(diag(VarCov) < 1e-100)] <- 1e-100
}
else if(is.null(Covar)) {
VarCov <- matrix(0, LIV, LIV)
diag(VarCov) <- rep(ScaleF, LIV)
}
else if(is.list(Covar)) VarCov <- Covar
if(is.matrix(VarCov) & !is.list(VarCov))
DiagCovar <- matrix(diag(VarCov), 1, LIV)
else if(is.list(VarCov)) {
DiagCovar <- matrix(1, 1, LIV)
for (b in 1:length(Specs[["B"]])) {
DiagCovar[Specs[["B"]][[b]]] <- diag(VarCov[[b]])}}
}
else if(Algorithm %in% c("Adaptive Griddy-Gibbs",
"Adaptive Metropolis-within-Gibbs",
"Gibbs Sampler",
"Metropolis-within-Gibbs",
"Multiple-Try Metropolis",
"Sequential Adaptive Metropolis-within-Gibbs",
"Sequential Metropolis-within-Gibbs",
"Updating Sequential Adaptive Metropolis-within-Gibbs",
"Updating Sequential Metropolis-within-Gibbs")) {
### Algorithms that do not require VarCov, but require tuning
if(is.list(Covar)) Covar <- NULL
else if(is.matrix(Covar) & !is.list(Covar)) {
tuning <- sqrt(diag(Covar))
tuning[which(tuning < 1e-100)] <- 1e-100
}
else if(is.vector(Covar) & !is.list(Covar)) {
tuning <- abs(as.vector(Covar))
if(length(tuning) != length(Initial.Values))
tuning <- rep(ScaleF, LIV)
tuning[which(tuning < 1e-100)] <- 1e-100
}
else if(is.null(Covar)) {
tuning <- rep(ScaleF, LIV)}
VarCov <- NULL
DiagCovar <- matrix(tuning, 1, LIV)
}
else {
### Algorithms that do not require VarCov or tuning
VarCov <- NULL
DiagCovar <- matrix(1, 1, LIV)
}
rm(Covar)
############################ Begin MCMC ############################
cat("Algorithm:", Algorithm, "\n", file=LogFile, append=TRUE)
cat("\nLaplace's Demon is beginning to update...\n", file=LogFile,
append=TRUE)
options(warn=2)
on.exit(options(warn=0))
if(Algorithm == "Adaptive Directional Metropolis-within-Gibbs") {
mcmc.out <- .mcmcadmg(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, VarCov, Debug, LogFile)}
else if(Algorithm == "Adaptive Griddy-Gibbs") {
mcmc.out <- .mcmcagg(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, tuning, Debug, LogFile)}
else if(Algorithm == "Adaptive Hamiltonian Monte Carlo") {
mcmc.out <- .mcmcahmc(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, Debug, LogFile)}
else if(Algorithm == "Affine-Invariant Ensemble Sampler") {
mcmc.out <- .mcmcaies(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, Debug, LogFile)}
else if(Algorithm == "Adaptive Metropolis") {
mcmc.out <- .mcmcam(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, tuning, VarCov, Debug, LogFile)}
else if(Algorithm == "Adaptive-Mixture Metropolis" & !is.list(VarCov)) {
mcmc.out <- .mcmcamm(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, tuning, VarCov, Debug, LogFile)}
else if(Algorithm == "Adaptive-Mixture Metropolis" & is.list(VarCov)) {
mcmc.out <- .mcmcamm.b(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, tuning, VarCov, Debug, LogFile)}
else if(Algorithm == "Adaptive Metropolis-within-Gibbs") {
mcmc.out <- .mcmcamwg(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, tuning, Debug, LogFile)}
else if(Algorithm == "Automated Factor Slice Sampler") {
mcmc.out <- .mcmcafss(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, VarCov, Debug, LogFile)}
else if(Algorithm == "Componentwise Hit-And-Run Metropolis") {
mcmc.out <- .mcmccharm(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, Debug, LogFile)}
else if(Algorithm == "Delayed Rejection Adaptive Metropolis") {
mcmc.out <- .mcmcdram(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, tuning, VarCov, Debug, LogFile)}
else if(Algorithm == "Delayed Rejection Metropolis") {
mcmc.out <- .mcmcdrm(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, tuning, VarCov, Debug, LogFile)}
else if(Algorithm == "Differential Evolution Markov Chain") {
mcmc.out <- .mcmcdemc(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, Debug, LogFile)}
else if(Algorithm == "Elliptical Slice Sampler") {
mcmc.out <- .mcmcess(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, VarCov, Debug, LogFile)}
else if(Algorithm == "Experimental") {
# mcmc.out <- .mcmcexperimental(Model, Data, Iterations, Status,
# Thinning, Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0,
# ScaleF, thinned, Debug, LogFile)}
stop("Experimental function not found.", file=LogFile,
append=TRUE)}
else if(Algorithm == "Gibbs Sampler") {
mcmc.out <- .mcmcgibbs(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, tuning, Debug, LogFile)}
else if(Algorithm == "Griddy-Gibbs") {
mcmc.out <- .mcmcgg(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, Debug, LogFile)}
else if(Algorithm == "Hamiltonian Monte Carlo") {
mcmc.out <- .mcmchmc(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, VarCov, Debug, LogFile)}
else if(Algorithm == "Hamiltonian Monte Carlo with Dual-Averaging") {
mcmc.out <- .mcmchmcda(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, Debug, LogFile)}
else if(Algorithm == "Hit-And-Run Metropolis") {
mcmc.out <- .mcmcharm(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, Debug, LogFile)}
else if(Algorithm == "Independence Metropolis") {
mcmc.out <- .mcmcim(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, VarCov, Debug, LogFile)}
else if(Algorithm == "Interchain Adaptation") {
mcmc.out <- .mcmcinca(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, tuning, VarCov, Debug, LogFile)}
else if(Algorithm == "Metropolis-Adjusted Langevin Algorithm") {
mcmc.out <- .mcmcmala(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, VarCov, Debug, LogFile)}
else if(Algorithm == "Metropolis-Coupled Markov Chain Monte Carlo") {
mcmc.out <- .mcmcmcmcmc(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, tuning, VarCov, Debug, LogFile)}
else if(Algorithm == "Multiple-Try Metropolis") {
mcmc.out <- .mcmcmtm(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, thinned,
tuning, Debug, LogFile)}
else if(Algorithm == "Metropolis-within-Gibbs") {
mcmc.out <- .mcmcmwg(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, tuning, Debug, LogFile)}
else if(Algorithm == "No-U-Turn Sampler") {
mcmc.out <- .mcmcnuts(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, Debug, LogFile)}
else if(Algorithm == "Oblique Hyperrectangle Slice Sampler") {
mcmc.out <- .mcmcohss(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, VarCov, Debug, LogFile)}
else if(Algorithm == "Preconditioned Crank-Nicolson") {
mcmc.out <- .mcmcpcn(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, VarCov, Debug, LogFile)}
else if(Algorithm == "Random Dive Metropolis-Hastings") {
mcmc.out <- .mcmcrdmh(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, Debug, LogFile)}
else if(Algorithm == "Random-Walk Metropolis") {
mcmc.out <- .mcmcrwm(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, tuning, VarCov, Debug, LogFile)}
else if(Algorithm == "Refractive Sampler") {
mcmc.out <- .mcmcrefractive(Model, Data, Iterations, Status,
Thinning, Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0,
thinned, Debug, LogFile)}
else if(Algorithm == "Reflective Slice Sampler") {
mcmc.out <- .mcmcrss(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, thinned,
Debug, LogFile)}
else if(Algorithm == "Reversible-Jump") {
mcmc.out <- .mcmcrj(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, Debug, LogFile)}
else if(Algorithm == "Robust Adaptive Metropolis") {
mcmc.out <- .mcmcram(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, VarCov, Debug, LogFile)}
else if(Algorithm == "Sequential Adaptive Metropolis-within-Gibbs") {
mcmc.out <- .mcmcsamwg(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, tuning, parm.names=Data[["parm.names"]], Debug,
LogFile)}
else if(Algorithm == "Sequential Metropolis-within-Gibbs") {
mcmc.out <- .mcmcsmwg(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, tuning, parm.names=Data[["parm.names"]], Debug,
LogFile)}
else if(Algorithm == "Stochastic Gradient Langevin Dynamics") {
mcmc.out <- .mcmcsgld(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, Debug, LogFile)}
else if(Algorithm == "Slice Sampler") {
mcmc.out <- .mcmcslice(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, Debug, LogFile)}
else if(Algorithm == "Tempered Hamiltonian Monte Carlo") {
mcmc.out <- .mcmcthmc(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, Debug, LogFile)}
else if(Algorithm == "t-walk") {
mcmc.out <- .mcmctwalk(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, Debug, LogFile)}
else if(Algorithm == "Univariate Eigenvector Slice Sampler") {
mcmc.out <- .mcmcuess(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, VarCov, Debug, LogFile)}
else if(Algorithm == "Updating Sequential Adaptive Metropolis-within-Gibbs") {
mcmc.out <- .mcmcusamwg(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, tuning, parm.names=Data[["parm.names"]], Debug,
LogFile)}
else if(Algorithm == "Updating Sequential Metropolis-within-Gibbs") {
mcmc.out <- .mcmcusmwg(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, tuning, parm.names=Data[["parm.names"]], Debug,
LogFile)}
else stop("The algorithm is unrecognized.", file=LogFile, append=TRUE)
options(warn=0)
######################### MCMC is Finished #########################
Acceptance <- mcmc.out$Acceptance
Dev <- mcmc.out$Dev
DiagCovar <- mcmc.out$DiagCovar
Mon <- mcmc.out$Mon
thinned <- mcmc.out$thinned
VarCov <- mcmc.out$VarCov
remove(mcmc.out)
rownames(DiagCovar) <- NULL
colnames(DiagCovar) <- Data[["parm.names"]]
thinned <- matrix(thinned[-1,], nrow(thinned)-1, ncol(thinned))
Dev <- matrix(Dev[-1,], nrow(Dev)-1, 1)
Mon <- matrix(Mon[-1,], nrow(Mon)-1, ncol(Mon))
if(is.matrix(VarCov) & !is.list(VarCov)) {
colnames(VarCov) <- rownames(VarCov) <- Data[["parm.names"]]}
else if(is.vector(VarCov) & !is.list(VarCov)) {
names(VarCov) <- Data[["parm.names"]]}
thinned.rows <- nrow(thinned)
### Warnings (After Updating)
if(any(Acceptance == 0))
cat("\nWARNING: All proposals were rejected.\n", file=LogFile,
append=TRUE)
### Real Values
thinned[which(!is.finite(thinned))] <- 0
Dev[which(!is.finite(Dev))] <- 0
Mon[which(!is.finite(Mon))] <- 0
### Assess Stationarity
cat("\nAssessing Stationarity\n", file=LogFile, append=TRUE)
if(thinned.rows %% 10 == 0) thinned2 <- thinned
if(thinned.rows %% 10 != 0) thinned2 <- thinned[1:(10*trunc(thinned.rows/10)),]
HD <- BMK.Diagnostic(thinned2, batches=10)
Ind <- 1 * (HD > 0.5)
BurnIn <- thinned.rows
batch.list <- seq(from=1, to=nrow(thinned2), by=floor(nrow(thinned2)/10))
for (i in 1:9) {
if(sum(Ind[,i:9]) == 0) {
BurnIn <- batch.list[i] - 1
break}}
Stat.at <- BurnIn + 1
rm(batch.list, HD, Ind, thinned2)
### Assess Thinning and ESS Size for all parameter samples
cat("Assessing Thinning and ESS\n", file=LogFile, append=TRUE)
acf.rows <- trunc(10*log10(thinned.rows))
acf.temp <- matrix(1, acf.rows, LIV)
ESS1 <- Rec.Thin <- rep(1, LIV)
for (j in 1:LIV) {
temp0 <- acf(thinned[,j], lag.max=acf.rows, plot=FALSE)
if(length(temp0$acf[-1,1,1]) == acf.rows)
acf.temp[,j] <- abs(temp0$acf[-1,1,1])
ESS1[j] <- ESS(thinned[,j])
Rec.Thin[j] <- which(acf.temp[,j] <= 0.1)[1]*Thinning}
Rec.Thin[which(is.na(Rec.Thin))] <- nrow(acf.temp)
ESS3 <- ESS(Mon)
### Posterior Summary Table 1: All Thinned Samples
cat("Creating Summaries\n", file=LogFile, append=TRUE)
Num.Mon <- ncol(Mon)
Summ1 <- matrix(NA, LIV, 7, dimnames=list(Data[["parm.names"]],
c("Mean","SD","MCSE","ESS","LB","Median","UB")))
Summ1[,1] <- colMeans(thinned)
Summ1[,2] <- sqrt(.colVars(thinned))
Summ1[,3] <- 0
Summ1[,4] <- ESS1
rm(ESS1)
Summ1[,5] <- apply(thinned, 2, quantile, c(0.025), na.rm=TRUE)
Summ1[,6] <- apply(thinned, 2, quantile, c(0.500), na.rm=TRUE)
Summ1[,7] <- apply(thinned, 2, quantile, c(0.975), na.rm=TRUE)
for (i in 1:ncol(thinned)) {
temp <- try(MCSE(thinned[,i]), silent=!Debug[["DB.MCSE"]])
if(!inherits(temp, "try-error")) Summ1[i,3] <- temp
else {
if(Debug[["DB.MCSE"]] == TRUE)
cat("MCSE of", Data[["parm.names"]][i],
"failed in Summary1\n", file=LogFile, append=TRUE)
Summ1[i,3] <- MCSE(thinned[,i], method="sample.variance")}}
Deviance <- rep(NA,7)
Deviance[1] <- mean(Dev)
Deviance[2] <- sd(as.vector(Dev))
temp <- try(MCSE(as.vector(Dev)), silent=!Debug[["DB.MCSE"]])
if(inherits(temp, "try-error")) {
if(Debug[["DB.MCSE"]] == TRUE)
cat("MCSE of deviance failed in Summary1\n", file=LogFile,
append=TRUE)
temp <- MCSE(as.vector(Dev), method="sample.variance")}
Deviance[3] <- temp
Deviance[4] <- ESS(Dev)
Deviance[5] <- as.numeric(quantile(Dev, probs=0.025, na.rm=TRUE))
Deviance[6] <- as.numeric(quantile(Dev, probs=0.500, na.rm=TRUE))
Deviance[7] <- as.numeric(quantile(Dev, probs=0.975, na.rm=TRUE))
Summ1 <- rbind(Summ1, Deviance)
for (j in 1:Num.Mon) {
Monitor <- rep(NA,7)
Monitor[1] <- mean(Mon[,j])
Monitor[2] <- sd(as.vector(Mon[,j]))
temp <- try(MCSE(as.vector(Mon[,j])), silent=!Debug[["DB.MCSE"]])
if(inherits(temp, "try-error")) {
if(Debug[["DB.MCSE"]] == TRUE)
cat("MCSE of", Data[["mon.names"]][j],
"failed in Summary1\n", file=LogFile, append=TRUE)
temp <- MCSE(Mon[,j], method="sample.variance")}
Monitor[3] <- temp
Monitor[4] <- ESS3[j]
Monitor[5] <- as.numeric(quantile(Mon[,j], probs=0.025,
na.rm=TRUE))
Monitor[6] <- as.numeric(quantile(Mon[,j], probs=0.500,
na.rm=TRUE))
Monitor[7] <- as.numeric(quantile(Mon[,j], probs=0.975,
na.rm=TRUE))
Summ1 <- rbind(Summ1, Monitor)
rownames(Summ1)[nrow(Summ1)] <- Data[["mon.names"]][j]}
rm(ESS3)
### Posterior Summary Table 2: Stationary Samples
Summ2 <- matrix(NA, LIV, 7, dimnames=list(Data[["parm.names"]],
c("Mean","SD","MCSE","ESS","LB","Median","UB")))
if(Stat.at < thinned.rows) {
ESS6 <- ESS(Mon[Stat.at:thinned.rows,])
thinned2 <- matrix(thinned[Stat.at:thinned.rows,],
thinned.rows-Stat.at+1, ncol(thinned))
Dev2 <- matrix(Dev[Stat.at:thinned.rows,],
thinned.rows-Stat.at+1, ncol(Dev))
Mon2 <- matrix(Mon[Stat.at:thinned.rows,],
thinned.rows-Stat.at+1, ncol(Mon))
Summ2[,1] <- colMeans(thinned2)
Summ2[,2] <- sqrt(.colVars(thinned2))
Summ2[,3] <- 0
Summ2[,4] <- ESS(thinned[Stat.at:thinned.rows,])
Summ2[,5] <- apply(thinned2, 2, quantile, c(0.025), na.rm=TRUE)
Summ2[,6] <- apply(thinned2, 2, quantile, c(0.500), na.rm=TRUE)
Summ2[,7] <- apply(thinned2, 2, quantile, c(0.975), na.rm=TRUE)
for (i in 1:ncol(thinned2)) {
temp <- try(MCSE(thinned2[,i]), silent=!Debug[["DB.MCSE"]])
if(!inherits(temp, "try-error")) Summ2[i,3] <- temp
else {
if(Debug[["DB.MCSE"]] == TRUE)
cat("MCSE of", Data[["parm.names"]][i],
"failed in Summary2\n", file=LogFile,
append=TRUE)
Summ2[i,3] <- MCSE(thinned2[,i],
method="sample.variance")}}
Deviance <- rep(NA,7)
Deviance[1] <- mean(Dev2)
Deviance[2] <- sd(as.vector(Dev2))
temp <- try(MCSE(as.vector(Dev2)), silent=!Debug[["DB.MCSE"]])
if(inherits(temp, "try-error")) {
if(Debug[["DB.MCSE"]] == TRUE)
cat("MCSE of deviance failed in Summary2\n",
file=LogFile, append=TRUE)
temp <- MCSE(as.vector(Dev2), method="sample.variance")}
Deviance[3] <- temp
Deviance[4] <- ESS(Dev[Stat.at:thinned.rows,])
Deviance[5] <- as.numeric(quantile(Dev2, probs=0.025,
na.rm=TRUE))
Deviance[6] <- as.numeric(quantile(Dev2, probs=0.500,
na.rm=TRUE))
Deviance[7] <- as.numeric(quantile(Dev2, probs=0.975,
na.rm=TRUE))
Summ2 <- rbind(Summ2, Deviance)
for (j in 1:Num.Mon) {
Monitor <- rep(NA,7)
Monitor[1] <- mean(Mon2[,j])
Monitor[2] <- sd(as.vector(Mon2[,j]))
temp <- try(MCSE(as.vector(Mon2[,j])),
silent=!Debug[["DB.MCSE"]])
if(inherits(temp, "try-error")) {
if(Debug[["DB.MCSE"]] == TRUE)
cat("MCSE of", Data[["mon.names"]][j],
"failed in Summary2\n", file=LogFile,
append=TRUE)
temp <- MCSE(Mon2[,j], method="sample.variance")}
Monitor[3] <- temp
Monitor[4] <- ESS6[j]
Monitor[5] <- as.numeric(quantile(Mon2[,j],
probs=0.025, na.rm=TRUE))
Monitor[6] <- as.numeric(quantile(Mon2[,j],
probs=0.500, na.rm=TRUE))
Monitor[7] <- as.numeric(quantile(Mon2[,j],
probs=0.975, na.rm=TRUE))
Summ2 <- rbind(Summ2, Monitor)
rownames(Summ2)[nrow(Summ2)] <- Data[["mon.names"]][j]}
rm(ESS6)
}
### Column names to samples
if(identical(ncol(Mon), length(Data[["mon.names"]])))
colnames(Mon) <- Data[["mon.names"]]
if(identical(ncol(thinned), length(Data[["parm.names"]]))) {
colnames(thinned) <- Data[["parm.names"]]}
### Logarithm of the Marginal Likelihood
LML <- list(LML=NA, VarCov=NA)
if(Algorithm %in% c("Adaptive Griddy-Gibbs",
"Affine-Invariant Ensemble Sampler",
"Automated Factor Slice Sampler",
"Componentwise Hit-And-Run Metropolis",
"Delayed Rejection Metropolis",
"Elliptical Slice Sampler",
"Gibbs Sampler",
"Griddy-Gibbs",
"Hamiltonian Monte Carlo",
"Hit-And-Run Metropolis",
"Independence Metropolis",
"Metropolis-Adjusted Langevin Algorithm",
"Metropolis-Coupled Markov Chain Monte Carlo",
"Metropolis-within-Gibbs",
"Multiple-Try Metropolis",
"No-U-Turn Sampler",
"Oblique Hyperrectangle Slice Sampler",
"Preconditioned Crank-Nicolson",
"Random Dive Metropolis-Hastings",
"Random-Walk Metropolis",
"Reflective Slice Sampler",
"Refractive Sampler",
"Reversible-Jump",
"Sequential Metropolis-within-Gibbs",
"Slice Sampler",
"Stochastic Gradient Langevin Dynamics",
"Tempered Hamiltonian Monte Carlo",
"t-walk",
"Univariate Eigenvector Slice Sampler") &
{Stat.at < thinned.rows}) {
cat("Estimating Log of the Marginal Likelihood\n", file=LogFile,
append=TRUE)
LML <- LML(theta=thinned2, LL=as.vector(Dev2)*(-1/2),
method="NSIS")}
time2 <- proc.time()
### Compile Output
cat("Creating Output\n", file=LogFile, append=TRUE)
LaplacesDemon.out <- list(Acceptance.Rate=round(Acceptance/Iterations,7),
Algorithm=Algorithm,
Call=LDcall,
Covar=VarCov,
CovarDHis=DiagCovar,
Deviance=as.vector(Dev),
DIC1=c(mean(as.vector(Dev)),
var(as.vector(Dev))/2,
mean(as.vector(Dev)) + var(as.vector(Dev))/2),
DIC2=if(Stat.at < thinned.rows) {
c(mean(as.vector(Dev2)),
var(as.vector(Dev2))/2,
mean(as.vector(Dev2)) +
var(as.vector(Dev2))/2)}
else rep(NA,3),
Initial.Values=Initial.Values,
Iterations=Iterations,
LML=LML[[1]],
Minutes=round(as.vector(time2[3] - time1[3]) / 60,2),
Model=Model,
Monitor=Mon,
Parameters=LIV,
Posterior1=thinned,
Posterior2=if(Stat.at < thinned.rows) {
thinned[Stat.at:thinned.rows,]}
else thinned[thinned.rows,],
Rec.BurnIn.Thinned=BurnIn,
Rec.BurnIn.UnThinned=BurnIn*Thinning,
Rec.Thinning=min(1000, max(Rec.Thin)),
Specs=Specs,
Status=Status,
Summary1=Summ1,
Summary2=Summ2,
Thinned.Samples=thinned.rows,
Thinning=Thinning)
class(LaplacesDemon.out) <- "demonoid"
cat("\nLaplace's Demon has finished.\n", file=LogFile, append=TRUE)
return(LaplacesDemon.out)
}
.mcmcadmg <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, VarCov,
Debug, LogFile)
{
n <- Specs[["n"]]
Periodicity <- Specs[["Periodicity"]]
Acceptance <- matrix(0, 1, LIV)
AccRate <- rep(0, LIV)
obs.sum <- matrix(Mo0[["parm"]]*n, LIV, 1)
obs.scatter <- tcrossprod(Mo0[["parm"]])*n
s <- svd(VarCov)
U <- diag(s$u)
tol <- LIV*max(s$d)*.Machine$double.eps
problem <- any(s$d <= tol)
DiagCovar <- matrix(diag(VarCov), floor(Iterations/Thinning)+1, LIV,
byrow=TRUE)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Random-Scan Componentwise Estimation
if(iter > 10) AccRate <- Acceptance / {iter - 1}
if(problem == FALSE) lambda <- U*rnorm(LIV, 0,
sqrt(0.01 + s$d*exp(2*s$d*(AccRate - 0.3))))
else lambda <- rnorm(LIV, 0, sqrt(diag(VarCov)))
for (j in sample.int(LIV)) {
### Propose new parameter values
prop <- Mo0[["parm"]]
prop[j] <- prop[j] + lambda[j]
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed for",
Data[["parm.names"]][j], ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
u <- log(runif(1)) < (Mo1[["LP"]] - Mo0[["LP"]])
if(u == TRUE) {
Mo0 <- Mo1
Acceptance[j] <- Acceptance[j] + 1}}}
### Update Sample and Scatter Sum
obs.sum <- obs.sum + Mo0[["parm"]]
obs.scatter <- obs.scatter + tcrossprod(Mo0[["parm"]])
### Adaptation
if(iter %% Periodicity == 0) {
VarCov <- obs.scatter/{n + iter} -
tcrossprod(obs.sum/{n + iter})
diag(VarCov) <- diag(VarCov) + 1e-05
s <- svd(VarCov)
U <- diag(s$u)
tol <- LIV*max(s$d)*.Machine$double.eps
problem <- any(s$d <= tol)}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]
DiagCovar[t.iter,] <- diag(VarCov)}
}
### Output
out <- list(Acceptance=mean(as.vector(Acceptance)),
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=VarCov)
return(out)
}
.mcmcafss <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, VarCov,
Debug, LogFile)
{
A <- Specs[["A"]]
Block <- Specs[["B"]]
m <- Specs[["m"]]
n <- Specs[["n"]]
w <- Specs[["w"]]
B <- length(Block)
targetRatio <- 0.5
if(B == 0) {
if(!is.symmetric.matrix(VarCov)) {
cat("\nAsymmetric Covar, correcting now...\n", file=LogFile,
append=TRUE)
VarCov <- as.symmetric.matrix(VarCov)}
if(!is.positive.definite(VarCov)) {
cat("\nNon-Positive-Definite Covar, correcting now...\n",
file=LogFile, append=TRUE)
VarCov <- as.positive.definite(VarCov)}
decomp.freq <- max(LIV * floor(Iterations / Thinning / 100), 10)
cat("\nEigendecomposition will occur every", decomp.freq,
"iterations.\n\n", file=LogFile, append=TRUE)
factors <- eigen(VarCov)$vectors
obs.sum <- matrix(Mo0[["parm"]]*n, LIV, 1)
obs.scatter <- tcrossprod(Mo0[["parm"]])*n
DiagCovar <- matrix(w, floor(Iterations/Thinning)+1, LIV,
byrow=TRUE)
nExpands <- nShrinks <- rep(0, LIV)
IterPerAdapt <- 1
nProposals <- 0
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Random-Scan Componentwise Estimation
for (j in sample.int(LIV)) {
y.slice <- Mo0[["LP"]] - rexp(1)
upper <- runif(1,0,w[j])
lower <- upper - w[j]
### Step Out
count <- 0
while (count <= m[j]) {
Mo1 <- try(Model(Mo0[["parm"]] +
lower*factors[,j], Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out the lower",
"bound failed for",
Data[["parm.names"]][j],
"in step", count+1, ".\n",
file=LogFile, append=TRUE)
lower <- lower + w[j]
break}
else if(!is.finite(Mo1[["LP"]])) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out the lower",
"bound for", Data[["parm.names"]][j],
"resulted in a non-finite LP",
"in step", count+1, ".\n",
file=LogFile, append=TRUE)
lower <- lower + w[j]
break}
nExpands[j] <- nExpands[j] + 1
if(Mo1[["LP"]] <= y.slice) break
lower <- lower - w[j]
count <- count + 1
}
count <- 0
while (count <= m[j]) {
Mo1 <- try(Model(Mo0[["parm"]] +
upper*factors[,j], Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out the upper",
"bound failed for",
Data[["parm.names"]][j],
"in step", count+1, ".\n",
file=LogFile, append=TRUE)
upper <- upper - w[j]
break}
else if(!is.finite(Mo1[["LP"]])) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out the upper",
"bound for", Data[["parm.names"]][j],
"resulted in a non-finite LP",
"in step", count+1, ".\n",
file=LogFile, append=TRUE)
upper <- upper - w[j]
break}
nExpands[j] <- nExpands[j] + 1
if(Mo1[["LP"]] <= y.slice) break
upper <- upper + w[j]
count <- count + 1
}
### Rejection Sampling
repeat {
lower <- -abs(min(lower, upper))
upper <- abs(max(lower, upper))
prop <- runif(1, lower, upper)
Mo1 <- try(Model(Mo0[["parm"]] + prop *
factors[,j], Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Rejection sampling",
"failed for",
Data[["parm.names"]][j], "\n",
file=LogFile, append=TRUE)
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Rejection sampling for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
Mo1 <- Mo0}
if(Mo1[["LP"]] >= y.slice) break
else if(abs(prop) < 1e-100) break
nShrinks[j] <- nShrinks[j] + 1
if(prop < 0) lower <- prop
else upper <- prop
}
Mo0 <- Mo1
}
nProposals <- nProposals + 1
obs.sum <- obs.sum + Mo0[["parm"]]
obs.scatter <- obs.scatter + tcrossprod(Mo0[["parm"]])
### Adaptation
if({iter <= A} & {A - iter >= decomp.freq}) {
### Tune Interval Widths
if(nProposals %% IterPerAdapt == 0) {
denom <- nExpands + nShrinks
for (j in 1:LIV) {
if(denom[j] > 0) {
ratio <- nExpands[j] / denom[j]
if(ratio == 0) ratio <- 1 / denom[j]
multiplier <- ratio / targetRatio
w[j] <- w[j]*multiplier
}
}
nExpands <- nShrinks <- rep(0,LIV)
nProposals <- 0
IterPerAdapt <- IterPerAdapt * 2}
### Tune Sampling Factors
if(iter %% decomp.freq == 0) {
VarCov <- obs.scatter/{n + iter} -
tcrossprod(obs.sum/{n + iter})
factors <- eigen(VarCov)$vectors
nExpands <- nShrinks <- rep(0,LIV)
IterPerAdapt <- 1
nProposals <- 0}
}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]
DiagCovar[t.iter,] <- w}
}
}
else {
if(!identical(length(VarCov), B))
stop("Number of components in Covar differs from number ",
"of blocks.", file=LogFile, append=TRUE)
factors <- obs.sum <- obs.scatter <- list()
decomp.freq <- rep(0, length(B))
for (b in 1:B) {
if(length(Block[[b]]) == 1)
stop("Single-parameter blocks are not allowed in AFSS.",
file=LogFile, append=TRUE)
if(!identical(length(Block[[b]]), length(diag(VarCov[[b]]))))
stop("Diagonal of Covar[[",b,"]] differs from block length.")
if(!is.symmetric.matrix(VarCov[[b]])) {
cat("\nAsymmetric Covar block, correcting now...\n",
file=LogFile, append=TRUE)
VarCov[[b]] <- as.symmetric.matrix(VarCov[[b]])}
if(!is.positive.definite(VarCov[[b]])) {
cat("\nNon-Positive-Definite Covar block,",
"correcting now...\n", file=LogFile, append=TRUE)
VarCov[[b]] <- as.positive.definite(VarCov[[b]])}
decomp.freq[b] <- max(length(Block[[b]]) *
floor(Iterations / Thinning / 100), 10)
factors[[b]] <-try(eigen(VarCov[[b]])$vectors,
silent=!Debug[["DB.eigen"]])
if(inherits(factors[[b]], "try-error")) {
if(Debug[["DB.eigen"]] == TRUE)
cat("\nWARNING: Eigendecomposition of covariance",
"matrix failed for block", b, ".\n",
file=LogFile, append=TRUE)
cat(" Eigendecomposition of an identity matrix",
"occurs instead.\n", file=LogFile, append=TRUE)
factors[[b]] <- diag(length(Block[[b]]))}
obs.sum[[b]] <- matrix(Mo0[["parm"]][Block[[b]]]*n,
length(Block[[b]]), 1)
obs.scatter[[b]] <- tcrossprod(Mo0[["parm"]][Block[[b]]])*n}
if(all(decomp.freq == decomp.freq[1]))
cat("\nEigendecomposition will occur every", decomp.freq[1],
"iterations.\n\n", file=LogFile, append=TRUE)
else cat("\nEigendecomposition frequency varies by block,",
"and will occur between\n",
min(decomp.freq), "and", max(decomp.freq),
"iterations.\n\n", file=LogFile, append=TRUE)
DiagCovar <- matrix(w, floor(Iterations/Thinning)+1, LIV,
byrow=TRUE)
nExpands <- nShrinks <- rep(0, LIV)
IterPerAdapt <- rep(1, B)
nProposals <- rep(0, B)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Blockwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Proceed by Block
for (b in 1:B) {
### Random-Scan Componentwise Estimation
for (j in sample(Block[[b]])) {
bj <- which(Block[[b]] == j)
y.slice <- Mo0[["LP"]] - rexp(1)
upper <- runif(1,0,w[j])
lower <- upper - w[j]
### Step Out
count <- 0
while (count <= m[j]) {
prop <- Mo0[["parm"]]
prop[Block[[b]]] <- prop[Block[[b]]] +
lower*factors[[b]][,bj]
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out the lower",
"bound failed for",
Data[["parm.names"]][j],
"in step", count+1, ".\n",
file=LogFile, append=TRUE)
lower <- lower + w[j]
break}
else if(!is.finite(Mo1[["LP"]])) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out the lower",
"bound for", Data[["parm.names"]][j],
"resulted in a non-finite LP",
"in step", count+1, ".\n",
file=LogFile, append=TRUE)
lower <- lower + w[j]
break}
nExpands[j] <- nExpands[j] + 1
if(Mo1[["LP"]] <= y.slice) break
lower <- lower - w[j]
count <- count + 1
}
count <- 0
while (count <= m[j]) {
prop <- Mo0[["parm"]]
prop[Block[[b]]] <- prop[Block[[b]]] +
upper*factors[[b]][,bj]
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out the upper",
"bound failed for",
Data[["parm.names"]][j],
"in step", count+1, ".\n",
file=LogFile, append=TRUE)
upper <- upper - w[j]
break}
else if(!is.finite(Mo1[["LP"]])) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out the upper",
"bound for", Data[["parm.names"]][j],
"resulted in a non-finite LP",
"in step", count+1, ".\n",
file=LogFile, append=TRUE)
upper <- upper - w[j]
break}
nExpands[j] <- nExpands[j] + 1
if(Mo1[["LP"]] <= y.slice) break
upper <- upper + w[j]
count <- count + 1
}
### Rejection Sampling
repeat {
prop <- Mo0[["parm"]]
lower <- -abs(min(lower, upper))
upper <- abs(max(lower, upper))
u <- runif(1, lower, upper)
prop[Block[[b]]] <- prop[Block[[b]]] +
u*factors[[b]][,bj]
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Rejection sampling",
"failed for",
Data[["parm.names"]][j], "\n",
file=LogFile, append=TRUE)
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Rejection sampling for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
Mo1 <- Mo0}
if(Mo1[["LP"]] >= y.slice) break
else if(abs(u) < 1e-100) break
nShrinks[j] <- nShrinks[j] + 1
if(u < 0) lower <- u
else upper <- u
}
Mo0 <- Mo1
}
nProposals[b] <- nProposals[b] + 1
obs.sum[[b]] <- obs.sum[[b]] + Mo0[["parm"]][Block[[b]]]
obs.scatter[[b]] <- obs.scatter[[b]] +
tcrossprod(Mo0[["parm"]][Block[[b]]])
### Adaptation
if({iter <= A} & {A - iter >= decomp.freq[b]}) {
### Tune Interval Widths
if(nProposals[b] %% IterPerAdapt[b] == 0) {
for (j in Block[[b]]) {
denom <- nExpands[j] + nShrinks[j]
if(denom > 0) {
ratio <- nExpands[j] / denom
if(ratio == 0) ratio <- 1 / denom
multiplier <- ratio / targetRatio
w[j] <- w[j]*multiplier
}
}
nExpands[Block[[b]]] <- rep(0,length(Block[[b]]))
nShrinks[Block[[b]]] <- rep(0,length(Block[[b]]))
nProposals[b] <- 0
IterPerAdapt[b] <- IterPerAdapt[b] * 2}
### Tune Sampling Factors
if(iter %% decomp.freq[b] == 0) {
VarCov[[b]] <- obs.scatter[[b]]/{n + iter} -
tcrossprod(obs.sum[[b]]/{n + iter})
factors[[b]] <- eigen(VarCov[[b]])$vectors
nExpands[Block[[b]]] <- rep(0,length(Block[[b]]))
nShrinks[Block[[b]]] <- rep(0,length(Block[[b]]))
IterPerAdapt[b] <- 1
nProposals[b] <- 0}
}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]
DiagCovar[t.iter,] <- w}
}
}
}
### Output
out <- list(Acceptance=Iterations,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=VarCov)
return(out)
}
.mcmcagg <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, tuning,
Debug, LogFile)
{
Grid <- Specs[["Grid"]]
dparm <- Specs[["dparm"]]
smax <- Specs[["smax"]]
CPUs <- Specs[["CPUs"]]
Packages <- Specs[["Packages"]]
Dyn.libs <- Specs[["Dyn.libs"]]
AGGCP <- function(Model, Data, j, Mo0, Grid, tuning, smax, Debug,
LogFile)
{
G <- length(Grid[[j]])
x <- Grid[[j]] * sqrt(2) * tuning[j]
LP.grid <- rep(0, G)
prop <- Mo0[["parm"]]
theta <- prop[j] + x
for (g in 1:G) {
prop[j] <- theta[g]
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating",
Data[["parm.names"]][j], "at",
round(prop[j],5), "failed.\n", file=LogFile,
append=TRUE)
Mo1 <- Mo0}
LP.grid[g] <- Mo1[["LP"]]
theta[g] <- Mo1[["parm"]][j]}
if(all(!is.finite(LP.grid))) LP.grid <- rep(0, G)
LP.grid[which(!is.finite(LP.grid))] <- min(LP.grid[which(is.finite(LP.grid))])
LP.grid <- exp(LP.grid - logadd(LP.grid))
LP.grid <- LP.grid / sum(LP.grid)
s <- spline(theta, LP.grid, n=1000)
s$y <- interval(s$y, 0, Inf, reflect=FALSE)
if(length(which(s$y > 0)) == 0)
prop[j] <- theta[which.max(LP.grid)[1]]
else prop[j] <- sample(s$x, 1, prob=s$y)
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating", Data[["parm.names"]][j],
"at", round(prop[j],5), "failed.\n",
file=LogFile, append=TRUE)
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating", Data[["parm.names"]][j],
"at", round(prop[j],5),
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
Mo1 <- Mo0
}
else tuning[j] <- min(max(sqrt(sum(LP.grid * x^2)),
1e-10), smax)
Mo0 <- Mo1
return(list(Mo0=Mo0, tuning=tuning))
}
AGGCPP <- function(Model, Data, j, Mo0, Grid, tuning, smax, Debug,
LogFile, cl)
{
G <- length(Grid[[j]])
x <- Grid[[j]] * sqrt(2) * tuning[j]
LP.grid <- rep(0, G)
LIV <- length(Mo0[["parm"]])
prop <- matrix(Mo0[["parm"]], G, LIV, byrow=TRUE)
prop[, j] <- prop[, j] + x
Mo1 <- parLapply(cl, 1:G,
function(x) Model(prop[x,], Data))
LP.grid <- as.vector(unlist(lapply(Mo1,
function(x) x[["LP"]])))
prop <- matrix(as.vector(unlist(lapply(Mo1,
function(x) x[["parm"]]))), G, LIV, byrow=TRUE)
theta <- prop[, j]
if(all(!is.finite(LP.grid))) LP.grid <- rep(0, G)
LP.grid[which(!is.finite(LP.grid))] <- min(LP.grid[which(is.finite(LP.grid))])
LP.grid <- exp(LP.grid - logadd(LP.grid))
LP.grid <- LP.grid / sum(LP.grid)
s <- spline(theta, LP.grid, n=1000)
s$y <- interval(s$y, 0, Inf, reflect=FALSE)
prop <- Mo0[["parm"]]
if(length(which(s$y > 0)) == 0)
prop[j] <- theta[which.max(LP.grid)[1]]
else prop[j] <- sample(s$x, 1, prob=s$y)
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating", Data[["parm.names"]][j],
"at", round(prop[j],5), "failed.\n",
file=LogFile, append=TRUE)
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating", Data[["parm.names"]][j],
"at", round(prop[j],5),
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
Mo1 <- Mo0
}
else tuning[j] <- min(max(sqrt(sum(LP.grid * x^2)),
1e-10), smax)
Mo0 <- Mo1
return(list(Mo0=Mo0, tuning=tuning))
}
Acceptance <- matrix(0, 1, LIV)
Grid.orig <- Grid
post <- matrix(Mo0[["parm"]], Iterations, LIV, byrow=TRUE)
if(CPUs == 1) {
for (iter in 1:Iterations) {
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
for (j in sample.int(LIV)) {
if(j %in% dparm)
Mo0 <- .mcmcggdp(Model, Data, j, Mo0, Grid, Debug,
LogFile)
else {
agg <- AGGCP(Model, Data, j, Mo0, Grid, tuning,
smax, Debug, LogFile)
Mo0 <- agg$Mo0
tuning[j] <- agg$tuning[j]}}
if(iter %% Thinning == 0) {
t.iter <- floor(iter/Thinning) + 1
thinned[t.iter, ] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter, ] <- Mo0[["Monitor"]]
DiagCovar <- rbind(DiagCovar, tuning)}}
}
else {
detectedCores <- detectCores()
cat("\n\nCPUs Detected:", detectedCores, "\n", file=LogFile,
append=TRUE)
if(CPUs > detectedCores) {
cat("\nOnly", detectedCores, "will be used.\n",
file=LogFile, append=TRUE)
CPUs <- detectedCores}
cat("\nLaplace's Demon is preparing environments for CPUs...",
file=LogFile, append=TRUE)
cat("\n##################################################\n",
file=LogFile, append=TRUE)
cl <- makeCluster(CPUs)
cat("\n##################################################\n",
file=LogFile, append=TRUE)
on.exit(stopCluster(cl))
varlist <- unique(c(ls(), ls(envir=.GlobalEnv),
ls(envir=parent.env(environment()))))
clusterExport(cl, varlist=varlist, envir=environment())
clusterSetRNGStream(cl)
wd <- getwd()
clusterExport(cl, varlist=c("Packages", "Dyn.libs", "wd"),
envir=environment())
for (iter in 1:Iterations) {
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
for (j in sample.int(LIV)) {
if(j %in% dparm)
Mo0 <- .mcmcggdpp(Model, Data, j, Mo0, Grid,
Debug, LogFile, cl)
else {
agg <- AGGCPP(Model, Data, j, Mo0, Grid,
tuning, smax, Debug, LogFile, cl)
Mo0 <- agg$Mo0
tuning[j] <- agg$tuning[j]}
}
if(iter %% Thinning == 0) {
t.iter <- floor(iter/Thinning) + 1
thinned[t.iter, ] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter, ] <- Mo0[["Monitor"]]
DiagCovar <- rbind(DiagCovar, tuning)}}}
DiagCovar <- DiagCovar[-1,]
out <- list(Acceptance=Iterations, Dev=Dev, DiagCovar=DiagCovar,
Mon=Mon, thinned=thinned, VarCov=.colVars(thinned))
return(out)
}
.mcmcahmc <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, Debug,
LogFile)
{
epsilon <- Specs[["epsilon"]]
L <- Specs[["L"]]
m <- Specs[["m"]]
invm <- as.inverse(m)
U <- chol(m)
Periodicity <- Specs[["Periodicity"]]
post <- matrix(Mo0[["parm"]], Iterations, LIV, byrow=TRUE)
DiagCovar <- matrix(epsilon, floor(Iterations/Periodicity), LIV,
byrow=TRUE)
gr0 <- partial(Model, post[1,], Data)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Propose new parameter values
prop <- post[iter,] <- Mo0[["parm"]]
momentum0 <- as.vector(rnorm(LIV) %*% U)
kinetic0 <- t(momentum0) %*% invm %*% momentum0 / 2
momentum1 <- momentum0 + (epsilon / 2) * gr0
Mo0.1 <- Mo0
for (l in 1:L) {
prop <- prop + as.vector(epsilon %*% invm) * momentum1
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed in leapfrog", l,
".\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0.1
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in leapfrog", l,
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0.1}
if(any(Mo0.1[["parm"]] == Mo1[["parm"]])) {
nomove <- which(Mo0.1[["parm"]] == Mo1[["parm"]])
momentum1[nomove] <- -momentum1[nomove]
prop[nomove] <- prop[nomove] + momentum1[nomove]
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed in leapfrog",
l, ".\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),
")",sep=""), "\n", file=LogFile,
append=TRUE)}
Mo1 <- Mo0.1
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in leapfrog",
l, "resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),
")", sep=""), "\n", file=LogFile,
append=TRUE)}
Mo1 <- Mo0.1}}
Mo0.1 <- Mo1
prop <- Mo1[["parm"]]
gr1 <- partial(Model, prop, Data)
if(l < L) momentum1 <- momentum1 + epsilon * gr1}
momentum1 <- momentum1 + (epsilon / 2) * gr1
momentum1 <- -momentum1
kinetic1 <- t(momentum1) %*% invm %*% momentum1 / 2
### Accept/Reject
H0 <- -Mo0[["LP"]] + kinetic0
H1 <- -Mo1[["LP"]] + kinetic1
delta <- H1 - H0
alpha <- min(1, exp(-delta))
if(!is.finite(alpha)) alpha <- 0
if(runif(1) < alpha) {
Mo0 <- Mo1
post[iter,] <- Mo1[["parm"]]
kinetic0 <- kinetic1
gr0 <- gr1
Acceptance <- Acceptance + 1
}
### Adaptation
if(iter %% Periodicity == 0) {
if(iter > 10) {
acceptances <- length(unique(post[(iter-9):iter,1]))
if(acceptances <= 1) epsilon <- epsilon * 0.8
else if(acceptances > 7) epsilon <- epsilon * 1.2}
a.iter <- floor(iter / Periodicity)
DiagCovar[a.iter,] <- epsilon}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=cov(thinned))
return(out)
}
.mcmcaies <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, Debug,
LogFile)
{
Nc <- Specs[["Nc"]]
Z <- Specs[["Z"]]
beta <- Specs[["beta"]]
CPUs <- Specs[["CPUs"]]
Packages <- Specs[["Packages"]]
Dyn.libs <- Specs[["Dyn.libs"]]
Mo0 <- list(Mo0=Mo0)
if(is.null(Z)) {
Z <- matrix(Mo0[[1]][["parm"]], Nc, LIV, byrow=TRUE)
for (i in 2:Nc) {
if(!is.null(Data[["PGF"]])) {
Z[i,] <- GIV(Model, Data, PGF=TRUE)
}
else Z[i,] <- GIV(Model, Data)
}
}
for (i in 2:Nc) Mo0[[i]] <- Model(Z[i,], Data)
if(CPUs == 1) {
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter, sep="", file=LogFile,
append=TRUE)
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[[1]][["parm"]]
Dev[t.iter] <- Mo0[[1]][["Dev"]]
Mon[t.iter,] <- Mo0[[1]][["Monitor"]]}
for (i in 1:Nc) {
### Propose new parameter values with stretch move
z <- 1 / sqrt(runif(1, 1 / beta, beta))
s <- sample(c(1:Nc)[-i], 1)
prop <- Mo0[[s]][["parm"]] +
z*(Mo0[[i]][["parm"]] - Mo0[[s]][["parm"]])
if(i == 1 & iter %% Status == 0)
cat(", Proposal: Multivariate, LP: ",
round(Mo0[[1]][["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed in walker",
i, ".\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),
")",sep=""), "\n", file=LogFile,
append=TRUE)}
Mo1 <- Mo0[[i]]
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in walker", i,
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),
")",sep=""), "\n", file=LogFile,
append=TRUE)}
Mo1 <- Mo0[[i]]}
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- (LIV-1)*log(z) + Mo1[["LP"]] -
Mo0[[i]][["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
else if(log.u < log.alpha) {
Mo0[[i]] <- Mo1
if(i == 1) {
Acceptance <- Acceptance + 1
if(iter %% Thinning == 0) {
thinned[t.iter,] <- Mo1[["parm"]]
Dev[t.iter] <- Mo1[["Dev"]]
Mon[t.iter,] <- Mo1[["Monitor"]]}
}
}
}
}
}
else {
detectedCores <- detectCores()
cat("\n\nCPUs Detected:", detectedCores, "\n", file=LogFile,
append=TRUE)
if(CPUs > detectedCores) {
cat("\nOnly", detectedCores, "will be used.\n", file=LogFile,
append=TRUE)
CPUs <- detectedCores}
cat("\nLaplace's Demon is preparing environments for CPUs...",
file=LogFile, append=TRUE)
cat("\n##################################################\n",
file=LogFile, append=TRUE)
cl <- makeCluster(CPUs)
cat("\n##################################################\n",
file=LogFile, append=TRUE)
on.exit(stopCluster(cl))
varlist <- unique(c(ls(), ls(envir=.GlobalEnv),
ls(envir=parent.env(environment()))))
clusterExport(cl, varlist=varlist, envir=environment())
clusterSetRNGStream(cl)
wd <- getwd()
clusterExport(cl, varlist=c("Packages", "Dyn.libs", "wd"),
envir=environment())
model.wrapper <- function(x, ...)
{
if(!is.null(Packages)) {
sapply(Packages,
function(x) library(x, character.only=TRUE,
quietly=TRUE))}
if(!is.null(Dyn.libs)) {
sapply(Dyn.libs,
function(x) dyn.load(paste(wd, x, sep = "/")))
on.exit(sapply(Dyn.libs,
function(x) dyn.unload(paste(wd, x, sep = "/"))))}
Model(prop[x,], Data)
}
prop <- Z
batch1 <- 1:(Nc/2)
batch2 <- batch1 + (Nc/2)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter, sep="", file=LogFile,
append=TRUE)
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[[1]][["parm"]]
Dev[t.iter] <- Mo0[[1]][["Dev"]]
Mon[t.iter,] <- Mo0[[1]][["Monitor"]]}
for (i in 1:Nc) {
### Propose new parameter values with stretch move
z <- 1 / sqrt(runif(1, 1 / beta, beta))
if(i <= (Nc/2)) s <- sample(batch2, 1)
else s <- sample(batch1, 1)
prop[i,] <- Mo0[[s]][["parm"]] +
z*(Mo0[[i]][["parm"]] - Mo0[[s]][["parm"]])
if(i == 1 & iter %% Status == 0)
cat(", Proposal: Multivariate\n", file=LogFile,
append=TRUE)}
### Log-Posterior of the proposed state
Mo1 <- clusterApply(cl, 1:Nc, model.wrapper,
Model, Data, prop)
for (i in 1:Nc) {
if(any(!is.finite(c(Mo1[[i]][["LP"]],
Mo1[[i]][["Dev"]], Mo1[[i]][["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in walker", i,
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[i,],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo1[[i]] <- Mo0[[i]]}
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- (LIV-1)*log(z) + Mo1[[i]][["LP"]] -
Mo0[[i]][["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
else if(log.u < log.alpha) {
Mo0[[i]] <- Mo1[[i]]
if(i == 1) {
Acceptance <- Acceptance + 1
if(iter %% Thinning == 0) {
thinned[t.iter,] <- Mo1[[i]][["parm"]]
Dev[t.iter] <- Mo1[[i]][["Dev"]]
Mon[t.iter,] <- Mo1[[i]][["Monitor"]]}
}
}
}
}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
.mcmcam <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, tuning,
VarCov, Debug, LogFile)
{
Adaptive <- Specs[["Adaptive"]]
Periodicity <- Specs[["Periodicity"]]
post <- matrix(Mo0[["parm"]], Iterations, LIV, byrow=TRUE)
Iden.Mat <- diag(LIV)
DiagCovar <- matrix(diag(VarCov), floor(Iterations/Periodicity), LIV,
byrow=TRUE)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter, sep="", file=LogFile, append=TRUE)
### Current Posterior
if(iter > 1) post[iter,] <- post[iter-1,]
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- post[iter,]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
### Propose new parameter values
MVNz <- try(rbind(rnorm(LIV)) %*% chol(VarCov),
silent=!Debug[["DB.chol"]])
if(!inherits(MVNz, "try-error") &
((Acceptance / iter) >= 0.05)) {
if(iter %% Status == 0)
cat(", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
MVNz <- as.vector(MVNz)
prop <- t(post[iter,] + t(MVNz))}
else {
if(iter %% Status == 0)
cat(", Proposal: Single-Component, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
if(Debug[["DB.chol"]] == TRUE)
cat("\nWARNING: Cholesky decomposition failed for",
"proposal in iteration", iter, ".\n",
file=LogFile, append=TRUE)
prop <- post[iter,]
j <- ceiling(runif(1,0,LIV))
prop[j] <- rnorm(1, post[iter,j], tuning[j])}
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",sep=""),
"\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal resulted in non-finite",
"value(s).\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",sep=""),
"\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0}
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
else if(log.u < log.alpha) {
Mo0 <- Mo1
post[iter,] <- Mo1[["parm"]]
Acceptance <- Acceptance + 1
if(iter %% Thinning == 0) {
thinned[t.iter,] <- Mo1[["parm"]]
Dev[t.iter] <- Mo1[["Dev"]]
Mon[t.iter,] <- Mo1[["Monitor"]]}}
### Shrinkage of Adaptive Proposal Variance
if({Adaptive < Iterations} & {Acceptance > 5} &
{Acceptance / iter < 0.05}) {
VarCov <- VarCov * {1 - {1 / Iterations}}
tuning <- tuning * {1 - {1 / Iterations}}}
### Adapt the Proposal Variance
if({iter >= Adaptive} & {iter %% Periodicity == 0}) {
### Covariance Matrix (Preferred if it works)
VarCov <- {ScaleF * cov(post[1:iter,])} +
{ScaleF * 1.0E-5 * Iden.Mat}
a.iter <- floor(iter / Periodicity)
DiagCovar[a.iter,] <- diag(VarCov)
### Univariate Standard Deviations
tuning <- sqrt(ScaleF * .colVars(post[1:iter,]) +
ScaleF * 1.0E-5)
}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=VarCov)
return(out)
}
.mcmcamm <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, tuning,
VarCov, Debug, LogFile)
{
Adaptive <- Specs[["Adaptive"]]
Block <- Specs[["B"]]
n <- Specs[["n"]]
Periodicity <- Specs[["Periodicity"]]
w <- Specs[["w"]]
obs.sum <- matrix(Mo0[["parm"]]*n, LIV, 1)
obs.scatter <- tcrossprod(Mo0[["parm"]])*n
if(all(upper.triangle(VarCov) == 0)) prop.R <- NULL
else prop.R <- ScaleF * chol(VarCov)
tuning <- sqrt(0.0001 * ScaleF)
DiagCovar <- matrix(diag(VarCov), floor(Iterations/Periodicity), LIV,
byrow=TRUE)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter, sep="", file=LogFile, append=TRUE)
### Propose new parameter values from a mixture
if(is.null(prop.R) || runif(1) < w) {
prop <- rnorm(LIV, Mo0[["parm"]], tuning)
if(iter %% Status == 0)
cat(", Proposal: Non-Adaptive Component, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)}
else {
prop <- Mo0[["parm"]] +
as.vector(rbind(rnorm(LIV)) %*% prop.R)
if(iter %% Status == 0)
cat(", Proposal: Adaptive Component, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)}
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",sep=""),
"\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal resulted in non-finite",
"value(s).\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",sep=""),
"\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
Acceptance <- Acceptance + 1}}
### Update Sample and Scatter Sum
obs.sum <- obs.sum + Mo0[["parm"]]
obs.scatter <- obs.scatter + tcrossprod(Mo0[["parm"]])
### Adapt the Proposal Variance
if({iter >= Adaptive} & {iter %% Periodicity == 0}) {
VarCov <- obs.scatter/{n + iter} -
tcrossprod(obs.sum/{n + iter})
diag(VarCov) <- diag(VarCov) + 1e-05
a.iter <- floor(iter / Periodicity)
DiagCovar[a.iter,] <- diag(VarCov)
prop.R <- try(ScaleF * chol(VarCov),
silent=!Debug[["DB.chol"]])
if(Debug[["DB.chol"]] == TRUE)
cat("\nWARNING: Cholesky decomposition failed for",
"proposal covariance in iteration", iter, ".\n",
file=LogFile, append=TRUE)
if(!is.matrix(prop.R)) prop.R <- NULL}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=VarCov)
return(out)
}
.mcmcamm.b <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, tuning,
VarCov, Debug, LogFile)
{
Adaptive <- Specs[["Adaptive"]]
Block <- Specs[["B"]]
n <- Specs[["n"]]
Periodicity <- Specs[["Periodicity"]]
w <- Specs[["w"]]
B <- length(Block)
if(!identical(length(VarCov), B))
stop("Number of components in Covar differs from ",
"number of blocks.", file=LogFile, append=TRUE)
obs.scatter <- obs.sum <- prop.R <- list()
for (b in 1:B) {
if(!identical(length(Block[[b]]), length(diag(VarCov[[b]]))))
stop("Diagonal of Covar[[",b,"]] differs from ",
"block length.", file=LogFile, append=TRUE)
obs.sum[[b]] <- matrix(Mo0[["parm"]][Block[[b]]]*n,
length(Block[[b]]), 1)
obs.scatter[[b]] <- matrix(tcrossprod(Mo0[["parm"]][Block[[b]]])*n,
length(Block[[b]]), length(Block[[b]]))
if(all(upper.triangle(VarCov[[b]]) == 0)) prop.R[[b]] <- NA
else prop.R[[b]] <- ScaleF * chol(VarCov[[b]])}
tuning <- sqrt(0.0001 * ScaleF)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter, sep="", file=LogFile, append=TRUE)
### Proceed by Block
for (b in 1:B) {
### Propose new parameter values from a mixture
prop <- Mo0[["parm"]]
if(any(is.na(prop.R[[b]])) || runif(1) < w) {
prop[Block[[b]]] <- rnorm(length(Block[[b]]),
Mo0[["parm"]][Block[[b]]], tuning)
if(b == 1 & iter %% Status == 0)
cat(", Proposal: Blockwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)}
else {
prop[Block[[b]]] <- Mo0[["parm"]][Block[[b]]] +
as.vector(rbind(rnorm(length(Block[[b]]))) %*%
prop.R[[b]])
if(b == 1 & iter %% Status == 0)
cat(", Proposal: Blockwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)}
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal resulted in non-finite",
"value(s).\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
Acceptance <- Acceptance +
length(Block[[b]]) / LIV}}
### Update Sample and Scatter Sum
obs.sum[[b]] <- obs.sum[[b]] + Mo0[["parm"]][Block[[b]]]
obs.scatter[[b]] <- obs.scatter[[b]] +
tcrossprod(Mo0[["parm"]][Block[[b]]])
### Adapt the Proposal Variance
if({iter >= Adaptive} & {iter %% Periodicity == 0}) {
VarCov[[b]] <- obs.scatter[[b]]/{n + iter} -
tcrossprod(obs.sum[[b]]/{n + iter})
diag(VarCov[[b]]) <- diag(VarCov[[b]]) + 1e-05
if(b == 1) DiagCovar <- rbind(DiagCovar, rep(0,LIV))
DiagCovar[nrow(DiagCovar),Block[[b]]] <- diag(VarCov[[b]])
prop.R[[b]] <- try(ScaleF * chol(VarCov[[b]]),
silent=!Debug[["DB.chol"]])
if(Debug[["DB.chol"]] == TRUE)
cat("\nWARNING: Cholesky decomposition failed for",
"proposal covariance in iteration", iter,
".\n", file=LogFile, append=TRUE)
if(!is.matrix(prop.R[[b]])) prop.R[[b]] <- NA}
}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=VarCov)
return(out)
}
.mcmcamwg <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, tuning,
Debug, LogFile)
{
Block <- Specs[["B"]]
n <- Specs[["n"]]
Periodicity <- Specs[["Periodicity"]]
Acceptance <- rep(0, LIV)
B <- length(Block)
DiagCovar <- matrix(tuning, floor(Iterations/Periodicity), LIV,
byrow=TRUE)
if(B == 0) {
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Random-Scan Componentwise Estimation
propdraw <- rnorm(LIV,0,tuning)
for (j in sample.int(LIV)) {
### Propose new parameter values
prop <- Mo0[["parm"]]
prop[j] <- prop[j] + propdraw[j]
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed for",
Data[["parm.names"]][j], ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
u <- log(runif(1)) < {Mo1[["LP"]] - Mo0[["LP"]]}
if(u == TRUE) {
Mo0 <- Mo1
Acceptance[j] <- Acceptance[j] + 1}}}
### Adapt the Proposal Variance
if(iter %% Periodicity == 0) {
size <- 1 / min(100, sqrt(n + iter))
Acceptance.Rate <- Acceptance / iter
log.tuning <- log(tuning)
tuning.num <- which(Acceptance.Rate > 0.44)
log.tuning[tuning.num] <- log.tuning[tuning.num] + size
tuning.num <- which(Acceptance.Rate <= 0.44)
log.tuning[tuning.num] <- log.tuning[tuning.num] - size
tuning <- exp(log.tuning)
a.iter <- floor(iter / Periodicity)
DiagCovar[a.iter,] <- tuning}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
}
else {
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Random-Scan Componentwise Estimation
propdraw <- rnorm(LIV,0,tuning)
for (b in 1:B) {
for (j in sample(Block[[b]])) {
### Propose new parameter values
prop <- Mo0[["parm"]]
prop[j] <- prop[j] + propdraw[j]
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed for",
Data[["parm.names"]][j], ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
u <- log(runif(1)) < {Mo1[["LP"]] -
Mo0[["LP"]]}
if(u == TRUE) {
Mo0 <- Mo1
Acceptance[j] <- Acceptance[j] + 1}}}}
### Adapt the Proposal Variance
if(iter %% Periodicity == 0) {
size <- 1 / min(100, sqrt(n + iter))
Acceptance.Rate <- Acceptance / iter
log.tuning <- log(tuning)
tuning.num <- which(Acceptance.Rate > 0.44)
log.tuning[tuning.num] <- log.tuning[tuning.num] + size
tuning.num <- which(Acceptance.Rate <= 0.44)
log.tuning[tuning.num] <- log.tuning[tuning.num] - size
tuning <- exp(log.tuning)
a.iter <- floor(iter / Periodicity)
DiagCovar[a.iter,] <- tuning}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
}
### Output
out <- list(Acceptance=mean(Acceptance),
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=tuning)
return(out)
}
.mcmccharm <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, Debug,
LogFile)
{
alpha.star <- Specs[["alpha.star"]]
if(is.na(alpha.star)) {
Acceptance <- matrix(0, 1, LIV)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Random-Scan Componentwise Estimation
theta <- rnorm(LIV)
theta <- theta / sqrt(sum(theta*theta))
lambda <- runif(1)
for (j in sample.int(LIV)) {
### Propose new parameter values
prop <- Mo0[["parm"]]
prop[j] <- prop[j] + lambda*theta[j]
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed for",
Data[["parm.names"]][j], ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
u <- log(runif(1)) < (Mo1[["LP"]] - Mo0[["LP"]])
if(u == TRUE) {
Mo0 <- Mo1
Acceptance[j] <- Acceptance[j] + 1}}}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=mean(as.vector(Acceptance)),
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
else {
tau <- rep(1, LIV)
Acceptance <- matrix(0, 1, LIV)
DiagCovar <- matrix(tau, nrow(thinned), LIV)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Random-Scan Componentwise Estimation
theta <- rnorm(LIV)
theta <- theta / sqrt(sum(theta*theta))
lambda <- runif(1)
for (j in sample.int(LIV)) {
### Propose new parameter values
prop <- Mo0[["parm"]]
prop[j] <- prop[j] + tau[j]*lambda*theta[j]
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed for",
Data[["parm.names"]][j], ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
u <- log(runif(1)) < (Mo1[["LP"]] - Mo0[["LP"]])
if(u == TRUE) {
Mo0 <- Mo1
Acceptance[j] <- Acceptance[j] + 1
tau[j] <- tau[j] + (tau[j] / (alpha.star *
(1 - alpha.star))) * (1 - alpha.star) / iter
}
else {
tau[j] <- abs(tau[j] - (tau[j] / (alpha.star *
(1 - alpha.star))) * alpha.star / iter)}}}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]
DiagCovar[t.iter,] <- tau}
}
### Output
out <- list(Acceptance=mean(as.vector(Acceptance)),
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
}
.mcmcdemc <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, Debug,
LogFile)
{
Nc <- Specs[["Nc"]]
Z <- Specs[["Z"]]
gamma <- Specs[["gamma"]]
w <- Specs[["w"]]
const <- 2.381204 / sqrt(2)
Mo0 <- list(Mo0=Mo0)
if(is.null(Z)) {
cat("\nGenerating Z...\n", file=LogFile, append=TRUE)
Z <- array(0, dim=c(floor(Iterations/Thinning)+1, LIV, Nc))
for (t in 1:dim(Z)[1]) {
for (i in 1:Nc) {
if(t == 1 & i == 1) {
Z[t,,i] <- Mo0[[1]][["parm"]]
}
else {
if(!is.null(Data[["PGF"]])) {
Z[t,,i] <- GIV(Model, Data, PGF=TRUE)}
else Z[t,,i] <- GIV(Model, Data)
}
}
}
}
else Z[1,,1] <- Mo0[[1]][["parm"]]
for (i in 2:Nc) Mo0[[i]] <- Model(Z[1,,i], Data)
for (iter in 1:Iterations) {
### Thinned Iteration
t.iter <- floor(iter / Thinning) + 1
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter, sep="", file=LogFile, append=TRUE)
### Save Thinned Samples
if(iter %% Thinning == 0) {
Z[t.iter,,] <- Z[t.iter-1,,]
thinned[t.iter,] <- Mo0[[1]][["parm"]]
Dev[t.iter] <- Mo0[[1]][["Dev"]]
Mon[t.iter,] <- Mo0[[1]][["Monitor"]]}
omega <- runif(1)
for (i in 1:Nc) {
r <- sample(dim(Z)[1], 2)
s <- sample(c(1:Nc)[-i], 2)
if(omega > w) {
### Parallel Direction Move
prop <- Mo0[[i]][["parm"]] +
gamma*(Z[r[1],,s[1]] - Z[r[2],,s[2]]) +
runif(LIV, -0.001, 0.001)^LIV
}
else {
### Snooker Move
si <- sample(c(1:Nc)[-i], 1)
prop <- Mo0[[i]][["parm"]] + const*
({Mo0[[si]][["parm"]] - Z[r[1],,s[1]]} -
{Mo0[[si]][["parm"]] - Z[r[2],,s[2]]})}
if(i == 1 & iter %% Status == 0)
cat(", Proposal: Multivariate, LP: ",
round(Mo0[[1]][["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed in chain", i,
".\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0[[i]]
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in chain", i,
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0[[i]]
}
else {
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[[i]][["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0[[i]] <- Mo1
Z[t.iter,,i] <- Mo1[["parm"]]
if(i == 1) {
Acceptance <- Acceptance + 1
if(iter %% Thinning == 0) {
thinned[t.iter,] <- Mo1[["parm"]]
Dev[t.iter] <- Mo1[["Dev"]]
Mon[t.iter,] <- Mo1[["Monitor"]]}
}
}
}
}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=thinned,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
.mcmcdram <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, tuning,
VarCov, Debug, LogFile)
{
Adaptive <- Specs[["Adaptive"]]
DR <- 1
Periodicity <- Specs[["Periodicity"]]
post <- matrix(Mo0[["parm"]], Iterations, LIV, byrow=TRUE)
Iden.Mat <- diag(LIV)
DiagCovar <- matrix(diag(VarCov), floor(Iterations/Periodicity), LIV,
byrow=TRUE)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter, sep="", file=LogFile, append=TRUE)
### Current Posterior
if(iter > 1) post[iter,] <- post[iter-1,]
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- post[iter,]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
### Propose new parameter values
MVNz <- try(rbind(rnorm(LIV)) %*% chol(VarCov),
silent=!Debug[["DB.chol"]])
if(!inherits(MVNz, "try-error") &
((Acceptance / iter) >= 0.05)) {
if(iter %% Status == 0)
cat(", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
MVNz <- as.vector(MVNz)
prop <- t(post[iter,] + t(MVNz))}
else {
if(iter %% Status == 0)
cat(", Proposal: Single-Component, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
if(Debug[["DB.chol"]] == TRUE)
cat("\nWARNING: Cholesky decomposition failed for",
"proposal 1 in iteration", iter, ".\n",
file=LogFile, append=TRUE)
prop <- post[iter,]
j <- ceiling(runif(1,0,LIV))
prop[j] <- rnorm(1, post[iter,j], tuning[j])}
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal 1 failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",sep=""),
"\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal 1 resulted in non-finite",
"value(s).\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",sep=""),
"\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0}
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
post[iter,] <- Mo1[["parm"]]
Acceptance <- Acceptance + 1
if(iter %% Thinning == 0) {
thinned[t.iter,] <- Mo1[["parm"]]
Dev[t.iter] <- Mo1[["Dev"]]
Mon[t.iter,] <- Mo1[["Monitor"]]}
}
### Delayed Rejection: Second Stage Proposals
else if(log.u >= log.alpha) {
MVNz <- try(rbind(rnorm(LIV)) %*%
chol(VarCov * 0.5), silent=!Debug[["DB.chol"]])
if(!inherits(MVNz, "try-error") &
((Acceptance / iter) >= 0.05)) {
MVNz <- as.vector(MVNz)
prop <- t(post[iter,] + t(MVNz))}
else {
if(Debug[["DB.chol"]] == TRUE)
cat("\nWARNING: Cholesky decomposition failed for",
"proposal 2 in iteration", iter, ".\n",
file=LogFile, append=TRUE)
prop <- post[iter,]
j <- ceiling(runif(1,0,LIV))
prop[j] <- rnorm(1, post[iter,j], tuning[j])}
### Log-Posterior of the proposed state
Mo2 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo2, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal 2 failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo2 <- Mo0
}
else if(any(!is.finite(c(Mo2[["LP"]], Mo2[["Dev"]],
Mo2[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal 2 resulted in non-finite",
"value(s).\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo2 <- Mo0
}
else {
### Accept/Reject
log.u <- log(runif(1))
options(warn=-1)
log.alpha.comp <- log(1 - exp(Mo1[["LP"]] -
Mo2[["LP"]]))
options(warn=0)
if(!is.finite(log.alpha.comp)) log.alpha.comp <- 0
log.alpha <- Mo2[["LP"]] + log.alpha.comp -
{Mo0[["LP"]] + log(1 - exp(Mo1[["LP"]] -
Mo0[["LP"]]))}
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo2
post[iter,] <- Mo2[["parm"]]
Acceptance <- Acceptance + 1
if(iter %% Thinning == 0) {
thinned[t.iter,] <- Mo1[["parm"]]
Dev[t.iter] <- Mo1[["Dev"]]
Mon[t.iter,] <- Mo1[["Monitor"]]}
}
}
}
### Shrinkage of Adaptive Proposal Variance
if({Adaptive < Iterations} & {Acceptance > 5} &
{Acceptance / iter < 0.05}) {
VarCov <- VarCov * {1 - {1 / Iterations}}
tuning <- tuning * {1 - {1 / Iterations}}}
### Adapt the Proposal Variance
if({iter >= Adaptive} & {iter %% Periodicity == 0}) {
### Covariance Matrix (Preferred if it works)
VarCov <- {ScaleF * cov(post[1:iter,])} +
{ScaleF * 1.0E-5 * Iden.Mat}
a.iter <- floor(iter / Periodicity)
DiagCovar[a.iter,] <- diag(VarCov)
### Univariate Standard Deviations
tuning <- sqrt(ScaleF * .colVars(post[1:iter,]) +
ScaleF * 1.0E-5)
}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=VarCov)
return(out)
}
.mcmcdrm <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, tuning,
VarCov, Debug, LogFile)
{
DR <- 1
U <- chol(VarCov)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter, sep="", file=LogFile, append=TRUE)
### Propose new parameter values
MVNz <- try(rbind(rnorm(LIV)) %*% U, silent=TRUE)
if(!inherits(MVNz, "try-error") &
((Acceptance / iter) >= 0.05)) {
if(iter %% Status == 0)
cat(", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
MVNz <- as.vector(MVNz)
prop <- t(as.vector(Mo0[["parm"]]) + t(MVNz))}
else {
if(iter %% Status == 0)
cat(", Proposal: Single-Component, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
prop <- Mo0[["parm"]]
j <- ceiling(runif(1,0,LIV))
prop[j] <- rnorm(1, Mo0[["parm"]][j], tuning[j])}
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal 1 failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",sep=""),
"\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal 1 resulted in non-finite",
"value(s).\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",sep=""),
"\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0}
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
Acceptance <- Acceptance + 1}
### Delayed Rejection: Second Stage Proposals
else if(log.u >= log.alpha) {
MVNz <- try(rbind(rnorm(LIV)) %*%
chol(VarCov * 0.5), silent=!Debug[["DB.chol"]])
if(!inherits(MVNz, "try-error") &
((Acceptance / iter) >= 0.05)) {
MVNz <- as.vector(MVNz)
prop <- t(as.vector(Mo0[["parm"]]) + t(MVNz))}
else {
if(Debug[["DB.chol"]] == TRUE)
cat("\nWARNING: Cholesky decomposition failed for",
"proposal 2 in iteration", iter, ".\n",
file=LogFile, append=TRUE)
prop <- Mo0[["parm"]]
j <- ceiling(runif(1,0,LIV))
prop[j] <- rnorm(1, Mo0[["parm"]][j], tuning[j])}
### Log-Posterior of the proposed state
Mo2 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo2, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal 2 failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo2 <- Mo0
}
else if(any(!is.finite(c(Mo2[["LP"]], Mo2[["Dev"]],
Mo2[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal 2 resulted in non-finite",
"value(s).\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""),"\n", file=LogFile, append=TRUE)}
Mo2 <- Mo0
}
else {
### Accept/Reject
log.u <- log(runif(1))
options(warn=-1)
log.alpha.comp <- log(1 - exp(Mo1[["LP"]] -
Mo2[["LP"]]))
options(warn=0)
if(!is.finite(log.alpha.comp)) log.alpha.comp <- 0
log.alpha <- Mo2[["LP"]] + log.alpha.comp -
{Mo0[["LP"]] + log(1 - exp(Mo1[["LP"]] -
Mo0[["LP"]]))}
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo2
Acceptance <- Acceptance + 1}}
}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=VarCov)
return(out)
}
.mcmcess <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, VarCov,
Debug, LogFile)
{
Block <- Specs[["B"]]
if(length(Block) == 0) {
if(!is.symmetric.matrix(VarCov)) {
cat("\nAsymmetric Covar, correcting now...\n", file=LogFile,
append=TRUE)
VarCov <- as.symmetric.matrix(VarCov)}
if(!is.positive.definite(VarCov)) {
cat("\nNon-Positive-Definite Covar, correcting now...\n",
file=LogFile, append=TRUE)
VarCov <- as.positive.definite(VarCov)}
nu <- rnorm(LIV, 0, diag(VarCov))
U <- chol(VarCov)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Propose new parameter values
nu <- as.vector(rbind(rnorm(LIV)) %*% U)
theta <- theta.max <- runif(1, 0, 2*pi)
theta.min <- theta - 2*pi
shrink <- TRUE
log.u <- log(runif(1))
### Rejection Sampling
while (shrink == TRUE) {
prop <- Mo0[["parm"]] * cos(theta) + nu*sin(theta)
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Rejection sampling failed.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Rejection sampling resulted",
"in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0}
### Accept/Reject
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
shrink <- FALSE
}
else {
if(theta < 0) theta.min <- theta
else theta.max <- theta
theta <- runif(1, theta.min, theta.max)}}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
}
else {
B <- length(Block)
if(!identical(length(VarCov), B))
stop("Number of components in Covar differs from ",
"number of blocks.", file=LogFile, append=TRUE)
nu <- rep(NA, LIV)
for (b in 1:B) {
if(!identical(length(Block[[b]]), length(diag(VarCov[[b]]))))
stop("Diagonal of Covar[[",b,"]] differs from ",
"block length.", file=LogFile, append=TRUE)
if(!is.symmetric.matrix(VarCov[[b]])) {
cat("\nAsymmetric Covar block, correcting now...\n",
file=LogFile, append=TRUE)
VarCov[[b]] <- as.symmetric.matrix(VarCov[[b]])}
if(!is.positive.definite(VarCov[[b]])) {
cat("\nNon-Positive-Definite Covar block,",
"correcting now...\n", file=LogFile, append=TRUE)
VarCov[[b]] <- as.positive.definite(VarCov[[b]])}
nu[Block[[b]]] <- rnorm(length(Block[[b]]), 0,
diag(VarCov[[b]]))}
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Blockwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Proceed by Block
for (b in 1:B) {
### Propose new parameter values
blen <- length(Block[[b]])
nu[Block[[b]]] <- as.vector(rbind(rnorm(blen)) %*%
chol(VarCov[[b]]))
theta <- theta.max <- runif(1, 0, 2*pi)
theta.min <- theta - 2*pi
shrink <- TRUE
log.u <- log(runif(1))
### Rejection Sampling
while (shrink == TRUE) {
prop <- Mo0[["parm"]]
prop[Block[[b]]] <- Mo0[["parm"]][Block[[b]]] *
cos(theta) + nu[Block[[b]]]*sin(theta)
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Rejection sampling failed.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Rejection sampling resulted",
"in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo1 <- Mo0}
### Accept/Reject
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
shrink <- FALSE
}
else {
if(theta < 0) theta.min <- theta
else theta.max <- theta
theta <- runif(1, theta.min, theta.max)}}
}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
}
### Output
out <- list(Acceptance=Iterations,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=cov(thinned))
return(out)
}
.mcmcgibbs <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, tuning,
Debug, LogFile)
{
FC <- Specs[["FC"]]
MWG <- Specs[["MWG"]]
if(is.null(MWG)) {
Acceptance <- Iterations
MWGlen <- 0}
else {
MWGlen <- length(MWG)
Acceptance <- matrix(0, 1, LIV)}
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Gibbs Sampling of Full Conditionals
prop <- try(FC(Mo0[["parm"]], Data), silent=!Debug[["DB.Model"]])
if(inherits(prop, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Gibbs proposal for full conditionals",
"failed.\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(Mo0[["parm"]], collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
prop <- Mo0[["parm"]]}
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Gibbs proposal failed.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",sep=""),
"\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0}
Mo0 <- Mo1
### Metropolis-within-Gibbs
if(MWGlen > 0) {
### Random-Scan Componentwise Estimation
for (j in sample(MWG)) {
### Propose new parameter values
prop <- Mo0[["parm"]]
prop[j] <- rnorm(1, prop[j], tuning[j])
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: MWG proposal failed for",
Data[["parm.names"]][j], ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: MWG proposal for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
u <- log(runif(1)) < (Mo1[["LP"]] - Mo0[["LP"]])
if(u == TRUE) {
Mo0 <- Mo1
Acceptance[j] <- Acceptance[j] + 1}}}
}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
if(MWGlen > 0) Acceptance <- mean(as.vector(Acceptance[,MWG]))
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=tuning)
return(out)
}
.mcmcgg <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, Debug,
LogFile)
{
Grid <- Specs[["Grid"]]
dparm <- Specs[["dparm"]]
CPUs <- Specs[["CPUs"]]
Packages <- Specs[["Packages"]]
Dyn.libs <- Specs[["Dyn.libs"]]
if(CPUs == 1) {
for (iter in 1:Iterations) {
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
for (j in sample.int(LIV)) {
if(j %in% dparm)
Mo0 <- .mcmcggdp(Model, Data, j, Mo0, Grid, Debug,
LogFile)
else Mo0 <- .mcmcggcp(Model, Data, j, Mo0, Grid, Debug,
LogFile)
}
if(iter %% Thinning == 0) {
t.iter <- floor(iter/Thinning) + 1
thinned[t.iter, ] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter, ] <- Mo0[["Monitor"]]}}
}
else {
detectedCores <- detectCores()
cat("\n\nCPUs Detected:", detectedCores, "\n", file=LogFile,
append=TRUE)
if(CPUs > detectedCores) {
cat("\nOnly", detectedCores, "will be used.\n",
file=LogFile, append=TRUE)
CPUs <- detectedCores}
cat("\nLaplace's Demon is preparing environments for CPUs...",
file=LogFile, append=TRUE)
cat("\n##################################################\n",
file=LogFile, append=TRUE)
cl <- makeCluster(CPUs)
cat("\n##################################################\n",
file=LogFile, append=TRUE)
on.exit(stopCluster(cl))
varlist <- unique(c(ls(), ls(envir=.GlobalEnv),
ls(envir=parent.env(environment()))))
clusterExport(cl, varlist=varlist, envir=environment())
clusterSetRNGStream(cl)
wd <- getwd()
clusterExport(cl, varlist=c("Packages", "Dyn.libs", "wd"),
envir=environment())
for (iter in 1:Iterations) {
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
for (j in sample.int(LIV)) {
if(j %in% dparm)
Mo0 <- .mcmcggdpp(Model, Data, j, Mo0, Grid,
Debug, LogFile, cl)
else Mo0 <- .mcmcggcpp(Model, Data, j, Mo0, Grid,
Debug, LogFile, cl)
}
if(iter %% Thinning == 0) {
t.iter <- floor(iter/Thinning) + 1
thinned[t.iter, ] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter, ] <- Mo0[["Monitor"]]}}}
out <- list(Acceptance=Iterations, Dev=Dev, DiagCovar=DiagCovar,
Mon=Mon, thinned=thinned, VarCov=.colVars(thinned))
return(out)
}
### Griddy-Gibbs Continuous Parameter (Non-Parallelized)
.mcmcggcp <- function(Model, Data, j, Mo0, Grid, Debug, LogFile)
{
G <- length(Grid[[j]])
LP.grid <- rep(0, G)
prop <- Mo0[["parm"]]
theta <- prop[j] + Grid[[j]]
for (g in 1:G) {
prop[j] <- theta[g]
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating",
Data[["parm.names"]][j], "at",
round(prop[j],5), "failed.\n", file=LogFile,
append=TRUE)
Mo1 <- Mo0}
LP.grid[g] <- Mo1[["LP"]]
theta[g] <- Mo1[["parm"]][j]}
if(all(!is.finite(LP.grid))) LP.grid <- rep(0, G)
LP.grid[which(!is.finite(LP.grid))] <- min(LP.grid[which(is.finite(LP.grid))])
LP.grid <- exp(LP.grid - logadd(LP.grid))
LP.grid <- LP.grid / sum(LP.grid)
s <- spline(theta, LP.grid, n=1000)
s$y <- interval(s$y, 0, Inf, reflect=FALSE)
if(length(which(s$y > 0)) == 0)
prop[j] <- theta[which.max(LP.grid)[1]]
else prop[j] <- sample(s$x, 1, prob=s$y)
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating", Data[["parm.names"]][j],
"at", round(prop[j],5), "failed.\n",
file=LogFile, append=TRUE)
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating", Data[["parm.names"]][j],
"at", round(prop[j],5),
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
Mo1 <- Mo0}
Mo0 <- Mo1
return(Mo0)
}
### Griddy-Gibbs Continuous Parameter (Parallelized)
.mcmcggcpp <- function(Model, Data, j, Mo0, Grid, Debug, LogFile, cl)
{
G <- length(Grid[[j]])
LP.grid <- rep(0, G)
LIV <- length(Mo0[["parm"]])
prop <- matrix(Mo0[["parm"]], G, LIV, byrow=TRUE)
prop[, j] <- prop[, j] + Grid[[j]]
Mo1 <- parLapply(cl, 1:G,
function(x) Model(prop[x,], Data))
LP.grid <- as.vector(unlist(lapply(Mo1,
function(x) x[["LP"]])))
prop <- matrix(as.vector(unlist(lapply(Mo1,
function(x) x[["parm"]]))), G, LIV, byrow=TRUE)
theta <- prop[, j]
if(all(!is.finite(LP.grid))) LP.grid <- rep(0, G)
LP.grid[which(!is.finite(LP.grid))] <- min(LP.grid[which(is.finite(LP.grid))])
LP.grid <- exp(LP.grid - logadd(LP.grid))
LP.grid <- LP.grid / sum(LP.grid)
s <- spline(theta, LP.grid, n=1000)
s$y <- interval(s$y, 0, Inf, reflect=FALSE)
prop <- Mo0[["parm"]]
if(length(which(s$y > 0)) == 0)
prop[j] <- theta[which.max(LP.grid)[1]]
else prop[j] <- sample(s$x, 1, prob=s$y)
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating", Data[["parm.names"]][j],
"at", round(prop[j],5), "failed.\n",
file=LogFile, append=TRUE)
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating", Data[["parm.names"]][j],
"at", round(prop[j],5),
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
Mo1 <- Mo0}
Mo0 <- Mo1
return(Mo0)
}
### Griddy-Gibbs Discrete Parameter (Non-Parallelized)
#where j is which parameter, and Grid are discrete values
.mcmcggdp <- function(Model, Data, j, Mo0, Grid, Debug, LogFile)
{
G <- length(Grid[[j]])
LP.grid <- rep(0, G)
prop <- Mo0[["parm"]]
theta <- Grid[[j]]
for (g in 1:G) {
prop[j] <- theta[g]
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating",
Data[["parm.names"]][j], "at",
round(prop[j],5), "failed.\n", file=LogFile,
append=TRUE)
Mo1 <- Mo0}
LP.grid[g] <- Mo1[["LP"]]
theta[g] <- Mo1[["parm"]][j]}
if(all(!is.finite(LP.grid))) LP.grid <- rep(0, G)
LP.grid[which(!is.finite(LP.grid))] <- min(LP.grid[which(is.finite(LP.grid))])
LP.grid <- exp(LP.grid - logadd(LP.grid))
LP.grid <- LP.grid / sum(LP.grid)
prop[j] <- sample(theta, 1, prob=LP.grid)
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating", Data[["parm.names"]][j],
"at", round(prop[j],5), "failed.\n",
file=LogFile, append=TRUE)
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating", Data[["parm.names"]][j],
"at", round(prop[j],5),
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
Mo1 <- Mo0}
Mo0 <- Mo1
return(Mo0)
}
### Griddy-Gibbs Discrete Parameter (Parallelized)
.mcmcggdpp <- function(Model, Data, j, Mo0, Grid, Debug, LogFile, cl)
{
G <- length(Grid[[j]])
LP.grid <- rep(0, G)
LIV <- length(Mo0[["parm"]])
prop <- matrix(Mo0[["parm"]], G, LIV, byrow=TRUE)
prop[, j] <- prop[, j] + Grid[[j]]
Mo1 <- parLapply(cl, 1:G,
function(x) Model(prop[x,], Data))
LP.grid <- as.vector(unlist(lapply(Mo1,
function(x) x[["LP"]])))
prop <- matrix(as.vector(unlist(lapply(Mo1,
function(x) x[["parm"]]))), G, LIV, byrow=TRUE)
theta <- prop[, j]
prop <- Mo0[["parm"]]
if(all(!is.finite(LP.grid))) LP.grid <- rep(0, G)
LP.grid[which(!is.finite(LP.grid))] <- min(LP.grid[which(is.finite(LP.grid))])
LP.grid <- exp(LP.grid - logadd(LP.grid))
LP.grid <- LP.grid / sum(LP.grid)
prop[j] <- sample(theta, 1, prob=LP.grid)
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating", Data[["parm.names"]][j],
"at", round(prop[j],5), "failed.\n",
file=LogFile, append=TRUE)
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating", Data[["parm.names"]][j],
"at", round(prop[j],5),
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
Mo1 <- Mo0}
Mo0 <- Mo1
return(Mo0)
}
.mcmcharm <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned,
Debug, LogFile)
{
alpha.star <- Specs[["alpha.star"]]
Block <- Specs[["B"]]
if(is.na(alpha.star) & {length(Block) == 0}) {
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter, sep="", file=LogFile,
append=TRUE)
### Propose new parameter values
theta <- rnorm(LIV)
d <- theta / sqrt(sum(theta*theta))
prop <- Mo0[["parm"]] + runif(1) * d
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal resulted in non-finite",
"value(s).\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
Acceptance <- Acceptance + 1}}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
else if(is.na(alpha.star) & {length(Block) > 0}) {
B <- length(Block)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter, sep="", file=LogFile,
append=TRUE)
### Proceed by Block
for (b in 1:B) {
### Propose new parameter values
theta <- rnorm(length(Block[[b]]))
d <- theta / sqrt(sum(theta*theta))
prop <- Mo0[["parm"]]
prop[Block[[b]]] <- prop[Block[[b]]] + runif(1) * d
if({b == 1} & {iter %% Status == 0})
cat(", Proposal: Blockwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal resulted in",
"non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
Acceptance <- Acceptance +
length(Block[[b]]) / LIV}}
}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
else if(length(Block) == 0) {
tau <- 1
DiagCovar <- matrix(tau, nrow(thinned), LIV)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter, sep="", file=LogFile,
append=TRUE)
### Propose new parameter values
theta <- rnorm(LIV)
d <- theta / sqrt(sum(theta*theta))
prop <- Mo0[["parm"]] + runif(1,0,tau) * d
if(iter %% Status == 0)
cat(", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal resulted in non-finite",
"value(s).\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
Acceptance <- Acceptance + 1
tau <- tau + (tau / (alpha.star *
(1 - alpha.star))) * (1 - alpha.star) / iter
}
else {
tau <- abs(tau - (tau / (alpha.star *
(1 - alpha.star))) * alpha.star / iter)}}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]
DiagCovar[t.iter,] <- tau}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
else {
B <- length(Block)
tau <- rep(1,B)
DiagCovar <- matrix(1, nrow(thinned), LIV)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter, sep="", file=LogFile,
append=TRUE)
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
### Proceed by Block
for (b in 1:B) {
### Propose new parameter values
theta <- rnorm(length(Block[[b]]))
d <- theta / sqrt(sum(theta*theta))
prop <- Mo0[["parm"]]
prop[Block[[b]]] <- prop[Block[[b]]] +
runif(1,0,tau[b]) * d
if({b == 1} & {iter %% Status == 0})
cat(", Proposal: Blockwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal resulted in",
"non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
Acceptance <- Acceptance +
length(Block[[b]]) / LIV
tau[b] <- tau[b] + (tau[b] / (alpha.star *
(1 - alpha.star))) * (1 - alpha.star) / iter
if(iter %% Thinning == 0) {
thinned[t.iter,] <- Mo1[["parm"]]
Dev[t.iter] <- Mo1[["Dev"]]
Mon[t.iter,] <- Mo1[["Monitor"]]
DiagCovar[t.iter, Block[[b]]] <- tau[b]}
}
else {
tau[b] <- abs(tau[b] - (tau[b] / (alpha.star *
(1 - alpha.star))) * alpha.star / iter)
if(iter %% Thinning == 0)
DiagCovar[t.iter, Block[[b]]] <- tau[b]}
}
}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
}
.mcmchmc <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, VarCov,
Debug, LogFile)
{
epsilon <- Specs[["epsilon"]]
L <- Specs[["L"]]
m <- Specs[["m"]]
invm <- as.inverse(m)
U <- chol(m)
gr0 <- partial(Model, Mo0[["parm"]], Data)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Propose new parameter values
prop <- Mo0[["parm"]]
momentum0 <- as.vector(rnorm(LIV) %*% U)
kinetic0 <- t(momentum0) %*% invm %*% momentum0 / 2
momentum1 <- momentum0 + (epsilon/2) * gr0
Mo0.1 <- Mo0
for (l in 1:L) {
prop <- prop + as.vector(epsilon %*% invm) * momentum1
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed in leapfrog", l,
".\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0.1
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in leapfrog", l,
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0.1}
if(any(Mo0.1[["parm"]] == Mo1[["parm"]])) {
nomove <- which(Mo0.1[["parm"]] == Mo1[["parm"]])
momentum1[nomove] <- -momentum1[nomove]
prop[nomove] <- prop[nomove] + momentum1[nomove]
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed in leapfrog",
l, ".\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0.1
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in leapfrog",
l, "resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0.1}}
Mo0.1 <- Mo1
prop <- Mo1[["parm"]]
gr1 <- partial(Model, prop, Data)
if(l < L) momentum1 <- momentum1 + epsilon * gr1}
momentum1 <- momentum1 + (epsilon/2) * gr1
momentum1 <- -momentum1
kinetic1 <- t(momentum1) %*% invm %*% momentum1 / 2
### Accept/Reject
H0 <- -Mo0[["LP"]] + kinetic0
H1 <- -Mo1[["LP"]] + kinetic1
delta <- H1 - H0
alpha <- min(1, exp(-delta))
if(!is.finite(alpha)) alpha <- 0
if(runif(1) < alpha) {
Mo0 <- Mo1
kinetic0 <- kinetic1
gr0 <- gr1
Acceptance <- Acceptance + 1}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=matrix(epsilon, 1, LIV),
Mon=Mon,
thinned=thinned,
VarCov=cov(thinned))
return(out)
}
.mcmchmcda <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, Debug,
LogFile)
{
A <- Specs[["A"]]
delta <- Specs[["delta"]]
epsilon <- Specs[["epsilon"]]
Lmax <- Specs[["Lmax"]]
lambda <- Specs[["lambda"]]
leapfrog <- function(theta, r, grad, epsilon, Model, Data, Mo0, Debug)
{
rprime <- r + 0.5 * epsilon * grad
thetaprime <- theta + epsilon * rprime
Mo1 <- try(Model(thetaprime, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed in leapfrog.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(thetaprime, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in leapfrog",
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(thetaprime, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0}
thetaprime <- Mo1[["parm"]]
gradprime <- partial(Model, thetaprime, Data)
rprime <- rprime + 0.5 * epsilon * gradprime
out <- list(thetaprime=thetaprime,
rprime=rprime,
gradprime=gradprime,
Mo1=Mo1)
return(out)
}
find.reasonable.epsilon <- function(theta0, grad0, Mo0, Model, Data,
LogFile)
{
cat("\nFinding a reasonable initial value for epsilon...",
file=LogFile, append=TRUE)
epsilon <- 0.001
r0 <- runif(length(theta0))
### Figure out which direction to move epsilon
leap <- leapfrog(theta0, r0, grad0, epsilon, Model, Data, Mo0,
Debug)
if(!is.finite(leap$Mo1[["LP"]]))
stop("LP is not finite in find.reasonable.epsilon().",
file=LogFile, append=TRUE)
acceptprob <- exp(leap$Mo1[["LP"]] - Mo0[["LP"]] - 0.5 *
(as.vector(leap$rprime %*% leap$rprime) -
as.vector(r0 %*% r0)))
a <- 2 * (acceptprob > 0.5) - 1
### Keep moving epsilon in that direction until acceptprob
### crosses 0.5
while (acceptprob^a > 2^(-a)) {
epsilon <- epsilon * 2^a
leap <- leapfrog(theta0, r0, grad0, epsilon, Model, Data,
Mo0, Debug)
if(!is.finite(leap$Mo1[["LP"]]))
stop("LP is not finite in find.reasonable.epsilon().",
file=LogFile, append=TRUE)
acceptprob <- exp(leap$Mo1[["LP"]] - Mo0[["LP"]] - 0.5 *
(as.vector(leap$rprime %*% leap$rprime) -
as.vector(r0 %*% r0)))
}
cat("\nepsilon: ", round(max(epsilon,0.001),5), "\n\n", sep="",
file=LogFile, append=TRUE)
return(epsilon)
}
gr0 <- partial(Model, Mo0[["parm"]], Data)
if(is.null(epsilon))
epsilon <- find.reasonable.epsilon(Mo0[["parm"]], gr0, Mo0, Model,
Data, LogFile)
DiagCovar[1,] <- epsilon
L <- max(1, round(lambda / epsilon))
L <- min(L, Lmax)
### Dual-Averaging Parameters
epsilonbar <- 1
gamma <- 0.05
Hbar <- 0
kappa <- 0.75
mu <- log(10*epsilon)
t0 <- 10
### Begin HMCDA
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Propose new parameter values
prop <- Mo0[["parm"]]
momentum1 <- momentum0 <- runif(LIV)
joint <- Mo0[["LP"]] - 0.5 * as.vector(momentum0 %*% momentum0)
L <- max(1, round(lambda / epsilon))
L <- min(L, Lmax)
gr1 <- gr0
Mo0.1 <- Mo0
### Leapfrog Function
for (l in 1:L) {
momentum1 <- momentum1 + 0.5 * epsilon * gr1
prop <- prop + epsilon * momentum1
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed in leapfrog", l,
".\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""),"\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0.1
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in leapfrog", l,
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0.1}
if(any(Mo0.1[["parm"]] == Mo1[["parm"]])) {
nomove <- which(Mo0.1[["parm"]] == Mo1[["parm"]])
momentum1[nomove] <- -momentum1[nomove]
prop[nomove] <- prop[nomove] + momentum1[nomove]
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed in leapfrog",
l, ".\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0.1
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in leapfrog", l,
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0.1}}
Mo0.1 <- Mo1
prop <- Mo1[["parm"]]
gr1 <- partial(Model, prop, Data)
momentum1 <- momentum1 + epsilon * gr1}
### Accept/Reject
alpha <- min(1,
exp(prop - 0.5 * as.vector(momentum1 %*% momentum1) - joint))
if(!is.finite(alpha)) alpha <- 0
if(runif(1) < alpha) {
Mo0 <- Mo1
gr0 <- gr1
Acceptance <- Acceptance + 1}
### Adaptation
if(iter > 1) {
eta <- 1 / (iter - 1 + t0)
Hbar <- (1 - eta) * Hbar + eta * (delta - alpha)
if(iter <= A) {
epsilon <- exp(mu - sqrt(iter-1)/gamma * Hbar)
eta <- (iter-1)^-kappa
epsilonbar <- exp((1 - eta) * log(epsilonbar) +
eta * log(epsilon))
DiagCovar <- rbind(DiagCovar, epsilon)}
else epsilon <- epsilonbar}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
.mcmcim <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, VarCov,
Debug, LogFile)
{
mu <- Specs[["mu"]]
VarCov <- as.positive.definite(as.symmetric.matrix(VarCov * 1.1))
Omega <- as.inverse(VarCov)
U <- chol(VarCov)
d <- eigen(VarCov, symmetric=TRUE)$values
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter, sep="", file=LogFile, append=TRUE)
### Propose new parameter values
MVNz <- try(rbind(rnorm(LIV)) %*% U, silent=TRUE)
if(!inherits(MVNz, "try-error")) {
if(iter %% Status == 0)
cat(", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
prop <- as.vector(mu) + as.vector(MVNz)}
else {prop <- as.vector(Mo0[["parm"]])}
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal resulted in non-finite",
"value(s).\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
### Importance Densities (dmvn)
ss <- prop - mu
z <- rowSums({ss %*% Omega} * ss)
d1 <- sum(-0.5 * (LIV * log(2*pi) + sum(log(d))) - (0.5*z))
ss <- Mo0[["parm"]] - mu
z <- rowSums({ss %*% Omega} * ss)
d0 <- sum(-0.5 * (LIV * log(2*pi) + sum(log(d))) - (0.5*z))
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]] + d1 - d0
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
Acceptance <- Acceptance + 1}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=cov(thinned))
return(out)
}
.mcmcinca <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, tuning,
VarCov, Debug, LogFile)
{
Adaptive <- Specs[["Adaptive"]]
Periodicity <- Specs[["Periodicity"]]
post <- matrix(Mo0[["parm"]], Iterations, LIV, byrow=TRUE)
Iden.Mat <- diag(LIV)
con <- get("con")
Chains <- get("Chains")
DiagCovar <- matrix(0, floor(Iterations/Periodicity), LIV)
### Store all posteriors
INCA_iter <- 1
INCA_first <- TRUE
tmpMean <- numeric(LIV)
tmpCov <- matrix(0, LIV, LIV)
tmpAlpha <- numeric(Periodicity)
lambda <- ScaleF
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter, sep="", file=LogFile, append=TRUE)
### Current Posterior
if(iter > 1) post[iter,] <- post[iter-1,]
### Propose new parameter values
MVNz <- try(rbind(rnorm(LIV)) %*% chol(VarCov),
silent=!Debug[["DB.chol"]])
if(!inherits(MVNz, "try-error") &
((Acceptance / iter) >= 0.05)) {
if(iter %% Status == 0)
cat(", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
prop <- as.vector(post[iter,]) + as.vector(MVNz)}
else {
if(iter %% Status == 0)
cat(", Proposal: Single-Component, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
if(Debug[["DB.chol"]] == TRUE)
cat("\nWARNING: Cholesky decomposition failed for",
"proposal in iteration", iter, ".\n",
file=LogFile, append=TRUE)
prop <- post[iter,]
j <- ceiling(runif(1,0,LIV))
prop[j] <- rnorm(1, post[iter,j], tuning[j])}
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal resulted in non-finite",
"value(s).\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
post[iter,] <- Mo1[["parm"]]
Acceptance <- Acceptance + 1}}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- post[iter,]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
### Save log.alpha
if({iter %% Periodicity} == 0)
tmpAlpha[Periodicity] <- min(1, exp(log.alpha))
else tmpAlpha[(iter %% Periodicity)] <- min(1, exp(log.alpha))
### Shrinkage of Adaptive Proposal Variance
if({iter < Adaptive} & {Acceptance > 5} &
{Acceptance / iter < 0.05}) {
VarCov <- VarCov * {1 - {1 / Iterations}}
tuning <- tuning * {1 - {1 / Iterations}}}
### Adapt the Proposal Variance
if({iter >= Adaptive} & {iter %% Periodicity == 0}) {
select_post <- cbind(post[(iter-Periodicity+1):iter,],
tmpAlpha)
### Ask for last posteriors to hpc_server
tmp <- unserialize(con)
### Send new posteriors matrix to hpc_server
serialize(select_post, con)
if(is.matrix(tmp) && INCA_first == FALSE) {
for (i in 1:nrow(select_post)) {
tmpMean <- tmpMean + 1/(INCA_iter+1) *
(select_post[i, 1:LIV]-tmpMean)
tmpCov <- (INCA_iter-1)/INCA_iter * tmpCov +
1/INCA_iter *
tcrossprod(select_post[i, 1:LIV]-tmpMean)
INCA_iter <- INCA_iter + 1}
for (i in 1:nrow(tmp)) {
tmpMean <- tmpMean + 1/(INCA_iter+1) *
(tmp[i, 1:LIV]-tmpMean)
tmpCov <- (INCA_iter-1)/INCA_iter * tmpCov +
1/INCA_iter *
tcrossprod(tmp[i, 1:LIV]-tmpMean)
INCA_iter <- INCA_iter + 1}
eta <- INCA_iter^-0.6
m1 <- median(select_post[, LIV+1])
m2 <- median(tmp[, LIV+1])
lambda <- exp(log(lambda) + eta * (m1 - 0.234))
lambda <- exp(log(lambda) + eta * (m2 - 0.234))}
if(INCA_first == TRUE) {
for (i in 1:iter) {
tmpMean <- tmpMean + 1/(INCA_iter+1) *
(post[i, ]-tmpMean)
tmpCov <- (INCA_iter-1)/INCA_iter * tmpCov +
1/INCA_iter *
tcrossprod(post[i, ] - tmpMean)
INCA_iter <- INCA_iter + 1}
INCA_first <- FALSE}
VarCov <- lambda * (tmpCov + 1e-9 * Iden.Mat)
a.iter <- floor(iter / Periodicity)
DiagCovar[a.iter,] <- diag(VarCov)
### Univariate Standard Deviations
tuning <- sqrt(diag(VarCov))}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=VarCov)
return(out)
}
.mcmcmala <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned,
VarCov, Debug, LogFile)
{
A <- Specs[["A"]]
alpha.star <- Specs[["alpha.star"]]
delta <- Specs[["delta"]]
gamma.const <- Specs[["gamma"]]
epsilon <- Specs[["epsilon"]]
Gamm <- as.positive.definite(VarCov)
mu <- Mo0[["parm"]]
sigma2 <- 1 / (LIV*LIV)
DiagCovar <- matrix(diag(Gamm), nrow(thinned), LIV)
Iden <- diag(LIV)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Propose new parameter values
gr <- partial(Model, Mo0[["parm"]], Data)
Dx <- {delta/max(delta, abs(gr))}*gr
gamm <- min(gamma.const/iter, 1)
Lambda <- Gamm + epsilon[2]*Iden
U <- try(chol(sigma2*Lambda), silent=!Debug[["DB.chol"]])
if(inherits(U, "try-error")) {
if(Debug[["DB.chol"]] == TRUE)
cat("\nWARNING: Cholesky decomposition failed for",
"proposal in iteration", iter, ".\n",
file=LogFile, append=TRUE)
U <- chol(as.positive.definite(sigma2*Lambda))}
prop <- as.vector((Mo0[["parm"]] +
{sigma2/2}*as.vector(Lambda %*% Dx)*Dx) +
rbind(rnorm(LIV)) %*% U)
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal resulted in non-finite",
"value(s).\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
Acceptance <- Acceptance + 1}}
### Adapt Gamma (first, since it uses mu[t] not [t+1])
xmu <- Mo0[["parm"]] - mu
Gamm.prop <- Gamm + gamm*{xmu %*% t(xmu) - Gamm}
norm.Gamm <- norm(Gamm.prop, type="F")
if(norm.Gamm <= A) Gamm <- Gamm.prop
else if(!is.finite(norm.Gamm)) Gamm <- sigma2*Iden
else Gamm <- {A/norm.Gamm}*Gamm.prop
### Adapt mu
mu.prop <- mu + gamm*(Mo0[["parm"]] - mu)
norm.mu <- sqrt(sum(mu.prop*mu.prop))
if(norm.mu <= A) mu <- mu.prop
else mu <- {A/norm.mu}*mu.prop
### Adapt sigma
sigma2 <- interval(sqrt(sigma2) +
gamm*(min(exp(log.alpha),1) - alpha.star),
epsilon[1], A, reflect=FALSE)^2
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]
DiagCovar[t.iter,] <- diag(Lambda)}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=Lambda)
return(out)
}
.mcmcmcmcmc <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, tuning,
VarCov, Debug, LogFile)
{
lambda <- Specs[["lambda"]]
CPUs <- Specs[["CPUs"]]
Packages <- Specs[["Packages"]]
Dyn.libs <- Specs[["Dyn.libs"]]
detectedCores <- detectCores()
cat("\n\nCPUs Detected:", detectedCores, "\n", file=LogFile,
append=TRUE)
if(CPUs > detectedCores) {
cat("\nOnly", detectedCores, "will be used.\n",
file=LogFile, append=TRUE)
CPUs <- detectedCores}
cat("\nLaplace's Demon is preparing environments for CPUs...",
file=LogFile, append=TRUE)
cat("\n##################################################\n",
file=LogFile, append=TRUE)
cl <- makeCluster(CPUs)
cat("\n##################################################\n",
file=LogFile, append=TRUE)
on.exit(stopCluster(cl))
varlist <- unique(c(ls(), ls(envir=.GlobalEnv),
ls(envir=parent.env(environment()))))
clusterExport(cl, varlist=varlist, envir=environment())
clusterSetRNGStream(cl)
wd <- getwd()
clusterExport(cl, varlist=c("Packages", "Dyn.libs", "wd"),
envir=environment())
if(length(lambda) == 1) Temperature <- 1/(1 + lambda*(c(1:CPUs) - 1))
else if(length(lambda) == LIV) Temperature <- lambda
else Temperature <- 1/(1 + lambda[1]*(c(1:CPUs) - 1))
coolest <- which.max(Temperature)[1]
temp <- Mo0
Mo0 <- list()
for (i in 1:CPUs) Mo0[[i]] <- temp
prop <- matrix(Mo0[[1]][["parm"]], CPUs, LIV, byrow=TRUE)
Acceptance.swap <- 0
U <- chol(VarCov)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[[coolest]][["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[[coolest]][["parm"]]
Dev[t.iter] <- Mo0[[coolest]][["Dev"]]
Mon[t.iter,] <- Mo0[[coolest]][["Monitor"]]}
### Propose new parameter values
for (i in 1:CPUs)
prop[i,] <- Mo0[[i]][["parm"]] + rbind(rnorm(LIV)) %*% U
### Log-Posterior of the proposed state
Mo1 <- parLapply(cl, 1:CPUs, function(x)
try(Model(prop[x,], Data), silent=!Debug[["DB.Model"]]))
for (i in 1:CPUs) {
if(inherits(Mo1[[i]], "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed in chain", i,
".\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[i,], collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1[[i]] <- Mo0[[i]]
}
else if(any(!is.finite(c(Mo1[[i]][["LP"]], Mo1[[i]][["Dev"]],
Mo1[[i]][["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in chain", i,
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[i,], collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1[[i]] <- Mo0[[i]]
}
}
### Accept/Reject
for (i in 1:CPUs) {
log.u <- log(runif(1))
log.alpha <- (Mo1[[i]][["LP"]] - Mo0[[i]][["LP"]]) /
Temperature[i]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0[[i]] <- Mo1[[i]]
if(i == coolest) {
Acceptance <- Acceptance + 1
if(iter %% Thinning == 0) {
thinned[t.iter,] <- Mo1[[i]][["parm"]]
Dev[t.iter] <- Mo1[[i]][["Dev"]]
Mon[t.iter,] <- Mo1[[i]][["Monitor"]]}}}}
### Swap
swap <- sample.int(CPUs, 2)
log.u <- log(runif(1))
log.alpha <- {(Mo0[[swap[1]]][["LP"]] - Mo0[[swap[2]]][["LP"]]) /
Temperature[swap[2]]} +
{(Mo0[[swap[2]]][["LP"]] - Mo0[[swap[1]]][["LP"]]) /
Temperature[swap[1]]}
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Acceptance.swap <- Acceptance.swap + 1
temp <- Mo0[[swap[2]]]
Mo0[[swap[2]]] <- Mo0[[swap[1]]]
Mo0[[swap[1]]] <- temp
if({swap[1] == coolest} & {iter %% Thinning == 0}) {
thinned[t.iter,] <- Mo0[[swap[1]]][["parm"]]
Dev[t.iter] <- Mo0[[swap[1]]][["Dev"]]
Mon[t.iter,] <- Mo0[[swap[1]]][["Monitor"]]}}
}
cat("\nSwap Acceptance Rate:",
round(Acceptance.swap / Iterations, 5), "\n", file=LogFile,
append=TRUE)
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=VarCov)
return(out)
}
.mcmcmtm <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, thinned, tuning, Debug,
LogFile)
{
K <- Specs[["K"]]
CPUs <- Specs[["CPUs"]]
Packages <- Specs[["Packages"]]
Dyn.libs <- Specs[["Dyn.libs"]]
if(CPUs > 1) {
detectedCores <- detectCores()
cat("\n\nCPUs Detected:", detectedCores, "\n", file=LogFile,
append=TRUE)
if(CPUs > detectedCores) {
cat("\nOnly", detectedCores, "will be used.\n",
file=LogFile, append=TRUE)
CPUs <- detectedCores}
cat("\nLaplace's Demon is preparing environments for CPUs...",
file=LogFile, append=TRUE)
cat("\n##################################################\n",
file=LogFile, append=TRUE)
cl <- makeCluster(CPUs)
cat("\n##################################################\n",
file=LogFile, append=TRUE)
on.exit(stopCluster(cl))
varlist <- unique(c(ls(), ls(envir=.GlobalEnv),
ls(envir=parent.env(environment()))))
clusterExport(cl, varlist=varlist, envir=environment())
clusterSetRNGStream(cl)
wd <- getwd()
clusterExport(cl, varlist=c("Packages", "Dyn.libs", "wd"),
envir=environment())}
Acceptance <- matrix(0, 1, LIV)
Mo1 <- list()
for (k in 1:K) Mo1[[k]] <- Mo0
LW <- LP <- rep(0, K)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Random-Scan Componentwise Estimation
for (j in sample.int(LIV)) {
### Propose new parameter values
prop1 <- matrix(Mo0[["parm"]], K, LIV, byrow=TRUE)
prop1[,j] <- rnorm(K, prop1[,j], tuning[j])
### Log-Posterior of the proposed states
if(CPUs == 1) {
### Non-parallel
for (k in 1:K) {
Mo1[[k]] <- try(Model(prop1[k,], Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1[[k]], "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal ", k,
"failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop1[k,j],5),
file=LogFile, append=TRUE)}
Mo1[[k]] <- Mo0
}
else if(any(!is.finite(c(Mo1[[k]][["LP"]],
Mo1[[k]][["Dev"]],
Mo1[[k]][["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal ", k,
"resulted in non-finite",
"value(s).\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop1[k,j],5),
file=LogFile, append=TRUE)}
Mo1[[k]] <- Mo0}
LP[k] <- LW[k] <- Mo1[[k]][["LP"]]
prop1[k,] <- Mo1[[k]][["parm"]]}
}
else {
### Parallel
Mo1 <- parLapply(cl, 1:K, function(x)
try(Model(prop1[x,], Data),
silent=!Debug[["DB.Model"]]))
for (k in 1:K) {
if(inherits(Mo1[[k]], "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal ", k,
"failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop1[k,j],5),
file=LogFile, append=TRUE)}
Mo1[[k]] <- Mo0
}
else if(any(!is.finite(c(Mo1[[k]][["LP"]],
Mo1[[k]][["Dev"]],
Mo1[[k]][["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal ", k,
"resulted in non-finite",
"value(s).\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop1[k,j],5),
file=LogFile, append=TRUE)}
Mo1[[k]] <- Mo0}
LP[k] <- LW[k] <- Mo1[[k]][["LP"]]
prop1[k,] <- Mo1[[k]][["parm"]]}
}
### Normalize Weights
w <- exp(LW - logadd(LW))
if(all(w == 0)) w <- rep(1/K, K)
### Sample a Proposal
prop5 <- Mo0[["parm"]]
prop2 <- sample(prop1[,j], size=1, prob=w)
prop5[j] <- prop2
### Create Reference Set
Mo2 <- try(Model(prop5, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo2, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop5[j],5),
file=LogFile, append=TRUE)}
Mo2 <- Mo0}
prop3 <- c(rnorm(K-1, Mo2[["parm"]][j], tuning[j]),
Mo2[["parm"]][j])
prop4 <- prop1
prop4[,j] <- prop3
### Calculate Acceptance Probability
numerator <- logadd(LP)
denom <- rep(0, K)
if(CPUs == 1) {
### Non-parallel
for (k in 1:K) {
Mo1[[k]] <- try(Model(prop4[k,], Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1[[k]], "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal ", k,
"failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop4[k,j],5),
file=LogFile, append=TRUE)}
Mo1[[k]] <- Mo0
}
else if(any(!is.finite(c(Mo1[[k]][["LP"]],
Mo1[[k]][["Dev"]],
Mo1[[k]][["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal ", k,
"resulted in non-finite",
"value(s).\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop4[k,j],5),
file=LogFile, append=TRUE)}
Mo1[[k]] <- Mo0}
denom[k] <- Mo1[[k]][["LP"]]}
}
else {
### Parallel
Mo1 <- parLapply(cl, 1:K, function(x)
try(Model(prop4[x,], Data),
silent=!Debug[["DB.Model"]]))
for (k in 1:K) {
if(inherits(Mo1[[k]], "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal ", k,
"failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop4[k,j],5),
file=LogFile, append=TRUE)}
Mo1[[k]] <- Mo0
}
else if(any(!is.finite(c(Mo1[[k]][["LP"]],
Mo1[[k]][["Dev"]],
Mo1[[k]][["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal ", k,
"resulted in non-finite",
"value(s).\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop4[k,j],5),
file=LogFile, append=TRUE)}
Mo1[[k]] <- Mo0}
denom[k] <- Mo1[[k]][["LP"]]}}
denom <- logadd(denom)
### Accept/Reject
u <- log(runif(1)) < (numerator - denom)
if(u == TRUE) {
Mo0 <- Mo2
Acceptance[j] <- Acceptance[j] + 1}}
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=mean(as.vector(Acceptance)),
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
.mcmcmwg <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, tuning,
Debug, LogFile)
{
Block <- Specs[["B"]]
B <- length(Block)
Acceptance <- matrix(0, 1, LIV)
if(B == 0) {
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Random-Scan Componentwise Estimation
propdraw <- rnorm(LIV,0,tuning)
for (j in sample.int(LIV)) {
### Propose new parameter values
prop <- Mo0[["parm"]]
prop[j] <- prop[j] + propdraw[j]
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed for",
Data[["parm.names"]][j], ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
u <- log(runif(1)) < {Mo1[["LP"]] - Mo0[["LP"]]}
if(u == TRUE) {
Mo0 <- Mo1
Acceptance[j] <- Acceptance[j] + 1}}}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
}
else {
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Random-Scan Componentwise Estimation
propdraw <- rnorm(LIV,0,tuning)
### Proceed by Block
for (b in 1:B) {
for (j in sample(Block[[b]])) {
### Propose new parameter values
prop <- Mo0[["parm"]]
prop[j] <- prop[j] + propdraw[j]
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed for",
Data[["parm.names"]][j], ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
u <- log(runif(1)) < {Mo1[["LP"]] -
Mo0[["LP"]]}
if(u == TRUE) {
Mo0 <- Mo1
Acceptance[j] <- Acceptance[j] + 1}}}}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
}
### Output
out <- list(Acceptance=mean(as.vector(Acceptance)),
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=tuning)
return(out)
}
.mcmcnuts <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, Debug,
LogFile)
{
A <- Specs[["A"]]
delta <- Specs[["delta"]]
epsilon <- Specs[["epsilon"]]
Lmax <- Specs[["Lmax"]]
post <- matrix(Mo0[["parm"]], Iterations, LIV, byrow=TRUE)
leapfrog <- function(theta, r, grad, epsilon, Model, Data, Mo0, Debug)
{
rprime <- r + 0.5 * epsilon * grad
thetaprime <- theta + epsilon * rprime
Mo1 <- try(Model(thetaprime, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed in leapfrog.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(thetaprime, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in leapfrog",
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(thetaprime, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0}
thetaprime <- Mo1[["parm"]]
gradprime <- partial(Model, thetaprime, Data)
rprime <- rprime + 0.5 * epsilon * gradprime
out <- list(thetaprime=thetaprime,
rprime=rprime,
gradprime=gradprime,
Mo1=Mo1)
return(out)
}
stop.criterion <- function(thetaminus, thetaplus, rminus, rplus)
{
thetavec <- thetaplus - thetaminus
criterion <- (thetavec %*% rminus >= 0) &&
(thetavec %*% rplus >= 0)
return(criterion)
}
build.tree <- function(theta, r, grad, logu, v, j, epsilon, joint0, Mo0)
{
if(j == 0) {
### Base case: Take a single leapfrog step in direction v
leap <- leapfrog(theta=theta, r=r, grad=grad,
epsilon=v*epsilon, Model=Model, Data=Data, Mo0=Mo0,
Debug=Debug)
rprime <- leap$rprime
thetaprime <- leap$thetaprime
Mo1 <- leap$Mo1
gradprime <- leap$gradprime
joint <- Mo1[["LP"]] - 0.5 * as.vector(rprime %*% rprime)
### Is the new point in the slice?
nprime <- logu < joint
### Is the simulation wildly inaccurate?
sprime <- logu - 1000 < joint
# Set the return values---minus=plus for all things here,
# since the "tree" is of depth 0.
thetaminus <- thetaprime
thetaplus <- thetaprime
rminus <- rprime
rplus <- rprime
gradminus <- gradprime
gradplus <- gradprime
### Compute the acceptance probability
alphaprime <- min(1, exp(Mo1[["LP"]] - 0.5 *
as.vector(rprime %*% rprime) - joint0))
nalphaprime <- 1}
else {
# Recursion: Implicitly build the height j-1 left and
# right subtrees
tree <- build.tree(theta=theta, r=r, grad=grad, logu=logu,
v=v, j=j-1, epsilon=epsilon, joint=joint0, Mo0=Mo0)
thetaminus <- tree$thetaminus
rminus <- tree$rminus
gradminus <- tree$gradminus
thetaplus <- tree$thetaplus
rplus <- tree$rplus
gradplus <- tree$gradplus
thetaprime <- tree$thetaprime
gradprime <- tree$gradprime
Mo1 <- tree$Mo1
nprime <- tree$nprime
sprime <- tree$sprime
alphaprime <- tree$alphaprime
nalphaprime <- tree$nalphaprime
### If the first subtree stopping criterion is met, then stop
if(sprime == 1) {
if(v == -1) {
tree <- build.tree(theta=thetaminus, r=rminus,
grad=gradminus, logu=logu, v=v, j=j-1,
epsilon=epsilon, joint0=joint0, Mo0=Mo0)
thetaminus <- tree$thetaminus
rminus <- tree$rminus
gradminus <- tree$gradminus
thetaprime2 <- tree$thetaprime
gradprime2 <- tree$gradprime
Mo12 <- tree$Mo1
nprime2 <- tree$nprime
sprime2 <- tree$sprime
alphaprime2 <- tree$alphaprime
nalphaprime2 <- tree$nalphaprime
}
else {
tree <- build.tree(theta=thetaplus, r=rplus,
grad=gradplus, logu=logu, v=v, j=j-1,
epsilon=epsilon, joint0=joint0, Mo0=Mo0)
thetaplus <- tree$thetaplus
rplus <- tree$rplus
gradplus <- tree$gradplus
thetaprime2 <- tree$thetaprime
gradprime2 <- tree$gradprime
Mo12 <- tree$Mo1
nprime2 <- tree$nprime
sprime2 <- tree$sprime
alphaprime2 <- tree$alphaprime
nalphaprime2 <- tree$nalphaprime
}
### Choose a subtree to propagate a sample up from
temp <- nprime2 / (nprime + nprime2)
if(!is.finite(temp)) temp <- 0
if(runif(1) < temp) {
thetaprime <- thetaprime2
gradprime <- gradprime2
Mo1 <- Mo12}
### Update the number of valid points
nprime <- nprime + nprime2
### Update the stopping criterion
sprime <- sprime && sprime2 &&
stop.criterion(thetaminus, thetaplus, rminus,
rplus)
### Update acceptance probability statistics
alphaprime <- alphaprime + alphaprime2
nalphaprime <- nalphaprime + nalphaprime2}}
out <- list(thetaminus=thetaminus,
rminus=rminus,
gradminus=gradminus,
thetaplus=thetaplus,
rplus=rplus,
gradplus=gradplus,
thetaprime=thetaprime,
gradprime=gradprime,
Mo1=Mo1,
nprime=nprime,
sprime=sprime,
alphaprime=alphaprime,
nalphaprime=nalphaprime)
return(out)
}
find.reasonable.epsilon <- function(theta0, grad0, Mo0, Model, Data,
LogFile)
{
cat("\nFinding a reasonable initial value for epsilon...",
file=LogFile, append=TRUE)
epsilon <- 0.001
r0 <- runif(length(theta0))
### Figure out which direction to move epsilon
leap <- leapfrog(theta=theta0, r=r0, grad=grad0,
epsilon=epsilon, Model=Model, Data=Data, Mo0=Mo0,
Debug=Debug)
if(!is.finite(leap$Mo1[["LP"]]))
stop("LP is not finite in find.reasonable.epsilon().",
file=LogFile, append=TRUE)
acceptprob <- exp(leap$Mo1[["LP"]] - Mo0[["LP"]] - 0.5 *
(as.vector(leap$rprime %*% leap$rprime) -
as.vector(r0 %*% r0)))
a <- 2 * (acceptprob > 0.5) - 1
### Keep moving epsilon in that direction until acceptprob
### crosses 0.5
while (acceptprob^a > 2^(-a)) {
epsilon <- epsilon * 2^a
leap <- leapfrog(theta=theta0, r=r0, grad=grad0,
epsilon=epsilon, Model=Model, Data=Data, Mo0=Mo0,
Debug=Debug)
if(!is.finite(leap$Mo1[["LP"]]))
stop("LP is not finite in find.reasonable.epsilon().",
file=LogFile, append=TRUE)
acceptprob <- exp(leap$Mo1[["LP"]] - Mo0[["LP"]] - 0.5 *
(as.vector(leap$rprime %*% leap$rprime) -
as.vector(r0 %*% r0)))
}
cat("\nepsilon: ", round(max(epsilon,0.001),5), "\n\n", sep="",
file=LogFile, append=TRUE)
return(epsilon)
}
Count <- 0
evals <- 0
grad <- partial(Model, post[1,], Data)
if(is.null(epsilon))
epsilon <- find.reasonable.epsilon(theta0=post[1,], grad0=grad,
Mo0=Mo0, Model=Model, Data=Data, LogFile=LogFile)
DiagCovar[1,] <- epsilon
### Dual-Averaging Parameters
epsilonbar <- 1
gamma <- 0.05
Hbar <- 0
kappa <- 0.75
mu <- log(10*epsilon)
t0 <- 10
### Reset Dev, Mon, and thinned
if(A < Iterations) {
Dev <- matrix(Dev[1:(floor((Iterations-A)/Thinning)+1),])
Mon <- matrix(Mo0[["Monitor"]], floor((Iterations-A)/Thinning)+1,
length(Mo0[["Monitor"]]), byrow=TRUE)
thinned <- matrix(0, floor((Iterations-A)/Thinning)+1, LIV)}
### Begin NUTS
for (iter in 2:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Current Posterior
if(iter > 1) post[iter,] <- post[iter-1,]
### Save Thinned Samples
if(iter > A) {
if((iter-A) %% Thinning == 0) {
thinned[((iter-A)/Thinning+1),] <- post[iter,]
Dev[((iter-A)/Thinning+1)] <- Mo0[["Dev"]]
Mon[((iter-A)/Thinning+1),] <- Mo0[["Monitor"]]}}
else if(A >= Iterations) {
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- post[iter,]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}}
prop <- post[iter,]
r0 <- runif(LIV) ### r0 is momenta
### Joint log-probability of theta and momenta r
joint <- Mo0[["LP"]] - 0.5 * as.vector(r0 %*% r0)
### Resample u ~ U([0, exp(joint)])
logu <- joint - rexp(1)
### Initialize Tree
thetaminus <- prop
thetaplus <- prop
rminus <- r0
rplus <- r0
gradminus <- grad
gradplus <- grad
j <- 0 ### Initial height j=0
n <- 1 ### Initially, the only valid point is the initial point
s <- 1 ### Loop until s == 0
while (s == 1) {
### Choose a direction: -1=backward, 1=forward.
v <- 2*(runif(1) < 0.5) - 1
### Double the size of the tree.
if(v == -1) {
tree <- build.tree(theta=thetaminus, r=rminus,
grad=gradminus, logu=logu, v=v, j=j,
epsilon=epsilon, joint0=joint, Mo0=Mo0)
thetaminus <- tree$thetaminus
rminus <- tree$rminus
gradminus <- tree$gradminus
thetaprime <- tree$thetaprime
gradprime <- tree$gradprime
Mo1 <- tree$Mo1
nprime <- tree$nprime
sprime <- tree$sprime
alpha <- tree$alphaprime
nalpha <- tree$nalphaprime}
else {
tree <- build.tree(theta=thetaplus, r=rplus,
grad=gradplus, logu, v=v, j=j, epsilon=epsilon,
joint0=joint, Mo0=Mo0)
thetaplus <- tree$thetaplus
rplus <- tree$rplus
gradplus <- tree$gradplus
thetaprime <- tree$thetaprime
gradprime <- tree$gradprime
Mo1 <- tree$Mo1
nprime <- tree$nprime
sprime <- tree$sprime
alpha <- tree$alphaprime
nalpha <- tree$nalphaprime}
### Accept/Reject
Count <- Count + 1
if((sprime == 1) && (runif(1) < nprime/n)) {
post[iter,] <- thetaprime
Mo0 <- Mo1
grad <- gradprime
Acceptance <- Acceptance + 1
if(iter > A) {
if((iter-A) %% Thinning == 0) {
thinned[((iter-A)/Thinning+1),] <- Mo1[["parm"]]
Dev[((iter-A)/Thinning+1)] <- Mo1[["Dev"]]
Mon[((iter-A)/Thinning+1),] <- Mo1[["Monitor"]]}}
else if(A >= Iterations) {
if(iter %% Thinning == 0) {
thinned[t.iter,] <- Mo1[["parm"]]
Dev[t.iter] <- Mo1[["Dev"]]
Mon[t.iter,] <- Mo1[["Monitor"]]}}}
### Update number of observed valid points
n <- n + nprime
### Decide if it is time to stop
s <- sprime &&
stop.criterion(thetaminus, thetaplus, rminus, rplus)
### Increment depth
j <- j + 1
if(j*j >= Lmax) s <- 0}
### Adaptation of epsilon
eta <- 1 / (iter - 1 + t0)
Hbar <- (1 - eta) * Hbar + eta * (delta - alpha / nalpha)
if(iter <= A) {
epsilon <- exp(mu - sqrt(iter-1)/gamma * Hbar)
eta <- (iter-1)^-kappa
epsilonbar <- exp((1 - eta) * log(epsilonbar) +
eta * log(epsilon))
DiagCovar <- rbind(DiagCovar, epsilon)}
else epsilon <- epsilonbar
}
Acceptance <- round(Acceptance / Count * Iterations)
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
.mcmcohss <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned,
VarCov, Debug, LogFile)
{
A <- Specs[["A"]]
n <- Specs[["n"]]
w <- 0.05 # as with Roberts & Rosenthal
if(!is.symmetric.matrix(VarCov)) {
cat("\nAsymmetric Covar, correcting now...\n", file=LogFile,
append=TRUE)
VarCov <- as.symmetric.matrix(VarCov)}
if(!is.positive.definite(VarCov)) {
cat("\nNon-Positive-Definite Covar, correcting now...\n",
file=LogFile, append=TRUE)
VarCov <- as.positive.definite(VarCov)}
decomp.freq <- max(floor(Iterations / Thinning / 100), 10)
cat("\nEigendecomposition will occur every", decomp.freq,
"iterations.\n\n", file=LogFile, append=TRUE)
S.eig <-try(eigen(VarCov), silent=!Debug[["DB.eigen"]])
if(inherits(S.eig, "try-error")) {
if(Debug[["DB.eigen"]] == TRUE)
cat("\nWARNING: Eigendecomposition failed.\n",
file=LogFile, append=TRUE)
S.eig <- NULL
DiagCovar <- matrix(0, floor(Iterations/Thinning)+1, LIV)
}
else DiagCovar <- matrix(diag(S.eig$vectors),
floor(Iterations/Thinning)+1, LIV, byrow=TRUE)
tuning <- 1 #Tuning
edge.scale <- 5 #Tuning
if(A > Iterations)
post <- matrix(Mo0[["parm"]], Iterations, LIV, byrow=TRUE)
else post <- matrix(Mo0[["parm"]], A, LIV, byrow=TRUE)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Eigenvectors of the Sample Covariance Matrix
if({iter %% decomp.freq == 0} & {iter > 2} & {iter <= A}) {
VarCov2 <- try({VarCov*n +
cov(post[1:(iter-1),,drop=FALSE])*(iter-1)}/{n+iter-1},
silent=TRUE)
if(inherits(VarCov2, "try-error")) VarCov2 <- VarCov
if(!is.symmetric.matrix(VarCov2))
VarCov2 <- as.symmetric.matrix(VarCov2)
if(!is.positive.definite(VarCov2))
VarCov2 <- as.positive.definite(VarCov2)
S.eig <- try(eigen(VarCov2), silent=!Debug[["DB.eigen"]])
if(inherits(S.eig, "try-error")) {
if(Debug[["DB.eigen"]] == TRUE)
cat("\nWARNING: Eigendecomposition failed in",
"iteration", iter, ".\n",
file=LogFile, append=TRUE)
S.eig <- eigen(VarCov)}}
### Hypercube or Eigenvector
if(runif(1) < w || is.null(S.eig)) {
vals <- rep(tuning, LIV)
vecs <- diag(1, nrow=LIV)
}
else {
vals <- S.eig$values
vecs <- S.eig$vectors}
### Slice Interval
Mo0.1 <- try(Model(Mo0[["parm"]], Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo0.1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(Mo0[["parm"]], collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo0.1 <- Mo0}
Mo0 <- Mo0.1
y.slice <- Mo0[["LP"]] - rexp(1)
L <- -1 * runif(LIV)
U <- L + 1
### Rejection Sampling
repeat {
wt <- runif(LIV, min=L, max=U)
v <- as.numeric(vecs %*% {edge.scale * wt * vals})
prop <- Mo0[["parm"]] + v
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Rejection sampling failed.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Rejection sampling resulted",
"in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0}
if(Mo1[["LP"]] >= y.slice) break
else if(all(abs(wt) < 1e-100)) {
Mo1 <- Mo0
break}
L[wt < 0] <- wt[wt < 0]
U[wt > 0] <- wt[wt > 0]}
Mo0 <- Mo1
if(iter <= A) post[iter,] <- Mo0[["parm"]]
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]
DiagCovar[t.iter,] <- diag(S.eig$vectors)}
}
if(A > 0) VarCov <- VarCov2
### Output
out <- list(Acceptance=Iterations,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=VarCov)
return(out)
}
.mcmcpcn <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, VarCov,
Debug, LogFile)
{
beta <- Specs[["beta"]]
U <- chol(VarCov)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Propose new parameter values
prop <- as.vector(sqrt(1 - beta*beta)*Mo0[["parm"]] +
beta*(rbind(rnorm(LIV)) %*% U))
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal resulted in non-finite",
"value(s).\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
Acceptance <- Acceptance + 1}}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=VarCov)
return(out)
}
.mcmcram <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, VarCov,
Debug, LogFile)
{
alpha.star <- Specs[["alpha.star"]]
Block <- Specs[["B"]]
Dist <- Specs[["Dist"]]
gamma <- Specs[["gamma"]]
n <- Specs[["n"]]
B <- length(Block)
if(B == 0) {
if(!is.symmetric.matrix(VarCov)) {
cat("\nAsymmetric Covar, correcting now...\n", file=LogFile,
append=TRUE)
VarCov <- as.symmetric.matrix(VarCov)}
if(!is.positive.definite(VarCov)) {
cat("\nNon-Positive-Definite Covar, correcting now...\n",
file=LogFile, append=TRUE)
VarCov <- as.positive.definite(VarCov)}
Iden.Mat <- diag(LIV)
S.z <- try(t(chol(VarCov)), silent=!Debug[["DB.chol"]])
if(!inherits(S.z, "try-error")) {
if(Debug[["DB.chol"]] == TRUE)
cat("\nWARNING: Cholesky decomposition failed for",
"proposal.\n", file=LogFile, append=TRUE)
S <- S.z}
else S <- Iden.Mat
DiagCovar <- matrix(diag(VarCov), floor(Iterations/Thinning)+1,
LIV, byrow=TRUE)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Propose New Parameter Values
if(Dist == "t") U <- rt(LIV, df=5)
else U <- rnorm(LIV)
prop <- Mo0[["parm"]] + rbind(U) %*% S
### Log-Posterior
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal resulted in non-finite",
"value(s).\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
Acceptance <- Acceptance + 1}}
### Adaptation
eta <- min(1, LIV*{n + iter}^(-gamma))
VarCov.test <- S %*% {Iden.Mat +
eta*(min(1, exp(log.alpha)) - alpha.star) *
U %*% t(U) / sum(U*U)} %*% t(S)
if(missing(VarCov.test) || !all(is.finite(VarCov.test)) ||
!is.matrix(VarCov.test)) {VarCov.test <- VarCov}
if(!is.symmetric.matrix(VarCov.test))
VarCov.test <- as.symmetric.matrix(VarCov.test)
if(is.positive.definite(VarCov.test)) {
S.z <- try(t(chol(VarCov)), silent=!Debug[["DB.chol"]])
if(!inherits(S.z, "try-error")) {
VarCov <- VarCov.test
S <- S.z
}
else if(Debug[["DB.chol"]] == TRUE)
cat("\nWARNING: Cholesky decomposition failed for",
"proposal in iteration", iter, ".\n",
file=LogFile, append=TRUE)}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]
DiagCovar[t.iter,] <- diag(VarCov)}
}
}
else {
if(!identical(length(VarCov), B))
stop("Number of components in Covar differs from ",
"number of blocks.", file=LogFile, append=TRUE)
DiagCovar <- rep(0, LIV)
Iden.Mat <- S <- S.z <- list()
for (b in 1:B) {
if(!identical(length(Block[[b]]), length(diag(VarCov[[b]]))))
stop("Diagonal of Covar[[",b,"]] differs from ",
"block length.", file=LogFile, append=TRUE)
if(!is.symmetric.matrix(VarCov[[b]])) {
cat("\nAsymmetric Covar block, correcting now...\n",
file=LogFile, append=TRUE)
VarCov[[b]] <- as.symmetric.matrix(VarCov[[b]])}
if(!is.positive.definite(VarCov[[b]])) {
cat("\nNon-Positive-Definite Covar block,",
"correcting now...\n", file=LogFile, append=TRUE)
VarCov[[b]] <- as.positive.definite(VarCov[[b]])}
Iden.Mat[[b]] <- diag(length(diag(VarCov[[b]])))
S.z[[b]] <- try(t(chol(VarCov[[b]])),
silent=!Debug[["DB.chol"]])
if(!inherits(S.z[[b]], "try-error")) S[[b]] <- S.z[[b]]
else {
if(Debug[["DB.chol"]] == TRUE)
cat("\nWARNING: Cholesky decomposition failed for",
"proposal in block", b, ".\n", file=LogFile,
append=TRUE)
S[[b]] <- Iden.Mat[[b]]}
DiagCovar[Block[[b]]] <- diag(VarCov[[b]])
}
DiagCovar <- matrix(DiagCovar, floor(Iterations/Thinning)+1,
LIV, byrow=TRUE)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Blockwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Proceed by Block
for (b in 1:B) {
### Propose New Parameter Values
if(Dist == "t") U <- rt(length(Block[[b]]), df=5)
else U <- rnorm(length(Block[[b]]))
prop <- Mo0[["parm"]]
prop[Block[[b]]] <- prop[Block[[b]]] +
rbind(U) %*% S[[b]]
### Log-Posterior
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed in block",
b, ".\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in block", b,
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
Acceptance <- Acceptance +
length(Block[[b]]) / LIV}}
### Adaptation
eta <- min(1, length(Block[[b]])*{n + iter}^(-gamma))
VarCov.test <- S[[b]] %*% {Iden.Mat[[b]] +
eta*(min(1, exp(log.alpha)) - alpha.star) *
U %*% t(U) / sum(U*U)} %*% t(S[[b]])
if(missing(VarCov.test) || !all(is.finite(VarCov.test)) ||
!is.matrix(VarCov.test)) {VarCov.test <- VarCov[[b]]}
if(!is.symmetric.matrix(VarCov.test))
VarCov.test <- as.symmetric.matrix(VarCov.test)
if(is.positive.definite(VarCov.test)) {
S.z[[b]] <- try(t(chol(VarCov[[b]])),
silent=!Debug[["DB.chol"]])
if(!inherits(S.z[[b]], "try-error")) {
VarCov[[b]] <- VarCov.test
S[[b]] <- S.z[[b]]}
else if(Debug[["DB.chol"]] == TRUE)
cat("\nWARNING: Cholesky decomposition",
"failed for proposal in block", b,
"in iteration", iter, ".\n",
file=LogFile, append=TRUE)}
DiagCovar[floor(iter / Thinning)+1,Block[[b]]] <- diag(VarCov[[b]])
}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=VarCov)
return(out)
}
.mcmcrdmh <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned,
Debug, LogFile)
{
Acceptance <- matrix(0, 1, LIV)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
s <- sample(c(-1,1), LIV, replace=TRUE)
u1 <- runif(LIV, -1, 1)
epsilon1 <- u1^s
### Random-Scan Componentwise Estimation
for (j in sample.int(LIV)) {
### Propose new parameter values
prop <- Mo0[["parm"]]
prop[j] <- prop[j]*epsilon1[j]
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed for",
Data[["parm.names"]][j], ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
epsilon2 <- log(abs(Mo1[["parm"]][j] /
Mo0[["parm"]][j]))
if(!is.finite(epsilon2)) epsilon2 <- 0
### Accept/Reject
u2 <- log(runif(1)) < (epsilon2 + Mo1[["LP"]] -
Mo0[["LP"]])
if(u2 == TRUE) {
Mo0 <- Mo1
Acceptance[j] <- Acceptance[j] + 1}}}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=mean(as.vector(Acceptance)),
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
.mcmcrefractive <- function(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, thinned, Debug,
LogFile)
{
Adaptive <- Specs[["Adaptive"]]
m <- Specs[["m"]]
w <- Specs[["w"]]
r <- Specs[["r"]]
alpha.star <- 0.65
if(Adaptive < Iterations) DiagCovar <- matrix(w, nrow(thinned), LIV)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
prop <- Mo0[["parm"]]
p <- rnorm(LIV)
a <- 1
g <- partial(Model, prop, Data)
for (i in 1:m) {
if(t(p) %*% g > 0) {
u <- g / sqrt(sum(g*g))
r1 <- 1
r2 <- r
}
else {
u <- -g / sqrt(sum(g*g))
r1 <- r
r2 <- 1}
cos.theta.1 <- (t(p) %*% u) / sqrt(sum(p*p))
cos.2.theta.1 <- cos.theta.1 * cos.theta.1
cos.2.theta.2 <- 1 - (r1^2 / r2^2)*(1 - cos.2.theta.1)
if(cos.2.theta.2 > 0) cos.theta.2 <- sqrt(cos.2.theta.2)
else cos.theta.2 <- -sqrt(abs(cos.2.theta.2))
if(cos.2.theta.2 < 0) p <- as.vector(p - 2*(t(p) %*% u) %*% u)
else {
p <- (r1 / r2)*p -
sqrt(sum(p*p))*((r1 / r2)*cos.theta.1 -
cos.theta.2)*u
a <- (r1 / r2)^(LIV-1)*(cos.theta.1 / cos.theta.2)*a}
prop <- prop + w*p
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal resulted in non-finite",
"value(s).\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
prop <- Mo1[["parm"]]}
### Accept/Reject
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]] + exp(a)
if(!is.finite(log.alpha)) log.alpha <- 0
if(log(runif(1)) < log.alpha) {
Mo0 <- Mo1
Acceptance <- Acceptance + 1
if(Adaptive < Iterations)
w <- w + (w / (alpha.star * (1 - alpha.star))) *
(1 - alpha.star) / iter
}
else if(Adaptive < Iterations)
w <- abs(w - (w / (alpha.star * (1 - alpha.star))) *
alpha.star / iter)
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]
if(Adaptive < Iterations) DiagCovar[t.iter,] <- w}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
.mcmcrj <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, Debug,
LogFile)
{
bin.n <- Specs[["bin.n"]]
bin.p <- Specs[["bin.p"]]
parm.p <- Specs[["parm.p"]]
selectable <- Specs[["selectable"]]
selected <- Specs[["selected"]]
cur.parm <- cur.sel <- selected
cur.parm[which(selectable == 0)] <- 1
nonzero.post <- rep(0, LIV)
p <- parm.p
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Propose a variable to include/exclude
v.change <- sample(LIV, 1, prob=selectable)
prop.sel <- cur.sel
prop.parm <- cur.parm
### Change proposed size, but not above bin.n
if(sum(cur.sel) < bin.n) {
prop.sel[v.change] <- 1 - prop.sel[v.change]
prop.parm[v.change] <- 1 - prop.parm[v.change]}
else if(prop.sel[v.change] == 1)
prop.parm[v.change] <- prop.sel[v.change] <- 0
### Priors
prior.cur <- sum(dbern(cur.sel, p[which(selectable == 1)], log=TRUE),
dbinom(sum(cur.sel), bin.n, bin.p, log=TRUE))
prior.prop <- sum(dbern(prop.sel, p[which(selectable == 1)], log=TRUE),
dbinom(sum(prop.sel), bin.n, bin.p, log=TRUE))
### Hit-And-Run Proposal Parameters
theta <- rnorm(LIV)
theta <- theta / sqrt(sum(theta*theta))
lambda <- runif(1)
### Random-Scan Componentwise Estimation (Within-Model)
for (j in sample(which(cur.parm == 1))) {
### Propose new parameter values
temp.post <- Mo0[["parm"]]
temp.post[which(temp.post == 0)] <- nonzero.post[which(temp.post == 0)]
temp.post[which(cur.parm == 0)] <- 0
prop <- Mo0[["parm"]] <- temp.post
prop[j] <- prop[j] + lambda*theta[j]
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Within-model proposal failed for",
Data[["parm.names"]][j], ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Within-model proposal for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
### Accept/Reject (Within-Model Move)
u <- log(runif(1)) < (Mo1[["LP"]] - Mo0[["LP"]])
if(u == TRUE) Mo0 <- Mo1
if(Mo0[["parm"]][j] != 0) nonzero.post[j] <- Mo0[["parm"]][j]
Acceptance <- Acceptance + (u * (1 / sum(cur.parm)))}
### Random-Scan Componentwise Estimation (Between-Models)
prop <- Mo0[["parm"]]
prop[v.change] <- prop.sel[v.change]*(prop[v.change] +
lambda*theta[v.change])
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Between-models proposal failed for",
Data[["parm.names"]][j], ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Between-models proposal for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
### Accept/Reject (Between-Models Move)
u <- log(runif(1)) < (Mo1[["LP"]] - Mo0[["LP"]] + prior.prop -
prior.cur)
if(u == TRUE) {
Mo0 <- Mo1
cur.sel <- prop.sel
cur.parm <- prop.parm}
if(Mo0[["parm"]][v.change] != 0)
nonzero.post[v.change] <- Mo0[["parm"]][v.change]
Acceptance <- Acceptance + (u * (1 / sum(prop.parm)))
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
.mcmcrss <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, thinned, Debug, LogFile)
{
m <- Specs[["m"]]
w <- Specs[["w"]]
reflections <- 0
Norm <- function(x) return(sqrt(sum(x*x)))
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
prop <- Mo0[["parm"]]
y.slice <- Mo0[["LP"]] - rexp(1)
g <- partial(Model, prop, Data)
p <- rnorm(LIV)
reflections <- 0
### Take m Steps
for (i in 1:m) {
prop0 <- prop
prop <- prop + w*p
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out proposal failed",
"in step", i, ".\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out proposal resulted",
"in non-finite value(s) in step", i, ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0}
prop <- Mo1[["parm"]]
### Reflect at boundary
if(y.slice > Mo1[["LP"]]) {
reflections <- reflections + 1
prop <- prop0
g <- partial(Model, prop, Data)
p <- p - 2*g*{(t(p) %*% g) / Norm(g)^2}}}
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Final proposal failed.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Final proposal resulted",
"in non-finite value(s).\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
Mo0 <- Mo1
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=Iterations,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
.mcmcrwm <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, tuning,
VarCov, Debug, LogFile)
{
Block <- Specs[["B"]]
if(length(Block) == 0) {
if(!is.symmetric.matrix(VarCov)) {
cat("\nAsymmetric Covar, correcting now...\n", file=LogFile,
append=TRUE)
VarCov <- as.symmetric.matrix(VarCov)}
if(!is.positive.definite(VarCov)) {
cat("\nNon-Positive-Definite Covar, correcting now...\n",
file=LogFile, append=TRUE)
VarCov <- as.positive.definite(VarCov)}
U <- chol(VarCov)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Propose new parameter values
prop <- as.vector(Mo0[["parm"]] +
rbind(rnorm(LIV)) %*% U)
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal resulted",
"in non-finite value(s).\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
Acceptance <- Acceptance + 1}}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
}
else {
B <- length(Block)
if(!identical(length(VarCov), B))
stop("Number of components in Covar differs from ",
"number of blocks.", file=LogFile, append=TRUE)
for (b in 1:B) {
if(!identical(length(Block[[b]]), length(diag(VarCov[[b]]))))
stop("Diagonal of Covar[[",b,"]] differs from ",
"block length.", file=LogFile, append=TRUE)
if(!is.symmetric.matrix(VarCov[[b]])) {
cat("\nAsymmetric Covar block, correcting now...\n",
file=LogFile, append=TRUE)
VarCov[[b]] <- as.symmetric.matrix(VarCov[[b]])}
if(!is.positive.definite(VarCov[[b]])) {
cat("\nNon-Positive-Definite Covar block,",
"correcting now...\n", file=LogFile, append=TRUE)
VarCov[[b]] <- as.positive.definite(VarCov[[b]])}}
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter, sep="", file=LogFile,
append=TRUE)
### Proceed by Block
for (b in 1:B) {
### Propose new parameter values
prop <- Mo0[["parm"]]
prop[Block[[b]]] <- Mo0[["parm"]][Block[[b]]] +
rbind(rnorm(length(Block[[b]]))) %*%
chol(VarCov[[b]])
if({b == 1} & {iter %% Status == 0})
cat(", Proposal: Blockwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in block", b,
"failed.\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in block", b,
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
Acceptance <- Acceptance +
length(Block[[b]]) / LIV}}
}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=VarCov)
return(out)
}
.mcmcsamwg <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, tuning,
parm.names, Debug, LogFile)
{
Dyn <- Specs[["Dyn"]]
Periodicity <- Specs[["Periodicity"]]
Acceptance <- matrix(0, 1, LIV)
for (k in 1:ncol(Dyn)) {for (t in 1:nrow(Dyn)) {
Dyn[t,k] <- which(parm.names == Dyn[t,k])}}
Dyn <- matrix(as.numeric(Dyn), nrow(Dyn), ncol(Dyn))
staticparms <- c(1:LIV)[-as.vector(Dyn)]
DiagCovar <- matrix(tuning, floor(Iterations/Periodicity), LIV,
byrow=TRUE)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Select Order of Parameters
if(length(staticparms) == 1) staticsample <- staticparms
else staticsample <- sample(staticparms)
if(ncol(Dyn) == 1) dynsample <- sample(Dyn)
else dynsample <- as.vector(apply(Dyn, 1, sample))
totsample <- c(staticsample, dynsample)
### Componentwise Estimation
for (j in totsample) {
### Propose new parameter values
prop <- Mo0[["parm"]]
prop[j] <- rnorm(1, prop[j], tuning[j])
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed for",
Data[["parm.names"]][j], ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
u <- log(runif(1)) < (Mo1[["LP"]] - Mo0[["LP"]])
if(u == TRUE) {
Mo0 <- Mo1
Acceptance[j] <- Acceptance[j] + 1}}}
### Adapt the Proposal Variance
if(iter %% Periodicity == 0) {
size <- 1 / min(100, sqrt(iter))
Acceptance.Rate <- Acceptance / iter
log.tuning <- log(tuning)
tuning.num <- which(Acceptance.Rate > 0.44)
log.tuning[tuning.num] <- log.tuning[tuning.num] + size
log.tuning[-tuning.num] <- log.tuning[-tuning.num] - size
tuning <- exp(log.tuning)
a.iter <- floor(iter / Periodicity)
DiagCovar[a.iter,] <- tuning}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=mean(as.vector(Acceptance)),
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=tuning)
return(out)
}
.mcmcsgld <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, Debug,
LogFile)
{
epsilon <- Specs[["epsilon"]]
file <- Specs[["file"]]
Nr <- Specs[["Nr"]]
Nc <- Specs[["Nc"]]
size <- Specs[["size"]]
Acceptance <- matrix(Iterations, 1, LIV)
con <- file(file, open="r")
on.exit(close(con))
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Sample Data
seek(con, 0)
skip.rows <- sample.int(Nr - size, size=1)
Data[["X"]] <- matrix(scan(file=con, sep=",", skip=skip.rows,
nlines=size, quiet=TRUE), size, Nc, byrow=TRUE)
### Propose new parameter values
g <- partial(Model, Mo0[["parm"]], Data)
eta <- rnorm(LIV, 0, epsilon[iter])
prop <- Mo0[["parm"]] + {epsilon[iter]/2}*g + eta
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal resulted in non-finite",
"value(s).\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
Mo0 <- Mo1
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
.mcmcslice <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, Debug,
LogFile)
{
Block <- Specs[["B"]]
B <- length(Block)
Bounds <- Specs[["Bounds"]]
m <- Specs[["m"]]
Type <- Specs[["Type"]]
w <- Specs[["w"]]
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Proceed by Block
for (b in 1:B) {
### Random-Scan Componentwise Estimation
if(Type[[b]] == "Continuous") {
for (j in sample(Block[[b]])) {
y.slice <- Mo0[["LP"]] - rexp(1)
u <- runif(1,0,w[[b]])
intL <- intR <- prop <- Mo0[["parm"]]
L <- intL[j] - u
R <- intR[j] + (w[[b]] - u)
### Unlimited number of steps
if(is.infinite(m[[b]])) {
repeat {
if(L <= Bounds[[b]][1]) break
intL[j] <- L
MoL <- try(Model(intL, Data),
silent=!Debug[["DB.Model"]])
if(inherits(MoL, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out",
"the lower bound failed for",
Data[["parm.names"]][j],
".\n",
file=LogFile, append=TRUE)
L <- L + w[[b]]
break}
else if(!is.finite(MoL[["LP"]])) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out",
"the lower bound for",
Data[["parm.names"]][j],
"resulted in a non-finite",
"LP.\n",
file=LogFile, append=TRUE)
L <- L + w[[b]]
break}
if(MoL[["LP"]] <= y.slice) break
L <- L - w[[b]]}
repeat {
if(R >= Bounds[[b]][2]) break
intR[j] <- R
MoR <- try(Model(intR, Data),
silent=!Debug[["DB.Model"]])
if(inherits(MoR, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out",
"the upper bound failed for",
Data[["parm.names"]][j],
".\n",
file=LogFile, append=TRUE)
R <- R - w[[b]]
break}
else if(!is.finite(MoR[["LP"]])) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out",
"the upper bound for",
Data[["parm.names"]][j],
"resulted in a non-finite",
"LP.\n",
file=LogFile, append=TRUE)
R <- R - w[[b]]
break}
if(MoR[["LP"]] <= y.slice) break
R <- R + w[[b]]}
}
else if(m[[b]] > 1) {
### Limited number of steps
J <- floor(runif(1,0,m[[b]]))
K <- (m[[b]] - 1) - J
while (J > 0) {
if(L <= Bounds[[b]][1]) break
intL[j] <- L
MoL <- try(Model(intL, Data),
silent=!Debug[["DB.Model"]])
if(inherits(MoL, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out",
"the lower bound failed for",
Data[["parm.names"]][j],
".\n",
file=LogFile, append=TRUE)
L <- L + w[[b]]
break}
else if(!is.finite(MoL[["LP"]])) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out",
"the lower bound for",
Data[["parm.names"]][j],
"resulted in a non-finite",
"LP.\n",
file=LogFile, append=TRUE)
L <- L + w[[b]]
break}
if(MoL[["LP"]] <= y.slice) break
L <- L - w[[b]]
J <- J - 1}
while (K > 0) {
if(R >= Bounds[[b]][2]) break
intR[j] <- R
MoR <- try(Model(intR, Data),
silent=!Debug[["DB.Model"]])
if(inherits(MoR, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out",
"the upper bound failed for",
Data[["parm.names"]][j],
".\n",
file=LogFile, append=TRUE)
R <- R - w[[b]]
break}
else if(!is.finite(MoR[["LP"]])) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out",
"the lower bound for",
Data[["parm.names"]][j],
"resulted in a non-finite",
"LP.\n",
file=LogFile, append=TRUE)
R <- R - w[[b]]
break}
R <- R + w[[b]]
K <- K - 1}
}
### Shrink the interval to lower and upper bounds
if(L < Bounds[[b]][1]) L <- Bounds[[b]][1]
if(R > Bounds[[b]][2]) R <- Bounds[[b]][2]
### Rejection Sampling
repeat {
L <- min(L,R)
R <- max(L,R)
prop[j] <- runif(1,L,R)
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Rejection sampling",
"failed for",
Data[["parm.names"]][j], "\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
"\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Rejection sampling for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
"\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0}
if(Mo1[["LP"]] >= y.slice) break
else if(abs(R-L) < 1e-100) break
if(Mo1[["parm"]][j] > Mo0[["parm"]][j])
R <- Mo1[["parm"]][j]
else L <- Mo1[["parm"]][j]}
Mo0 <- Mo1
}
}
else if(Type[[b]] == "Nominal") {
for (j in sample(Block[[b]])) {
y.slice <- Mo0[["LP"]] - rexp(1)
LP.grid <- theta <- Bounds[[b]][1]:Bounds[[b]][2]
for (i in 1:length(LP.grid)) {
prop[j] <- theta[i]
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating",
Data[["parm.names"]][j], "at",
round(prop[j],5), "failed.\n",
file=LogFile, append=TRUE)
LP.grid[i] <- 0
}
else if(!is.finite(Mo1[["LP"]])) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating",
Data[["parm.names"]][j], "at",
round(prop[j],5), "resulted",
"in non-finite value(s).\n",
file=LogFile, append=TRUE)
LP.grid[i] <- 0
}
else if(Mo1[["LP"]] < y.slice)
LP.grid[i] <- 0
else LP.grid[i] <- exp(Mo1[["LP"]])}
if(sum(LP.grid) > 0)
LP.grid <- LP.grid / sum(LP.grid)
else LP.grid <- rep(1/length(LP.grid),
length(LP.grid))
### Rejection Sampling
repeat {
prop[j] <- theta[sample(1:length(LP.grid),1,
prob=LP.grid)]
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(is.finite(Mo1[["LP"]])) {
if(Mo1[["LP"]] >= y.slice) break}}
Mo0 <- Mo1
}
}
else { ### Ordinal
for (j in sample(Block[[b]])) {
y.slice <- Mo0[["LP"]] - rexp(1)
intL <- intR <- prop <- Mo0[["parm"]]
L <- intL[j] - w[[b]]
R <- intR[j] + w[[b]]
### Unlimited number of steps
if(is.infinite(m[[b]])) {
repeat {
if(L <= Bounds[[b]][1]) break
intL[j] <- L
MoL <- try(Model(intL, Data),
silent=!Debug[["DB.Model"]])
if(inherits(MoL, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out",
"the lower bound failed for",
Data[["parm.names"]][j],
".\n", file=LogFile,
append=TRUE)
L <- L + w[[b]]
break}
else if(!is.finite(MoL[["LP"]])) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out",
"the lower bound for",
Data[["parm.names"]][j],
"resulted in a non-finite",
"LP.\n", file=LogFile,
append=TRUE)
L <- L + w[[b]]
break}
if(MoL[["LP"]] <= y.slice) break
L <- L - w[[b]]}
repeat {
if(R >= Bounds[[b]][2]) break
intR[j] <- R
MoR <- try(Model(intR, Data),
silent=!Debug[["DB.Model"]])
if(inherits(MoR, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out",
"the upper bound failed for",
Data[["parm.names"]][j],
".\n", file=LogFile,
append=TRUE)
R <- R - w[[b]]
break}
else if(!is.finite(MoR[["LP"]])) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out",
"the upper bound for",
Data[["parm.names"]][j],
"resulted in a non-finite",
"LP.\n", file=LogFile,
append=TRUE)
R <- R - w[[b]]
break}
if(MoR[["LP"]] <= y.slice) break
R <- R + w[[b]]}
}
else if(m[[b]] > 1) {
### Limited number of steps
J <- floor(runif(1,0,m[[b]]))
K <- (m[[b]] - 1) - J
while (J > 0) {
if(L <= Bounds[[b]][1]) break
intL[j] <- L
MoL <- try(Model(intL, Data),
silent=!Debug[["DB.Model"]])
if(inherits(MoL, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out",
"the lower bound failed for",
Data[["parm.names"]][j],
".\n", file=LogFile,
append=TRUE)
L <- L + w[[b]]
break}
else if(!is.finite(MoL[["LP"]])) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out",
"the lower bound for",
Data[["parm.names"]][j],
"resulted in a non-finite",
"LP.\n", file=LogFile,
append=TRUE)
L <- L + w[[b]]
break}
if(MoL[["LP"]] <= y.slice) break
L <- L - w[[b]]
J <- J - 1}
while (K > 0) {
if(R >= Bounds[[b]][2]) break
intR[j] <- R
MoR <- try(Model(intR, Data),
silent=!Debug[["DB.Model"]])
if(inherits(MoR, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out",
"the upper bound failed for",
Data[["parm.names"]][j],
".\n", file=LogFile,
append=TRUE)
R <- R - w[[b]]
break}
if(!is.finite(MoR[["LP"]])) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out",
"the lower bound for",
Data[["parm.names"]][j],
"resulted in a non-finite",
"LP.\n", file=LogFile,
append=TRUE)
R <- R - w[[b]]
break}
R <- R + w[[b]]
K <- K - 1}
}
### Shrink the interval to lower and upper bounds
if(L < Bounds[[b]][1]) L <- Bounds[[b]][1]
if(R > Bounds[[b]][2]) R <- Bounds[[b]][2]
### Rejection Sampling
repeat {
prop[j] <- sample(L:R,1)
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Rejection sampling",
"failed for",
Data[["parm.names"]][j], "\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
"\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Rejection sampling for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
"\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0}
if(Mo1[["LP"]] >= y.slice) break
else if(abs(R-L) < 1e-100) break
if(Mo1[["parm"]][j] > Mo0[["parm"]][j])
R <- Mo1[["parm"]][j]
else L <- Mo1[["parm"]][j]}
Mo0 <- Mo1
}
}
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
}
### Output
out <- list(Acceptance=Iterations,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
.mcmcsmwg <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, tuning,
parm.names, Debug, LogFile)
{
Dyn <- Specs[["Dyn"]]
Acceptance <- matrix(0, 1, LIV)
for (k in 1:ncol(Dyn)) {for (t in 1:nrow(Dyn)) {
Dyn[t,k] <- which(parm.names == Dyn[t,k])}}
Dyn <- matrix(as.numeric(Dyn), nrow(Dyn), ncol(Dyn))
staticparms <- c(1:LIV)[-as.vector(Dyn)]
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Select Order of Parameters
if(length(staticparms) == 1) staticsample <- staticparms
else staticsample <- sample(staticparms)
if(ncol(Dyn) == 1) dynsample <- sample(Dyn)
else dynsample <- as.vector(apply(Dyn, 1, sample))
totsample <- c(staticsample, dynsample)
### Componentwise Estimation
for (j in totsample) {
### Propose new parameter values
prop <- Mo0[["parm"]]
prop[j] <- rnorm(1, prop[j], tuning[j])
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed for",
Data[["parm.names"]][j], ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
u <- log(runif(1)) < (Mo1[["LP"]] - Mo0[["LP"]])
if(u == TRUE) {
Mo0 <- Mo1
Acceptance[j] <- Acceptance[j] + 1}}}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=mean(as.vector(Acceptance)),
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=tuning)
return(out)
}
.mcmcthmc <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, Debug,
LogFile)
{
epsilon <- Specs[["epsilon"]]
L <- Specs[["L"]]
m <- Specs[["m"]]
invm <- as.inverse(m)
U <- chol(m)
Temperature <- Specs[["Temperature"]]
gr <- partial(Model, Mo0[["parm"]], Data)
sqrt.Temp <- sqrt(Temperature)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Propose new parameter values
prop <- Mo0[["parm"]]
momentum1 <- momentum0 <- as.vector(rnorm(LIV) %*% U)
kinetic0 <- t(momentum0) %*% invm %*% momentum0 / 2
Mo0.1 <- Mo0
for (l in 1:L) {
if(2*(l-1) < L) momentum1 <- momentum1 * sqrt.Temp
else momentum1 <- momentum1 / sqrt.Temp
momentum1 <- momentum1 + (epsilon/2) * gr
prop <- prop + as.vector(epsilon %*% invm) * momentum1
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed in leapfrog", l,
".\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0.1
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in leapfrog", l,
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0.1}
if(any(Mo0.1[["parm"]] == Mo1[["parm"]])) {
nomove <- which(Mo0.1[["parm"]] == Mo1[["parm"]])
momentum1[nomove] <- -momentum1[nomove]
prop[nomove] <- prop[nomove] + momentum1[nomove]
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed in leapfrog",
l, ".\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0.1
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in leapfrog",
l, "resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0.1}}
Mo0.1 <- Mo1
prop <- Mo1[["parm"]]
gr <- partial(Model, prop, Data)
momentum1 <- momentum1 + (epsilon/2) * gr
if(2*l > L) momentum1 <- momentum1 / sqrt.Temp
else momentum1 <- momentum1 * sqrt.Temp}
momentum1 <- -momentum1
kinetic1 <- t(momentum1) %*% invm %*% momentum1 / 2
### Accept/Reject
H0 <- -Mo0[["LP"]] + kinetic0
H1 <- -Mo1[["LP"]] + kinetic1
delta <- H1 - H0
alpha <- min(1, exp(-delta))
if(!is.finite(alpha)) alpha <- 0
if(runif(1) < alpha) {
Mo0 <- Mo1
kinetic0 <- kinetic1
Acceptance <- Acceptance + 1}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=matrix(epsilon, 1, LIV),
Mon=Mon,
thinned=thinned,
VarCov=cov(thinned))
return(out)
}
.mcmctwalk <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, Debug,
LogFile)
{
xp0 <- SIV <- Specs[["SIV"]]
n1 <- Specs[["n1"]]
at <- Specs[["at"]]
aw <- Specs[["aw"]]
IntProd <- function(x) {return(sum(x*x))}
DotProd <- function(x, y) {return(sum(x*y))}
Simh1 <- function(dim, pphi, x, xp, beta)
{
phi <- runif(dim) < pphi
rt <- NULL
for (i in 1:dim)
if(phi[i])
rt <- append(rt, xp[i] + beta*(xp[i] - x[i]))
else
rt <- append(rt, x[i])
return(list(rt=rt, nphi=sum(phi)))
}
Simfbeta <- function(at)
{
if(runif(1) < (at-1)/(2*at))
return(exp(1/(at + 1)*log(runif(1))))
else
return(exp(1/(1 - at)*log(runif(1))))
}
Simh2 <- function(dim, pphi, aw, x, xp)
{
u <- runif(dim)
phi <- runif(dim) < pphi
z <- (aw/(1+aw))*(aw*u^2 + 2*u -1)
z <- z*phi
return(list(rt=x + (x - xp)*z, nphi=sum(phi)))
}
Simh3 <- function(dim, pphi, x, xp)
{
phi <- runif(dim) < pphi
sigma <- max(phi*abs(xp - x))
x + sigma*rnorm(dim)*phi
return(list(rt=x + sigma*rnorm(dim)*phi, nphi=sum(phi),
sigma=sigma))
}
G3U <- function(nphi, sigma, h, x, xp)
{
if(nphi > 0)
return((nphi/2)*log(2*pi) + nphi*log(sigma) +
0.5*IntProd(h - xp)/(sigma^2))
else
return(0)
}
Simh4 <- function(dim, pphi, x, xp)
{
phi <- runif(dim) < pphi
sigma <- max(phi*abs(xp - x))/3
rt <- NULL
for (i in 1:dim)
if(phi[i])
rt <- append(rt, xp[i] + sigma*rnorm(1))
else
rt <- append(rt, x[i])
return(list(rt=rt, nphi=sum(phi), sigma=sigma))
}
G4U <- function(nphi, sigma, h, x, xp)
{
if(nphi > 0)
return((nphi/2)*log(2*pi) + nphi*log(sigma) +
0.5*IntProd((h - x))/(sigma^2))
else
return(0)
}
OneMove <- function(dim, Model, Data, x, U, xp, Up, at=at, aw=aw,
pphi=pphi, F1=0.4918, F2=0.9836, F3=0.9918, Mo0.1, Mo0.2)
{
dir <- runif(1) ### Determine which set of points
ker <- runif(1) ### Choose a kernel
if(ker < F1) {
### Kernel h1: Traverse
funh <- 1
if(dir < 0.5) {
beta <- Simfbeta(at)
tmp <- Simh1(dim, pphi, xp, x, beta)
yp <- tmp$rt
nphi <- tmp$nphi
y <- x
propU <- U
Mo1.2 <- try(Model(yp, Data),
silent=!Debug[["DB.Model"]])
check1 <- check2 <- FALSE
if(!inherits(Mo1.2, "try-error")) {
check1 <- TRUE
if(is.finite(Mo1.2[["LP"]]) &
identical(yp, as.vector(Mo1.2[["LP"]])))
check2 <- TRUE}
if(check1 & check2) {
propUp <- Mo1.2[["LP"]] * -1 ### Symmetric Proposal
if(nphi == 0)
A <- 1 ### Nothing moved
else
A <- exp((U - propU) + (Up - propUp) +
(nphi-2)*log(beta))}
else {
propUp <- NULL
A <- 0 ### Out of support, not accepted
}
}
else {
beta <- Simfbeta(at)
tmp <- Simh1(dim, pphi, x, xp, beta)
y <- tmp$rt
nphi <- tmp$nphi
yp <- xp
propUp <- Up
Mo1.1 <- try(Model(y, Data),
silent=!Debug[["DB.Model"]])
check1 <- check2 <- FALSE
if(!inherits(Mo1.1, "try-error")) {
check1 <- TRUE
if(is.finite(Mo1.1[["LP"]]) &
identical(y, as.vector(Mo1.1[["parm"]])))
check2 <- TRUE}
if(check1 & check2) {
propU <- Mo1.1[["LP"]] * -1 ### Symmetric Proposal
if(nphi == 0)
A <- 1 ### Nothing moved
else
A <- exp((U - propU) + (Up - propUp) +
(nphi-2)*log(beta))}
else {
propU <- NULL
A <- 0 ### Out of support, not accepted
}
}
}
else if(ker < F2) {
### Kernel h2: Walk
funh <- 2
if(dir < 0.5) {
### x as pivot
tmp <- Simh2(dim, pphi, aw, xp, x)
yp <- tmp$rt
nphi <- tmp$nphi
y <- x
propU <- U
Mo1.2 <- try(Model(yp, Data),
silent=!Debug[["DB.Model"]])
check1 <- check2 <- FALSE
if(!inherits(Mo1.2, "try-error")) {
check1 <- TRUE
if(is.finite(Mo1.2[["LP"]]) &
identical(yp, as.vector(Mo1.2[["parm"]])))
check2 <- TRUE}
if(check1 & check2 & !identical(yp, y)) {
propUp <- Mo1.2[["LP"]] * -1
A <- exp((U - propU) + (Up - propUp))}
else {
propUp <- NULL
A <- 0 ### Out of support, not accepted
}
}
else {
### xp as pivot
tmp <- Simh2(dim, pphi, aw, x, xp)
y <- tmp$rt
nphi <- tmp$nphi
yp <- xp
propUp <- Up
Mo1.1 <- try(Model(y, Data),
silent=!Debug[["DB.Model"]])
check1 <- check2 <- FALSE
if(!inherits(Mo1.1, "try-error")) {
check1 <- TRUE
if(is.finite(Mo1.1[["LP"]]) &
identical(y, as.vector(Mo1.1[["parm"]])))
check2 <- TRUE}
if(check1 & check2 & !identical(yp, y)) {
propU <- Mo1.1[["LP"]] * -1
A <- exp((U - propU) + (Up - propUp))}
else {
propU <- NULL
A <- 0 ### Out of support, not accepted
}
}
}
else if(ker < F3) {
### Kernel h3: Blow
funh <- 3
if(dir < 0.5) {
### x as pivot
tmp <- Simh3(dim, pphi, xp, x)
yp <- tmp$rt
nphi <- tmp$nphi
sigma <- tmp$sigma
y <- x
propU <- U
Mo1.2 <- try(Model(yp, Data),
silent=!Debug[["DB.Model"]])
check1 <- check2 <- FALSE
if(!inherits(Mo1.2, "try-error")) {
check1 <- TRUE
if(is.finite(Mo1.2[["LP"]]) &
identical(yp, as.vector(Mo1.2[["parm"]])))
check2 <- TRUE}
if(check1 & check2 & !identical(yp, x)) {
propUp <- Mo1.2[["LP"]] * -1
W1 <- G3U(nphi, sigma, yp, xp, x)
W2 <- G3U(nphi, sigma, xp, yp, x)
A <- exp((U - propU) + (Up - propUp) + (W1 - W2))}
else {
propUp <- NULL
A <- 0 ### Out of support, not accepted
}
}
else {
### xp as pivot
tmp <- Simh3(dim, pphi, x, xp)
y <- tmp$rt
nphi <- tmp$nphi
sigma <- tmp$sigma
yp <- xp
propUp <- Up
Mo1.1 <- try(Model(y, Data),
silent=!Debug[["DB.Model"]])
check1 <- check2 <- FALSE
if(!inherits(Mo1.1, "try-error")) {
check1 <- TRUE
if(is.finite(Mo1.1[["LP"]]) &
identical(y, as.vector(Mo1.1[["parm"]])))
check2 <- TRUE}
if(check1 & check2 & !identical(y, xp)) {
propU <- Mo1.1[["LP"]] * -1
W1 <- G3U(nphi, sigma, y, x, xp)
W2 <- G3U(nphi, sigma, x, y, xp)
A <- exp((U - propU) + (Up - propUp) + (W1 - W2))}
else {
propU <- NULL
A <- 0 ### Out of support, not accepted
}
}
}
else {
## Kernel h4: Hop
funh <- 4
if(dir < 0.5) {
### x as pivot
tmp <- Simh4(dim, pphi, xp, x)
yp <- tmp$rt
nphi <- tmp$nphi
sigma <- tmp$sigma
y <- x
propU <- U
Mo1.2 <- try(Model(yp, Data),
silent=!Debug[["DB.Model"]])
check1 <- check2 <- FALSE
if(!inherits(Mo1.2, "try-error")) {
check1 <- TRUE
if(is.finite(Mo1.2[["LP"]]) &
identical(yp, as.vector(Mo1.2[["parm"]])))
check2 <- TRUE}
if(check1 & check2 & !identical(yp, x)) {
propUp <- Mo1.2[["LP"]] * -1
W1 <- G4U(nphi, sigma, yp, xp, x)
W2 <- G4U(nphi, sigma, xp, yp, x)
A <- exp((U - propU) + (Up - propUp) + (W1 - W2))}
else {
propUp <- NULL
A <- 0 ### Out of support, not accepted
}
}
else {
### xp as pivot
tmp <- Simh4(dim, pphi, x, xp)
y <- tmp$rt
nphi <- tmp$nphi
sigma <- tmp$sigma
yp <- xp
propUp <- Up
Mo1.1 <- try(Model(y, Data),
silent=!Debug[["DB.Model"]])
check1 <- check2 <- FALSE
if(!inherits(Mo1.1, "try-error")) {
check1 <- TRUE
if(is.finite(Mo1.1[["LP"]]) &
identical(y, as.vector(Mo1.1[["parm"]])))
check2 <- TRUE}
if(check1 & check2 & !identical(y, xp)) {
propU <- Mo1.1[["LP"]] * -1
W1 <- G4U(nphi, sigma, y, x, xp)
W2 <- G4U(nphi, sigma, x, y, xp)
A <- exp((U - propU) + (Up - propUp) + (W1 - W2))}
else {
propU <- NULL
A <- 0 ### Out of support, not accepted
}
}
}
if(check1 & check2 & is.finite(A) & (dir < 0.5))
Mo0.2 <- Mo1.2
else if(check1 & check2 & is.finite(A) & (dir >= 0.5))
Mo0.1 <- Mo1.1
else if(!is.finite(A)) A <- 0
return(list(y=y, propU=propU, yp=yp, propUp=propUp, A=A,
funh=funh, nphi=nphi, Mo0.1=Mo0.1, Mo0.2=Mo0.2))
}
Runtwalk <- function(Iterations, dim, x0, xp0, pphi, at, aw,
F1=0.4918, F2=F1+0.4918, F3=F2+0.0082, Model, Data, Status,
Thinning, Acceptance, Dev, Mon, Mo0, thinned, Debug, LogFile)
{
x <- x0 ### Primary vector of initial values
xp <- xp0 ### Secondary vector of initial values
Mo0.1 <- try(Model(x, Data), silent=!Debug[["DB.Model"]])
Mo0.2 <- try(Model(xp, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo0.1, "try-error") | inherits(Mo0.2, "try-error"))
stop("Error in estimating the log-posterior.",
file=LogFile, append=TRUE)
if(any(!is.finite(c(Mo0.1[["LP"]], Mo0.2[["LP"]]))))
stop("The log-posterior is non-finite.", file=LogFile,
append=TRUE)
if(identical(x, as.vector(Mo0.1[["parm"]])) &
identical(xp, as.vector(Mo0.2[["parm"]]))) {
U <- Mo0.1[["LP"]] * -1
Up <- Mo0.2[["LP"]] * -1}
else {
cat("\nInitial values are out of support.", file=LogFile,
append=TRUE)
cat("\n Initial.Values=", x, file=LogFile, append=TRUE)
cat("\n SIV=", xp, file=LogFile, append=TRUE)
stop("Try re-specifying initial values.", file=LogFile,
append=TRUE)}
if(any(abs(x - xp) <= 0))
stop("\nBoth vectors of initial values are not unique.",
file=LogFile, append=TRUE)
Acceptance <- 0
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate Subset, LP: ",
round(Mo0.1[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Assign x and xp
x <- as.vector(Mo0.1[["parm"]])
xp <- as.vector(Mo0.2[["parm"]])
### Propose New Parameter Values
move <- OneMove(dim=dim, Model, Data, x, U, xp, Up,
at=at, aw=aw, pphi=pphi, F1=F1, F2=F2, F3=F3,
Mo0.1=Mo0.1, Mo0.2=Mo0.2)
### Accept/Reject
if(runif(1) < move$A) {
Mo0.1 <- move$Mo0.1
Mo0.2 <- move$Mo0.2
Acceptance <- Acceptance + 1 #move$nphi/dim
x <- move$y
U <- move$propU
xp <- move$yp
Up <- move$propUp
}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0.1[["parm"]]
Dev[t.iter] <- Mo0.1[["Dev"]]
Mon[t.iter,] <- Mo0.1[["Monitor"]]}
}
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
out <- Runtwalk(Iterations=Iterations, dim=LIV, x0=Mo0[["parm"]],
xp0=xp0, pphi=min(LIV, n1)/LIV, at=6, aw=1.5, Model=Model,
Data=Data, Status=Status, Thinning=Thinning,
Acceptance=Acceptance, Dev=Dev, Mon=Mon, Mo0=Mo0,
thinned=thinned, Debug=Debug, LogFile=LogFile)
### Output
return(out)
}
.mcmcuess <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned,
VarCov, Debug, LogFile)
{
A <- Specs[["A"]]
Block <- Specs[["B"]]
m <- Specs[["m"]]
n <- Specs[["n"]]
w <- 0.05
B <- length(Block)
if(B == 0) {
if(!is.symmetric.matrix(VarCov)) {
cat("\nAsymmetric Covar, correcting now...\n", file=LogFile,
append=TRUE)
VarCov <- as.symmetric.matrix(VarCov)}
if(!is.positive.definite(VarCov)) {
cat("\nNon-Positive-Definite Covar, correcting now...\n",
file=LogFile, append=TRUE)
VarCov <- as.positive.definite(VarCov)}
decomp.freq <- max(LIV * floor(Iterations / Thinning / 100), 10)
cat("\nEigendecomposition will occur every", decomp.freq,
"iterations.\n\n", file=LogFile, append=TRUE)
S.eig <-try(eigen(VarCov), silent=!Debug[["DB.eigen"]])
if(inherits(S.eig, "try-error")) S.eig <- NULL
obs.sum <- matrix(Mo0[["parm"]]*n, LIV, 1)
obs.scatter <- tcrossprod(Mo0[["parm"]])*n
DiagCovar <- matrix(diag(VarCov), floor(Iterations/Thinning)+1,
LIV, byrow=TRUE)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Eigenvectors of the Sample Covariance Matrix
if({iter %% decomp.freq == 0} & {iter > 1} & {iter < A}) {
VarCov <- obs.scatter/{n + iter} -
tcrossprod(obs.sum/{n + iter})
S.eig <- eigen(VarCov)}
### Non-Adaptive or Adaptive
if(runif(1) < w || is.null(S.eig)) {
v <- rnorm(LIV)
v <- v / sqrt(sum(v*v))
}
else {
which.eig <- floor(1 + LIV * runif(1))
v <- S.eig$vectors[,which.eig] *
sqrt(abs(S.eig$values[which.eig]))}
### Slice Interval
Mo0.1 <- try(Model(Mo0[["parm"]], Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo0.1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(Mo0[["parm"]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo0.1 <- Mo0}
Mo0 <- Mo0.1
y.slice <- Mo0[["LP"]] - rexp(1)
L <- -runif(1)
U <- L + 1
if(m > 0) {
L.y <- try(Model(Mo0[["parm"]] + v*L, Data)[["LP"]],
silent=!Debug[["DB.Model"]])
if(inherits(L.y, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out the lower",
"bound failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(Mo0[["parm"]] + v*L,
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
L.y <- Mo0[["LP"]]
}
else if(!is.finite(L.y)) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out the lower",
"bound resulted in non-finite LP.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(Mo0[["parm"]] + v*L,
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
L.y <- Mo0[["LP"]]}
U.y <- try(Model(Mo0[["parm"]] + v*U, Data)[["LP"]],
silent=!Debug[["DB.Model"]])
if(inherits(U.y, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out the upper",
"bound failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(Mo0[["parm"]] + v*U,
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
U.y <- Mo0[["LP"]]
}
else if(!is.finite(U.y)) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out the upper",
"bound resulted in non-finite LP.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(Mo0[["parm"]] + v*U,
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
U.y <- Mo0[["LP"]]}
step <- 0
while({L.y > y.slice || U.y > y.slice} && step < m) {
step <- step + 1
if(runif(1) < 0.5) {
L <- L - 1
L.y <- try(Model(Mo0[["parm"]] + v*L,
Data)[["LP"]], silent=!Debug[["DB.Model"]])
if(inherits(L.y, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out the lower",
"bound failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(Mo0[["parm"]] +
v*L, collapse=","),")",sep=""),
"\n", file=LogFile, append=TRUE)}
L.y <- Mo0[["LP"]]
}
else if(!is.finite(L.y)) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out the lower",
"bound resulted in non-finite LP.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(Mo0[["parm"]] +
v*L, collapse=","),")",sep=""),
"\n", file=LogFile, append=TRUE)}
L.y <- Mo0[["LP"]]
}
}
else {
U <- U + 1
U.y <- try(Model(Mo0[["parm"]] + v*U,
Data)[["LP"]], silent=!Debug[["DB.Model"]])
if(inherits(U.y, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out the upper",
"bound failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(Mo0[["parm"]] +
v*U, collapse=","),")",sep=""),
"\n", file=LogFile, append=TRUE)}
U.y <- Mo0[["LP"]]
}
else if(!is.finite(U.y)) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out the upper",
"bound resulted in non-finite LP.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(Mo0[["parm"]] +
v*U, collapse=","),")",sep=""),
"\n", file=LogFile, append=TRUE)}
U.y <- Mo0[["LP"]]}}}}
### Rejection Sampling
repeat {
prop.offset <- runif(1, min=L, max=U)
prop <- Mo0[["parm"]] + prop.offset * v
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Rejection sampling failed.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Rejection sampling resulted",
"in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0}
prop <- Mo1[["parm"]]
if(Mo1[["LP"]] >= y.slice) break
else if(abs(prop.offset < 1e-100)) {
Mo1 <- Mo0
break}
if(prop.offset < 0) L <- prop.offset
else U <- prop.offset}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo1[["parm"]]
Dev[t.iter] <- Mo1[["Dev"]]
Mon[t.iter,] <- Mo1[["Monitor"]]
DiagCovar[t.iter,] <- diag(S.eig$vectors)}
obs.sum <- obs.sum + Mo1[["parm"]]
obs.scatter <- obs.scatter + tcrossprod(Mo1[["parm"]])
Mo0 <- Mo1}
}
else {
if(!identical(length(VarCov), B))
stop("Number of components in Covar differs from ",
"number of blocks.", file=LogFile, append=TRUE)
S.eig <- obs.sum <- obs.scatter <- list()
decomp.freq <- rep(0, length(B))
DiagCovar <- rep(0, LIV)
for (b in 1:B) {
if(!identical(length(Block[[b]]), length(diag(VarCov[[b]]))))
stop("Diagonal of Covar[[",b,"]] differs from block ",
"length.", file=LogFile, append=TRUE)
if(!is.symmetric.matrix(VarCov[[b]])) {
cat("\nAsymmetric Covar block, correcting now...\n",
file=LogFile, append=TRUE)
VarCov[[b]] <- as.symmetric.matrix(VarCov[[b]])}
if(!is.positive.definite(VarCov[[b]])) {
cat("\nNon-Positive-Definite Covar block,",
"correcting now...\n", file=LogFile, append=TRUE)
VarCov[[b]] <- as.positive.definite(VarCov[[b]])}
decomp.freq[b] <- max(length(Block[[b]]) *
floor(Iterations / Thinning / 100), 10)
S.eig[[b]] <-try(eigen(VarCov[[b]]),
silent=!Debug[["DB.eigen"]])
if(inherits(S.eig[[b]], "try-error")) S.eig[[b]] <- NULL
obs.sum[[b]] <- matrix(Mo0[["parm"]][Block[[b]]]*n,
length(Block[[b]]), 1)
obs.scatter[[b]] <- tcrossprod(Mo0[["parm"]][Block[[b]]])*n
DiagCovar[Block[[b]]] <- diag(VarCov[[b]])}
if(all(decomp.freq == decomp.freq[1]))
cat("\nEigendecomposition will occur every", decomp.freq[1],
"iterations.\n\n", file=LogFile, append=TRUE)
else cat("\nEigendecomposition frequency varies by block,",
"and will occur between\n",
min(decomp.freq), "and", max(decomp.freq),
"iterations.\n\n", file=LogFile, append=TRUE)
DiagCovar <- matrix(DiagCovar, floor(Iterations / Thinning)+1,
LIV, byrow=TRUE)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Blockwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Proceed by Block
for (b in 1:B) {
### Eigenvectors of the Sample Covariance Matrix
if({iter %% decomp.freq[b] == 0} & {iter > 1} &
{iter < A}) {
VarCov[[b]] <- obs.scatter[[b]]/{n + iter} -
tcrossprod(obs.sum[[b]]/{n + iter})
S.eig[[b]] <- eigen(VarCov[[b]])}
### Non-Adaptive or Adaptive
if(runif(1) < w || is.null(S.eig[[b]])) {
v <- rnorm(length(Block[[b]]))
v <- v / sqrt(sum(v*v))
}
else {
which.eig <- floor(1 + length(Block[[b]]) * runif(1))
v <- S.eig[[b]]$vectors[,which.eig] *
sqrt(abs(S.eig[[b]]$values[which.eig]))}
### Slice Interval
Mo0.1 <- try(Model(Mo0[["parm"]][Block[[b]]], Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo0.1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal for block", b,
"failed.\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(Mo0[["parm"]][Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo0.1 <- Mo0}
Mo0 <- Mo0.1
y.slice <- Mo0[["LP"]] - rexp(1)
L <- -runif(1)
U <- L + 1
if(m > 0) {
prop <- Mo0[["parm"]]
prop[Block[[b]]] <- prop[Block[[b]]] + v*L
L.y <- try(Model(prop, Data)[["LP"]],
silent=!Debug[["DB.Model"]])
if(inherits(L.y, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out the lower",
"bound failed for block", b, ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
L.y <- Mo0[["LP"]]
}
else if(!is.finite(L.y)) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out the lower",
"bound resulted in non-finite LP",
"for block", b, ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
L.y <- Mo0[["LP"]]}
prop <- Mo0[["parm"]]
prop[Block[[b]]] <- prop[Block[[b]]] + v*U
U.y <- try(Model(prop, Data)[["LP"]],
silent=!Debug[["DB.Model"]])
if(inherits(U.y, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out the upper",
"bound failed for block", b, ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
U.y <- Mo0[["LP"]]
}
else if(!is.finite(U.y)) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out the upper",
"bound resulted in non-finite LP",
"for block", b, ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
U.y <- Mo0[["LP"]]}
step <- 0
while({L.y > y.slice || U.y > y.slice} && step < m) {
step <- step + 1
if(runif(1) < 0.5) {
L <- L - 1
prop <- Mo0[["parm"]]
prop[Block[[b]]] <- prop[Block[[b]]] + v*L
L.y <- try(Model(prop, Data)[["LP"]],
silent=!Debug[["DB.Model"]])
if(inherits(L.y, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out the",
"lower bound failed for",
"block", b, ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Proposal:\n", paste("c(",
paste(prop[Block[[b]]],
collapse=","),")",sep=""),
"\n", file=LogFile,
append=TRUE)}
L.y <- Mo0[["LP"]]
}
else if(!is.finite(L.y)) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out the",
"lower bound resulted in ",
"non-finite LP for block",
b, ".\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter,
"Proposal:\n", paste("c(",
paste(prop[Block[[b]]],
collapse=","),")",sep=""),
"\n", file=LogFile,
append=TRUE)}
L.y <- Mo0[["LP"]]
}
}
else {
U <- U + 1
prop <- Mo0[["parm"]]
prop[Block[[b]]] <- prop[Block[[b]]] + v*U
U.y <- try(Model(prop, Data)[["LP"]],
silent=!Debug[["DB.Model"]])
if(inherits(U.y, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out the",
"upper bound failed for",
"block", b, ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Proposal:\n", paste("c(",
paste(prop[Block[[b]]],
collapse=","),")",sep=""),
"\n", file=LogFile,
append=TRUE)}
U.y <- Mo0[["LP"]]
}
else if(!is.finite(U.y)) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out the",
"upper bound resulted in",
"non-finite LP for block",
b, ".\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter,
"Proposal:\n", paste("c(",
paste(prop[Block[[b]]],
collapse=","),")",sep=""),
"\n", file=LogFile,
append=TRUE)}
U.y <- Mo0[["LP"]]}}}}
### Rejection Sampling
repeat {
prop.offset <- runif(1, min=L, max=U)
prop <- Mo0[["parm"]]
prop[Block[[b]]] <- prop[Block[[b]]] + prop.offset*v
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Rejection sampling",
"failed for block", b, ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Rejection sampling",
"resulted in non-finite",
"value(s) for block", b, ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo1 <- Mo0}
prop <- Mo1[["parm"]]
if(Mo1[["LP"]] >= y.slice) break
else if(abs(prop.offset < 1e-100)) {
Mo1 <- Mo0
break}
if(prop.offset < 0) L <- prop.offset
else U <- prop.offset}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo1[["parm"]]
Dev[t.iter] <- Mo1[["Dev"]]
Mon[t.iter,] <- Mo1[["Monitor"]]
DiagCovar[t.iter,Block[[b]]] <- diag(S.eig[[b]]$vectors)}
obs.sum[[b]] <- obs.sum[[b]] + Mo1[["parm"]][Block[[b]]]
obs.scatter[[b]] <- obs.scatter[[b]] +
tcrossprod(Mo1[["parm"]][Block[[b]]])
Mo0 <- Mo1}
}
}
### Output
out <- list(Acceptance=Iterations,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=VarCov)
return(out)
}
.mcmcusamwg <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, tuning,
parm.names, Debug, LogFile)
{
Dyn <- Specs[["Dyn"]]
Periodicity <- Specs[["Periodicity"]]
Fit <- Specs[["Fit"]]
Begin <- Specs[["Begin"]]
Acceptance <- matrix(0, 1, LIV)
for (k in 1:ncol(Dyn)) {for (t in 1:nrow(Dyn)) {
Dyn[t,k] <- which(parm.names == Dyn[t,k])}}
Dyn <- matrix(as.numeric(Dyn), nrow(Dyn), ncol(Dyn))
Dyn <- matrix(Dyn[-c(1:(Begin-1)),], nrow(Dyn)-Begin+1, ncol(Dyn))
n.samples <- nrow(Fit$Posterior1)
mults <- Iterations / n.samples
samps <- rep(1:n.samples, each=mults)
if(Iterations != length(samps))
stop("Iterations not a multiple of posterior samples.",
file=LogFile, append=TRUE)
ivs <- Mo0[["parm"]]
post <- Fit$Posterior1[samps,]
post[1,as.vector(Dyn)] <- ivs[as.vector(Dyn)]
DiagCovar <- matrix(tuning, floor(Iterations/Periodicity), LIV,
byrow=TRUE)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Store Current Posterior
if(iter > 1) post[iter,as.vector(Dyn)] <- post[iter-1,as.vector(Dyn)]
### Select Order of Parameters
if(ncol(Dyn) == 1) dynsample <- sample(Dyn)
else dynsample <- as.vector(apply(Dyn, 1, sample))
### Componentwise Estimation
for (j in dynsample) {
### Propose new parameter values
prop <- post[iter,]
prop[j] <- rnorm(1, prop[j], tuning[j])
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed for",
Data[["parm.names"]][j], ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
u <- log(runif(1)) < (Mo1[["LP"]] - Mo0[["LP"]])
if(u == TRUE) {
Mo0 <- Mo1
post[iter,] <- Mo0[["parm"]]
Acceptance[j] <- Acceptance[j] + 1}}}
### Adapt the Proposal Variance
if(iter %% Periodicity == 0) {
size <- 1 / min(100, sqrt(iter))
Acceptance.Rate <- Acceptance / iter
log.tuning <- log(tuning)
tuning.num <- which(Acceptance.Rate > 0.44)
log.tuning[tuning.num] <- log.tuning[tuning.num] + size
log.tuning[-tuning.num] <- log.tuning[-tuning.num] - size
tuning <- exp(log.tuning)
a.iter <- floor(iter / Periodicity)
DiagCovar[a.iter,] <- tuning}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- post[iter,]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=mean(as.vector(Acceptance[dynsample])),
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=tuning)
return(out)
}
.mcmcusmwg <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, tuning,
parm.names, Debug, LogFile)
{
Dyn <- Specs[["Dyn"]]
Fit <- Specs[["Fit"]]
Begin <- Specs[["Begin"]]
Acceptance <- matrix(0, 1, LIV)
for (k in 1:ncol(Dyn)) {for (t in 1:nrow(Dyn)) {
Dyn[t,k] <- which(parm.names == Dyn[t,k])}}
Dyn <- matrix(as.numeric(Dyn), nrow(Dyn), ncol(Dyn))
Dyn <- matrix(Dyn[-c(1:(Begin-1)),], nrow(Dyn)-Begin+1, ncol(Dyn))
n.samples <- nrow(Fit$Posterior1)
mults <- Iterations / n.samples
samps <- rep(1:n.samples, each=mults)
if(Iterations != length(samps))
stop("Iterations not a multiple of posterior samples.",
file=LogFile, append=TRUE)
ivs <- Mo0[["parm"]]
post <- Fit$Posterior1[samps,]
post[1,as.vector(Dyn)] <- ivs[as.vector(Dyn)]
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Store Current Posterior
if(iter > 1) post[iter,as.vector(Dyn)] <- post[iter-1,as.vector(Dyn)]
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
### Select Order of Parameters
if(ncol(Dyn) == 1) dynsample <- sample(Dyn)
else dynsample <- as.vector(apply(Dyn, 1, sample))
### Componentwise Estimation
for (j in dynsample) {
### Propose new parameter values
prop <- post[iter,]
prop[j] <- rnorm(1, prop[j], tuning[j])
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed for",
Data[["parm.names"]][j], ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
u <- log(runif(1)) < (Mo1[["LP"]] - Mo0[["LP"]])
if(u == TRUE) {
Mo0 <- Mo1
post[iter,] <- Mo0[["parm"]]
Acceptance[j] <- Acceptance[j] + 1}}}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=mean(as.vector(Acceptance[dynsample])),
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=tuning)
return(out)
}
#End
Try the LaplacesDemon package in your browser
Any scripts or data that you put into this service are public.
LaplacesDemon documentation built on July 9, 2021, 5:07 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions .mcmcusmwg .mcmcusamwg .mcmcuess .mcmctwalk .mcmcthmc .mcmcsmwg .mcmcslice .mcmcsgld .mcmcsamwg .mcmcrwm .mcmcrss .mcmcrj .mcmcrefractive .mcmcrdmh .mcmcram .mcmcpcn .mcmcohss .mcmcnuts .mcmcmwg .mcmcmtm .mcmcmcmcmc .mcmcmala .mcmcinca .mcmcim .mcmchmcda .mcmchmc .mcmcharm .mcmcggdpp .mcmcggdp .mcmcggcpp .mcmcggcp .mcmcgg .mcmcgibbs .mcmcess .mcmcdrm .mcmcdram .mcmcdemc .mcmccharm .mcmcamwg .mcmcamm.b .mcmcamm .mcmcam .mcmcaies .mcmcahmc .mcmcagg .mcmcafss .mcmcadmg LaplacesDemon
Documented in LaplacesDemon .mcmcadmg .mcmcafss .mcmcagg .mcmcahmc .mcmcaies .mcmcam .mcmcamm .mcmcamm.b .mcmcamwg .mcmccharm .mcmcdemc .mcmcdram .mcmcdrm .mcmcess .mcmcgg .mcmcggcp .mcmcggcpp .mcmcggdp .mcmcggdpp .mcmcgibbs .mcmcharm .mcmchmc .mcmchmcda .mcmcim .mcmcinca .mcmcmala .mcmcmcmcmc .mcmcmtm .mcmcmwg .mcmcnuts .mcmcohss .mcmcram .mcmcrdmh .mcmcrefractive .mcmcrj .mcmcrss .mcmcrwm .mcmcsamwg .mcmcsgld .mcmcslice .mcmcsmwg .mcmcthmc .mcmctwalk .mcmcuess .mcmcusamwg .mcmcusmwg
###########################################################################
# LaplacesDemon #
# #
# The purpose of the LaplacesDemon function is to use MCMC on the #
# logarithm of the unnormalized joint posterior density of a Bayesian #
# model. #
###########################################################################
LaplacesDemon <- function(Model, Data, Initial.Values, Covar=NULL,
Iterations=10000, Status=100, Thinning=10, Algorithm="MWG",
Specs=list(B=NULL), Debug=list(DB.chol=FALSE, DB.eigen=FALSE,
DB.MCSE=FALSE, DB.Model=TRUE), LogFile="", ...)
{
cat("\nLaplace's Demon was called on ", date(), "\n", sep="",
file=LogFile, append=TRUE)
time1 <- proc.time()
LDcall <- match.call()
########################## Initial Checks ##########################
cat("\nPerforming initial checks...\n", file=LogFile, append=TRUE)
if(missing(Model))
stop("A function must be entered for Model.", file=LogFile,
append=TRUE)
if(!is.function(Model))
stop("Model must be a function.", file=LogFile, append=TRUE)
if(missing(Data))
stop("A list containing data must be entered for Data.",
file=LogFile, append=TRUE)
if(is.null(Data[["mon.names"]]))
stop("In Data, mon.names is NULL.", file=LogFile, append=TRUE)
if(is.null(Data[["parm.names"]]))
stop("In Data, parm.names is NULL.", file=LogFile, append=TRUE)
for (i in 1:length(Data)) {
if(is.matrix(Data[[i]])) {
if(all(is.finite(Data[[i]]))) {
mat.rank <- qr(Data[[i]], tol=1e-10)$rank
if(mat.rank < ncol(Data[[i]])) {
cat("WARNING: Matrix", names(Data)[[i]],
"may be rank-deficient.\n", file=LogFile,
append=TRUE)}}}}
if(missing(Initial.Values)) {
cat("WARNING: Initial Values were not supplied.\n", file=LogFile,
append=TRUE)
Initial.Values <- rep(0, length(Data[["parm.names"]]))}
if(!identical(length(Initial.Values), length(Data[["parm.names"]]))) {
cat("WARNING: The length of Initial Values differed from",
"Data$parm.names.\n", file=LogFile, append=TRUE)
Initial.Values <- rep(0, length(Data[["parm.names"]]))}
if(any(!is.finite(Initial.Values))) {
cat("WARNING: Initial Values contain non-finite values.\n",
file=LogFile, append=TRUE)
Initial.Values <- rep(0, length(Data[["parm.names"]]))}
Iterations <- round(abs(Iterations))
if(Iterations < 11) {
Iterations <- 11
cat("'Iterations' has been changed to ", Iterations, ".\n",
sep="", file=LogFile, append=TRUE)}
Status <- round(abs(Status))
if({Status < 1} || {Status > Iterations}) {
Status <- Iterations
cat("'Status' has been changed to ", Status, ".\n",
sep="", file=LogFile, append=TRUE)}
Thinning <- round(abs(Thinning))
if({Thinning < 1} || {Thinning > Iterations}) {
Thinning <- 1
cat("'Thinning' has been changed to ", Thinning, ".\n",
sep="", file=LogFile, append=TRUE)}
if(Algorithm %in% c("ADMG","AFSS","AGG","AHMC","AIES","AM","AMM",
"AMWG","CHARM","DEMC","DRAM","DRM","ESS","Experimental","GG",
"Gibbs","HARM","HMC","HMCDA","IM","INCA","MALA","MCMCMC","MTM",
"MWG","NUTS","OHSS","pCN","RAM","Refractive","RDMH","RJ","RSS",
"RWM","SAMWG","SGLD","Slice","SMWG","THMC","twalk","UESS",
"USAMWG","USMWG")) {
if(Algorithm == "ADMG") {
Algorithm <- "Adaptive Directional Metropolis-within-Gibbs"
if(missing(Specs) | is.null(Specs))
Specs <- list(n=0, Periodicity=1)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("n","Periodicity") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["n"]] <- abs(round(Specs[["n"]]))
Specs[["Periodicity"]] <- max(abs(round(Specs[["Periodicity"]])),
length(Initial.Values))
}
else if(Algorithm == "AFSS") {
Algorithm <- "Automated Factor Slice Sampler"
if(missing(Specs) | is.null(Specs))
Specs <- list(A=Inf, B=NULL, m=Inf, n=0, w=1)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("A","B","m","n","w") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["A"]] <- min(round(abs(Specs[["A"]])), Iterations)
Specs[["m"]] <- abs(round(Specs[["m"]]))
if(!identical(length(Specs[["m"]]), length(Initial.Values)))
Specs[["m"]] <- rep(Specs[["m"]],
length(Initial.Values))
Specs[["n"]] <- abs(round(Specs[["n"]]))
Specs[["w"]] <- abs(Specs[["w"]])
if(!identical(length(Specs[["w"]]), length(Initial.Values)))
Specs[["w"]] <- rep(Specs[["w"]],
length(Initial.Values))
}
else if(Algorithm == "AGG") {
Algorithm <- "Adaptive Griddy-Gibbs"
if(missing(Specs))
stop("The Specs argument is required.", file=LogFile,
append=TRUE)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("Grid","dparm","smax","CPUs","Packages","Dyn.libs")
%in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
if(is.list(Specs[["Grid"]])) {
if(length(Specs[["Grid"]]) != length(Initial.Values)) {
Specs[["Grid"]] <- list(NULL)
for (i in 1:length(Initial.Values))
Specs[["Grid"]][[i]] <- GaussHermiteQuadRule(3)$nodes
cat("\nGrid was misspecified and changed to default.\n",
file=LogFile, append=TRUE)}
}
else {
temp <- as.vector(Specs[["Grid"]])
Specs[["Grid"]] <- list(NULL)
for (i in 1:length(Initial.Values))
Specs[["Grid"]][[i]] <- temp}
if(!is.null(Specs[["dparm"]])) {
Specs[["dparm"]] <- unique(interval(round(Specs[["dparm"]]), 1,
length(Initial.Values)))
Specs[["dparm"]] <- Specs[["dparm"]][order(Specs[["dparm"]])]}
else Specs[["dparm"]] <- 0
Specs[["smax"]] <- abs(Specs[["smax"]])
Specs[["CPUs"]] <- max(1, abs(round(Specs[["CPUs"]])))
}
else if(Algorithm == "AHMC") {
Algorithm <- "Adaptive Hamiltonian Monte Carlo"
if(missing(Specs) | is.null(Specs))
Specs=list(epsilon=rep(1/length(Initial.Values),
length(Initial.Values)), L=2, m=rep(1,
length(Initial.Values)), Periodicity=1)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("epsilon","L","m","Periodicity") %in% names(Specs)))
if(!identical(names(Specs),
c("epsilon","L","m","Periodicity")))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
if(is.null(Specs[["epsilon"]]))
Specs[["epsilon"]] <- rep(1/length(Initial.Values),
length(Initial.Values))
Specs[["epsilon"]] <- as.vector(abs(Specs[["epsilon"]]))
if(length(Specs[["epsilon"]]) != length(Initial.Values)) {
cat("\nLength of epsilon is incorrect.\n",
file=LogFile, append=TRUE)
Specs[["epsilon"]] <- rep(Specs[["epsilon"]][1],
length(Initial.Values))}
Specs[["L"]] <- abs(round(Specs[["L"]]))
if(Specs[["L"]] < 1) {
cat("\nL has been increased to its minimum: 1.\n",
file=LogFile, append=TRUE)
Specs[["L"]] <- 1}
if(is.null(Specs[["m"]]))
Specs[["m"]] <- diag(length(Initial.Values))
}
else if(Algorithm == "AIES") {
Algorithm <- "Affine-Invariant Ensemble Sampler"
if(missing(Specs))
stop("The Specs argument is required.", file=LogFile,
append=TRUE)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("Nc","Z","beta","CPUs","Packages","Dyn.libs") %in%
names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["Nc"]] <- max(abs(round(Specs[["Nc"]])), 3)
if(!is.null(Specs[["Z"]])) {
if(is.matrix(Specs[["Z"]])) {
if(ncol(Specs[["Z"]]) != length(Initial.Values))
stop("Z has the wrong number of columns.",
file=LogFile, append=TRUE)
if(nrow(Specs[["Z"]]) != Specs[["Nc"]])
stop("Z has the wrong number of rows.",
file=LogFile, append=TRUE)}}
if(length(Specs[["beta"]]) != 1) {
cat("\nLength of beta is wrong. Changed to 1.\n",
file=LogFile, append=TRUE)
Specs[["beta"]] <- as.vector(Specs[["beta"]])[1]}
if(Specs[["beta"]] <= 1) {
cat("\nbeta must be > 1. Changed to 2.\n",
file=LogFile, append=TRUE)
Specs[["beta"]] <- 2}
Specs[["CPUs"]] <- max(1, abs(round(Specs[["CPUs"]])))
if(Specs[["CPUs"]] > 1 & Specs[["Nc"]] %% 2 != 0)
stop("For CPUs > 1, Nc must be even.", file=LogFile,
append=TRUE)
}
else if(Algorithm == "AM") {
Algorithm <- "Adaptive Metropolis"
if(missing(Specs) | is.null(Specs))
Specs=list(Adaptive=floor(Iterations/2),
Periodicity=1)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("Adaptive","Periodicity") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
}
else if(Algorithm == "AMM") {
Algorithm <- "Adaptive-Mixture Metropolis"
if(missing(Specs) | is.null(Specs))
Specs=list(Adaptive=floor(Iterations/2), B=NULL,
n=0, Periodicity=1, w=0.05)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("Adaptive","B","n","Periodicity","w") %in%
names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
if(!is.null(Specs[["B"]])) {
if(is.null(Covar)) {
Covar <- list(NULL)
for (b in 1:length(Specs[["B"]])) {
Covar[[b]] <- diag(length(Specs[["B"]][[b]]))}}}
Specs[["n"]] <- round(abs(Specs[["n"]]))
Specs[["w"]] <- abs(Specs[["w"]])
if(Specs[["w"]] <= 0 || Specs[["w"]] >= 1) {
Specs[["w"]] <- 0.05
cat("\nw was misspecified and changed to 0.05.\n",
file=LogFile, append=TRUE)}
}
else if(Algorithm == "AMWG") {
Algorithm <- "Adaptive Metropolis-within-Gibbs"
if(missing(Specs) | is.null(Specs))
Specs=list(B=NULL, n=0, Periodicity=50)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("B","n","Periodicity") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
}
else if(Algorithm == "CHARM") {
Algorithm <- "Componentwise Hit-And-Run Metropolis"
if(missing(Specs) | is.null(Specs))
Specs <- list(alpha.star=NA)
else {
if(!is.list(Specs))
stop("The Specs argument is not a list.",
file=LogFile, append=TRUE)
if(!all(c("alpha.star") %in% names(Specs)))
stop("The Specs argument is incorrect",
file=LogFile, append=TRUE)
Specs[["alpha.star"]] <- abs(as.vector(Specs[["alpha.star"]])[1])
if(Specs[["alpha.star"]] <= 0 | Specs[["alpha.star"]] >= 1) {
cat("\nalpha.star not in (0,1), set to 0.44.\n",
file=LogFile, append=TRUE)
alpha.star <- 0.44}}
}
else if(Algorithm == "DEMC") {
Algorithm <- "Differential Evolution Markov Chain"
if(missing(Specs))
stop("The Specs argument is required.", file=LogFile,
append=TRUE)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("Nc","Z","gamma","w") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["Nc"]] <- max(abs(round(Specs[["Nc"]])), 3)
if(!is.null(Specs[["Z"]])) {
if(is.matrix(Specs[["Z"]])) {
if(ncol(Specs[["Z"]]) != length(Initial.Values))
stop("Z has the wrong number of columns.",
file=LogFile, append=TRUE)
if(nrow(Specs[["Z"]]) != (floor(Iterations/Thinning)+1)) {
Z.temp <- Specs[["Z"]][nrow(Specs[["Z"]]),]
if(nrow(Specs[["Z"]]) < (floor(Iterations/Thinning)+1)) {
Specs[["Z"]] <- rbind(Specs[["Z"]],
Specs[["Z"]][1:(floor(Iterations/Thinning)+1-nrow(Specs[["Z"]])),])
}
else if(nrow(Specs[["Z"]]) > (floor(Iterations/Thinning)+1))
Specs[["Z"]] <- Specs[["Z"]][1:(floor(Iterations/Thinning)+1),]
Specs[["Z"]][1,] <- Z.temp
}
Specs[["Z"]] <- array(Specs[["Z"]], dim=c(floor(Iterations/Thinning)+1,
length(Initial.Values), Specs[["Nc"]]))}
if(dim(Specs[["Z"]])[1] != floor(Iterations/Thinning)+1)
stop("The first dimension of Z is incorrect.",
file=LogFile, append=TRUE)
if(dim(Specs[["Z"]])[2] != length(Initial.Values))
stop("The second dimension of Z is incorrect.",
file=LogFile, append=TRUE)
if(dim(Specs[["Z"]])[3] != Specs[["Nc"]])
stop("The third dimension of Z is incorrect.",
file=LogFile, append=TRUE)}
if(is.null(Specs[["gamma"]]))
Specs[["gamma"]] <- 2.381204 /
sqrt(2*length(Initial.Values))
else Specs[["gamma"]] <- abs(Specs[["gamma"]])
Specs[["w"]] <- interval(Specs[["w"]], 0, 1)
}
else if(Algorithm == "DRAM") {
Algorithm <- "Delayed Rejection Adaptive Metropolis"
if(missing(Specs) | is.null(Specs))
Specs=list(Adaptive=floor(Iterations/2),
Periodicity=1)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("Adaptive","Periodicity") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
}
else if(Algorithm == "DRM") {
Algorithm <- "Delayed Rejection Metropolis"
Specs <- NULL
}
else if(Algorithm == "ESS") {
Algorithm <- "Elliptical Slice Sampler"
if(missing(Specs) | is.null(Specs))
Specs=list(B=NULL)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("B") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
if(is.null(Specs[["B"]])) Specs[["B"]] <- list()
}
else if(Algorithm == "Experimental") {
Specs=NULL
}
else if(Algorithm == "GG") {
Algorithm <- "Griddy-Gibbs"
if(missing(Specs))
stop("The Specs argument is required.", file=LogFile,
append=TRUE)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("Grid","dparm","CPUs","Packages","Dyn.libs") %in%
names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
if(is.list(Specs[["Grid"]])) {
if(length(Specs[["Grid"]]) != length(Initial.Values)) {
Specs[["Grid"]] <- list(NULL)
for (i in 1:length(Initial.Values))
Specs[["Grid"]][[i]] <- seq(from=-0.1, to=0.1, len=5)
cat("\nGrid was misspecified and changed to default.\n",
file=LogFile, append=TRUE)}
}
else {
temp <- as.vector(Specs[["Grid"]])
Specs[["Grid"]] <- list(NULL)
for (i in 1:length(Initial.Values))
Specs[["Grid"]][[i]] <- temp}
if(!is.null(Specs[["dparm"]])) {
Specs[["dparm"]] <- unique(interval(round(Specs[["dparm"]]), 1,
length(Initial.Values)))
Specs[["dparm"]] <- Specs[["dparm"]][order(Specs[["dparm"]])]}
else Specs[["dparm"]] <- 0
Specs[["CPUs"]] <- max(1, abs(round(Specs[["CPUs"]])))
}
else if(Algorithm == "Gibbs") {
Algorithm <- "Gibbs Sampler"
if(missing(Specs) | is.null(Specs)) {
cat("\nSpecs missing or null, Algorithm changed to MWG.\n",
file=LogFile, append=TRUE)
Algorithm == "MWG"
Specs <- NULL
}
else {
if(!is.list(Specs))
stop("The Specs argument is not a list.",
file=LogFile, append=TRUE)
if(!all(c("FC","MWG") %in% names(Specs)))
stop("The Specs argument is incorrect",
file=LogFile, append=TRUE)
if(!is.function(Specs[["FC"]]))
stop("FC must be a function.", file=LogFile,
append=TRUE)
FCtest <- try(Specs[["FC"]](Initial.Values, Data),
silent=TRUE)
if(inherits(FCtest, "try-error"))
stop("Error in FC.", file=LogFile, append=TRUE)
if(!is.vector(FCtest))
stop("FC must return a vector.", file=LogFile,
append=TRUE)
if(length(FCtest) != length(Initial.Values))
stop("Length of parameters to/from FC differs.",
file=LogFile, append=TRUE)
if(!is.null(Specs[["MWG"]]) &
!is.vector(Specs[["MWG"]]) &
!is.numeric(Specs[["MWG"]]))
stop("MWG must be a numeric vector.",
file=LogFile, append=TRUE)}
}
else if(Algorithm == "HARM") {
Algorithm <- "Hit-And-Run Metropolis"
if(missing(Specs) | is.null(Specs))
Specs <- list(alpha.star=NA, B=NULL)
else {
if(!is.list(Specs))
stop("The Specs argument is not a list.",
file=LogFile, append=TRUE)
if(!all(c("alpha.star","B") %in% names(Specs)))
stop("The Specs argument is incorrect",
file=LogFile, append=TRUE)
Specs[["alpha.star"]] <- abs(as.vector(Specs[["alpha.star"]])[1])
if(Specs[["alpha.star"]] <= 0 | Specs[["alpha.star"]] >= 1) {
cat("\nalpha.star not in (0,1), set to 0.234.\n",
file=LogFile, append=TRUE)
alpha.star <- 0.234}
if(is.na(Specs[["alpha.star"]]) & !is.null(Specs[["B"]]))
alpha.star <- 0.234}
if(is.null(Specs[["B"]])) Specs[["B"]] <- list()
}
else if(Algorithm == "HMC") {
Algorithm <- "Hamiltonian Monte Carlo"
if(missing(Specs) | is.null(Specs))
Specs=list(epsilon=rep(1/length(Initial.Values),
length(Initial.Values)), L=2, m=rep(1,
length(Initial.Values)))
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("epsilon","L","m") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["epsilon"]] <- abs(Specs[["epsilon"]])
if(length(Specs[["epsilon"]]) != length(Initial.Values)) {
Specs[["epsilon"]] <- rep(Specs[["epsilon"]][1],
length(Initial.Values))}
Specs[["L"]] <- abs(round(Specs[["L"]]))
if(Specs[["L"]] < 1) {
cat("\nL has been increased to its minimum: 1.\n",
file=LogFile, append=TRUE)
L <- 1}
if(is.null(Specs[["m"]]))
Specs[["m"]] <- diag(length(Initial.Values))
}
else if(Algorithm == "HMCDA") {
Algorithm <- "Hamiltonian Monte Carlo with Dual-Averaging"
if(missing(Specs))
stop("The Specs argument is required.", file=LogFile,
append=TRUE)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("A","delta","epsilon","Lmax","lambda") %in%
names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["A"]] <- min(round(abs(Specs[["A"]])), Iterations)
Specs[["delta"]] <- max(min(abs(Specs[["delta"]]), 1),
1/Iterations)
if(!is.null(Specs[["epsilon"]]))
Specs[["epsilon"]] <- abs(Specs[["epsilon"]][1])
Specs[["Lmax"]] <- abs(round(Specs[["Lmax"]]))
Specs[["lambda"]] <- abs(Specs[["lambda"]])
if(!is.null(Specs[["epsilon"]]))
if(Specs[["lambda"]] < Specs[["epsilon"]])
Specs[["lambda"]] <- Specs[["epsilon"]]
}
else if(Algorithm == "IM") {
Algorithm <- "Independence Metropolis"
if(missing(Specs))
stop("The Specs argument is required.", file=LogFile,
append=TRUE)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("mu") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["mu"]] <- as.vector(Specs[["mu"]])
if(length(Specs[["mu"]]) != length(Initial.Values))
stop("length(mu) != length(Initial.Values).",
file=LogFile, append=TRUE)
}
else if(Algorithm == "INCA") {
Algorithm <- "Interchain Adaptation"
if(missing(Specs) | is.null(Specs))
Specs=list(Adaptive=floor(Iterations/2),
Periodicity=1)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("Adaptive","Periodicity") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
}
else if(Algorithm == "MALA") {
Algorithm <- "Metropolis-Adjusted Langevin Algorithm"
if(missing(Specs) | is.null(Specs))
Specs=list(A=1e7, alpha.star=0.574, delta=1,
epsilon=c(1e-6,1e-7))
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("A","alpha.star","gamma","delta","epsilon") %in%
names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["A"]] <- abs(Specs[["A"]][1])
Specs[["gamma"]] <- min(max(Specs[["gamma"]][1], 0),
Iterations)
Specs[["delta"]] <- min(max(Specs[["delta"]][1], 1e-10),
1000)
Specs[["epsilon"]] <- abs(Specs[["epsilon"]][1:2])
}
else if(Algorithm == "MCMCMC") {
Algorithm <- "Metropolis-Coupled Markov Chain Monte Carlo"
if(missing(Specs) | is.null(Specs))
Specs <- list(lambda=1, CPUs=1, Packages=NULL,
Dyn.libs=NULL)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("lambda","CPUs","Packages","Dyn.libs") %in%
names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["lambda"]] <- abs(Specs[["lambda"]])
if(Specs[["CPUs"]] <= 1)
cat("\nCPUs must be at least 2. Attempting 2 CPUs...\n",
file=LogFile, append=TRUE)
Specs[["CPUs"]] <- max(2, abs(round(Specs[["CPUs"]])))
}
else if(Algorithm == "MTM") {
Algorithm <- "Multiple-Try Metropolis"
if(missing(Specs) | is.null(Specs))
Specs <- list(K=4, CPUs=1, Packages=NULL, Dyn.libs=NULL)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("K","CPUs","Packages","Dyn.libs") %in%
names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["K"]] <- abs(round(Specs[["K"]]))
if(Specs[["CPUs"]] < 1)
cat("\nCPUs must be at least 1.\n", file=LogFile,
append=TRUE)
Specs[["CPUs"]] <- max(1, abs(round(Specs[["CPUs"]])))
}
else if(Algorithm == "MWG") {
Algorithm <- "Metropolis-within-Gibbs"
if(missing(Specs) | is.null(Specs))
Specs <- list(B=NULL)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("B") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
}
else if(Algorithm == "NUTS") {
Algorithm <- "No-U-Turn Sampler"
if(missing(Specs))
stop("The Specs argument is required.", file=LogFile,
append=TRUE)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("A","delta","epsilon","Lmax") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["A"]] <- max(min(round(abs(Specs[["A"]])),
Iterations),1)
Specs[["delta"]] <- max(min(abs(Specs[["delta"]]),
1), 1/Iterations)
if(!is.null(Specs[["epsilon"]]))
Specs[["epsilon"]] <- abs(Specs[["epsilon"]][1])
Specs[["Lmax"]] <- round(abs(Specs[["Lmax"]]))
}
else if(Algorithm == "OHSS") {
Algorithm <- "Oblique Hyperrectangle Slice Sampler"
if(missing(Specs) | is.null(Specs))
Specs <- list(A=Iterations+1, n=0)
else {
if(!is.list(Specs))
stop("The Specs argument is not a list.",
file=LogFile, append=TRUE)
if(!all(c("A", "n") %in% names(Specs)))
stop("The Specs argument is incorrect.",
file=LogFile, append=TRUE)
Specs[["A"]] <- round(abs(Specs[["A"]]))
Specs[["n"]] <- round(abs(Specs[["n"]]))}
}
else if(Algorithm == "pCN") {
Algorithm <- "Preconditioned Crank-Nicolson"
if(missing(Specs) | is.null(Specs))
Specs <- list(beta=0.01)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("beta") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["beta"]] <- max(min(Specs[["beta"]], 1), 0)
}
else if(Algorithm == "RAM") {
Algorithm <- "Robust Adaptive Metropolis"
if(missing(Specs) | is.null(Specs))
Specs=list(alpha.star=0.234, B=NULL, Dist="N",
gamma=0.66, n=0)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("alpha.star","B","Dist","gamma","n") %in%
names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["alpha.star"]] <- Specs[["alpha.star"]][1]
if(Specs[["alpha.star"]] <= 0 ||
Specs[["alpha.star"]] >= 1) {
cat("\nalpha.star not in (0,1). Changed to 0.234.\n",
file=LogFile, append=TRUE)
Specs[["alpha.star"]] <- 0.234}
if(!is.null(Specs[["B"]])) {
if(is.null(Covar)) {
Covar <- list(NULL)
for (b in 1:length(Specs[["B"]])) {
Covar[[b]] <- diag(length(Specs[["B"]][[b]]))}}}
if(Specs[["Dist"]] != "t" & Specs[["Dist"]] != "N") {
cat("\nDist was not t or N, and changed to N.\n",
file=LogFile, append=TRUE)
Specs[["Dist"]] <- "N"}
Specs[["gamma"]] <- Specs[["gamma"]][1]
if(Specs[["gamma"]] <= 0.5 || Specs[["gamma"]] > 1) {
cat("\ngamma not in (0.5,1]. Changed to 0.66.\n",
file=LogFile, append=TRUE)
Specs[["gamma"]] <- 0.66}
Specs[["n"]] <- abs(Specs[["n"]][1])
}
else if(Algorithm == "RDMH") {
Algorithm <- "Random Dive Metropolis-Hastings"
Specs <- NULL
}
else if(Algorithm == "Refractive") {
Algorithm <- "Refractive Sampler"
if(missing(Specs) | is.null(Specs))
Specs=list(Adaptive=1, m=2, w=0.1, r=1.3)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("Adaptive","m","w","r") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["m"]] <- abs(round(Specs[["m"]]))
if(length(Specs[["m"]]) != 1)
Specs[["m"]] <- Specs[["m"]][1]
if(Specs[["m"]] < 2) {
cat("\nm was misspecified, and is replaced with 2.\n",
file=LogFile, append=TRUE)
Specs[["m"]] <- 2}
Specs[["w"]] <- abs(Specs[["w"]])
if(length(Specs[["w"]]) != 1)
Specs[["w"]] <- Specs[["w"]][1]
Specs[["r"]] <- abs(Specs[["r"]])
if(length(Specs[["r"]]) != 1)
Specs[["r"]] <- Specs[["r"]][1]
}
else if(Algorithm == "RJ") {
Algorithm <- "Reversible-Jump"
if(missing(Specs))
stop("The Specs argument is required.", file=LogFile,
append=TRUE)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("bin.n","bin.p","parm.p","selectable","selected") %in%
names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["bin.n"]] <- round(Specs[["bin.n"]])
if(Specs[["bin.n"]] > length(Initial.Values))
Specs[["bin.n"]] <- length(Initial.Values)
if(Specs[["bin.n"]] < 1) Specs[["bin.n"]] <- 1
if(Specs[["bin.p"]] < 0 | Specs[["bin.p"]] > 1) {
Specs[["bin.p"]] <- interval(Specs[["bin.p"]],
0, 1, reflect=FALSE)
cat("\nbin.p must be in [0,1]. It's now",
round(Specs[["bin.p"]],5), "\n", file=LogFile,
append=TRUE)}
Specs[["parm.p"]] <- as.vector(Specs[["parm.p"]])
if(length(Specs[["parm.p"]]) != length(Initial.Values)) {
Specs[["parm.p"]] <- rep(Specs[["parm.p"]][1],
length(Initial.Values))
cat("\nparm.p now has the correct length, all equal to parm.p[1].\n",
file=LogFile, append=TRUE)}
Specs[["selectable"]] <- as.vector(Specs[["selectable"]])
if(length(Specs[["selectable"]]) != length(Initial.Values)) {
Specs[["selectable"]] <- rep(1, length(Initial.Values))
cat("\nselectable now has the correct length, all set to 1.\n",
file=LogFile, append=TRUE)}
Specs[["selected"]] <- as.vector(Specs[["selected"]])
if(length(Specs[["selected"]]) != length(Initial.Values)) {
Specs[["selected"]] <- rep(1, length(Initial.Values))
cat("\nselected now has the correct length, all set to 1.\n",
file=LogFile, append=TRUE)}
}
else if(Algorithm == "RSS") {
Algorithm <- "Reflective Slice Sampler"
if(missing(Specs))
stop("The Specs argument is required.", file=LogFile,
append=TRUE)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("m","w") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["m"]] <- abs(round(Specs[["m"]]))
if(length(Specs[["m"]]) != 1)
Specs[["m"]] <- Specs[["m"]][1]
if(Specs[["m"]] < 1) {
cat("\nm was misspecified, and is replaced with 1.\n",
file=LogFile, append=TRUE)
Specs[["m"]] <- 1}
Specs[["w"]] <- abs(Specs[["w"]])
if(length(Specs[["w"]]) != length(Initial.Values))
Specs[["w"]] <- rep(Specs[["w"]],
len=length(Initial.Values))
if(any(Specs[["w"]] <= 0)) {
cat("\nw was misspecified, and is replaced with 1.\n",
file=LogFile, append=TRUE)
Specs[["w"]][which(Specs[["w"]] <= 0)] <- 1}
}
else if(Algorithm == "RWM") {
Algorithm <- "Random-Walk Metropolis"
if(missing(Specs) | is.null(Specs))
Specs <- list(B=list())
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("B") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
}
else if(Algorithm == "SAMWG") {
Algorithm <- "Sequential Adaptive Metropolis-within-Gibbs"
if(missing(Specs))
stop("The Specs argument is required.", file=LogFile,
append=TRUE)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("Dyn","Periodicity") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
if(!is.matrix(Specs[["Dyn"]]))
Specs[["Dyn"]] <- as.matrix(Specs[["Dyn"]])
}
else if(Algorithm == "SGLD") {
Algorithm <- "Stochastic Gradient Langevin Dynamics"
if(missing(Specs))
stop("The Specs argument is required.", file=LogFile,
append=TRUE)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("epsilon","file","Nr","Nc","size") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["Nr"]] <- abs(round(Specs[["Nr"]]))
Specs[["Nc"]] <- abs(round(Specs[["Nc"]]))
Specs[["size"]] <- abs(round(Specs[["size"]]))
if(Specs[["size"]] >= Specs[["Nr"]])
stop("size must be less than nr.")
if(any(is.na(Specs[["epsilon"]])))
Specs[["epsilon"]] <- 1 / Specs[["Nr"]]
if(length(Specs[["epsilon"]]) == 1)
Specs[["epsilon"]] <- rep(Specs[["epsilon"]],
Iterations)
if(length(Specs[["epsilon"]]) > Iterations)
Specs[["epsilon"]] <- Specs[["epsilon"]][1:Iterations]
}
else if(Algorithm == "Slice") {
Algorithm <- "Slice Sampler"
if(missing(Specs) | is.null(Specs))
Specs <- list(B=NULL, Bounds=c(-Inf,Inf), m=Inf,
Type="Continuous", w=1)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("B","Bounds","m","Type","w") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
if(is.null(Specs[["B"]])) {
B <- list()
B[[1]] <- 1:length(Initial.Values)
Bounds <- list()
Bounds[[1]] <- Specs[["Bounds"]]
m <- list()
m[[1]] <- Specs[["m"]]
Type <- list()
Type[[1]] <- Specs[["Type"]]
w <- list()
w[[1]] <- Specs[["w"]]
Specs[["B"]] <- B
Specs[["Bounds"]] <- Bounds
Specs[["m"]] <- m
Specs[["Type"]] <- Type
Specs[["w"]] <- w}
if(!is.list(Specs[["B"]]))
stop("B must be a list.", file=LogFile, append=TRUE)
if(!is.list(Specs[["Bounds"]])) {
Bounds <- list()
for (i in 1:length(Initial.Values))
Bounds[[i]] <- Specs[["Bounds"]]
Specs[["Bounds"]] <- Bounds}
if(!is.list(Specs[["m"]])) {
Specs[["m"]] <- abs(Specs[["m"]][1])
m <- list()
for (i in 1:length(Initial.Values))
m[[i]] <- Specs[["m"]]
Specs[["m"]] <- m}
if(!is.list(Specs[["Type"]])) {
Specs[["Type"]] <- Specs[["Type"]][1]
if(!Specs[["Type"]] %in% c("Continuous", "Nominal",
"Ordinal"))
Specs[["Type"]] <- "Continuous"
Type <- list()
for (i in 1:length(Initial.Values))
Type[[i]] <- Specs[["Type"]]
Specs[["Type"]] <- Type}
if(!is.list(Specs[["w"]])) {
Specs[["w"]] <- abs(Specs[["w"]][1])
w <- list()
for (i in 1:length(Initial.Values))
w[[i]] <- Specs[["w"]]
Specs[["w"]] <- w}
}
else if(Algorithm == "SMWG") {
Algorithm <- "Sequential Metropolis-within-Gibbs"
if(missing(Specs))
stop("The Specs argument is required.", file=LogFile,
append=TRUE)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("Dyn") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
if(!is.matrix(Specs[["Dyn"]]))
Specs[["Dyn"]] <- as.matrix(Specs[["Dyn"]])
}
else if(Algorithm == "THMC") {
Algorithm <- "Tempered Hamiltonian Monte Carlo"
if(missing(Specs))
stop("The Specs argument is required.", file=LogFile,
append=TRUE)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("epsilon","L","m", "Temperature") %in%
names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["epsilon"]] <- as.vector(abs(Specs[["epsilon"]]))
if(length(Specs[["epsilon"]]) != length(Initial.Values)) {
cat("\nLength of epsilon is incorrect.\n", file=LogFile,
append=TRUE)
Specs[["epsilon"]] <- rep(Specs[["epsilon"]][1],
length(Initial.Values))}
Specs[["L"]] <- abs(round(Specs[["L"]]))
if(Specs[["L"]] < 2) {
cat("\nL has been increased to its minimum: 2.\n",
file=LogFile, append=TRUE)
Specs[["L"]] <- 2}
if(is.null(Specs[["m"]]))
Specs[["m"]] <- diag(length(Initial.Values))
if(Specs[["Temperature"]] <= 0) {
cat("\nTemperature is incorrect, changed to 1.\n",
file=LogFile, append=TRUE)
Specs[["Temperature"]] <- 1}
}
else if(Algorithm == "twalk") {
Algorithm <- "t-walk"
if(missing(Specs) | is.null(Specs))
Specs=list(SIV=NULL, n1=4, at=6, aw=1.5)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("SIV","n1","at","aw") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
if(is.null(Specs[["SIV"]])) {
cat("\nGenerating SIV...\n", file=LogFile, append=TRUE)
if(!is.null(Data[["PGF"]]))
Specs[["SIV"]] <- GIV(Model, Data, PGF=TRUE)
else Specs[["SIV"]] <- GIV(Model, Data)}
if(!identical(length(Specs[["SIV"]]),
length(Initial.Values))) {
cat("\nGenerating SIV due to length mismatch.\n",
file=LogFile, append=TRUE)
if(!is.null(Data[["PGF"]]))
Specs[["SIV"]] <- GIV(Model, Data, PGF=TRUE)
else Specs[["SIV"]] <- GIV(Model, Data)}
Mo2 <- Model(Specs[["SIV"]], Data)
if(!is.finite(Mo2[["LP"]]))
stop("SIV results in a non-finite posterior.",
file=LogFile, append=TRUE)
if(!is.finite(Mo2[["Dev"]]))
stop("SIV results in a non-finite deviance.",
file=LogFile, append=TRUE)
Specs[["SIV"]] <- Mo2[["parm"]]
rm(Mo2)
if(Specs[["n1"]] < 1) {
cat("\nn1 must be at least 1. Changed to 4.\n",
file=LogFile, append=TRUE)
Specs[["n1"]] <- 4}
if(Specs[["at"]] <= 0) {
cat("\nat must be positive. Changed to 6.\n",
file=LogFile, append=TRUE)
Specs[["at"]] <- 6}
if(Specs[["aw"]] <= 0) {
cat("\naw must be positive. Changed to 1.5.\n",
file=LogFile, append=TRUE)
Specs[["aw"]] <- 1.5}
}
else if(Algorithm == "UESS") {
Algorithm = "Univariate Eigenvector Slice Sampler"
if(missing(Specs) | is.null(Specs))
Specs=list(A=Inf, B=NULL, m=100, n=0)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("A","B","m","n") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
Specs[["A"]] <- abs(round(Specs[["A"]]))
if(!is.null(Specs[["B"]])) {
if(is.null(Covar)) {
Covar <- list(NULL)
for (b in 1:length(Specs[["B"]])) {
Covar[[b]] <- diag(length(Specs[["B"]][[b]]))}}}
Specs[["m"]] <- abs(round(Specs[["m"]]))
Specs[["n"]] <- abs(round(Specs[["n"]]))
}
else if(Algorithm == "USAMWG") {
Algorithm <- "Updating Sequential Adaptive Metropolis-within-Gibbs"
if(missing(Specs))
stop("The Specs argument is required.", file=LogFile,
append=TRUE)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("Dyn","Periodicity","Fit","Begin") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
if(!is.matrix(Specs[["Dyn"]]))
Specs[["Dyn"]] <- as.matrix(Specs[["Dyn"]])
}
else if(Algorithm == "USMWG") {
Algorithm <- "Updating Sequential Metropolis-within-Gibbs"
if(missing(Specs))
stop("The Specs argument is required.", file=LogFile,
append=TRUE)
if(!is.list(Specs))
stop("The Specs argument is not a list.", file=LogFile,
append=TRUE)
if(!all(c("Dyn","Fit","Begin") %in% names(Specs)))
stop("The Specs argument is incorrect.", file=LogFile,
append=TRUE)
if(!is.matrix(Specs[["Dyn"]]))
Specs[["Dyn"]] <- as.matrix(Specs[["Dyn"]])
}
}
else {cat("Unknown algorithm has been changed to Metropolis-within-Gibbs.\n",
file=LogFile, append=TRUE)
Algorithm <- "Metropolis-within-Gibbs"
Specs <- NULL}
if(!is.null(Specs[["Adaptive"]])) {
Specs[["Adaptive"]] <- abs(Specs[["Adaptive"]])
if({Specs[["Adaptive"]] < 1} |
{Specs[["Adaptive"]] > Iterations})
Specs[["Adaptive"]] <- Iterations + 1}
if(!is.null(Specs[["B"]])) {
if(length(Specs[["B"]]) > 0) {
if(any(!is.finite(unlist(Specs[["B"]]))))
stop("Non-finite values in specification B.",
file=LogFile, append=TRUE)
if(!identical(as.vector(as.numeric(unlist(Specs[["B"]]))),
round(abs(as.vector(as.numeric(unlist(Specs[["B"]])))))))
stop("Specification B must have only positive integers.",
file=LogFile, append=TRUE)
if(!identical(length(unlist(Specs[["B"]])),
length(Initial.Values)))
stop("Non-integer values in specification B.",
file=LogFile, append=TRUE)}}
if(!is.null(Specs[["Periodicity"]])) {
Specs[["Periodicity"]] <- abs(Specs[["Periodicity"]])
if({Specs[["Periodicity"]] < 1} |
{Specs[["Periodicity"]] > Iterations})
Specs[["Periodicity"]] <- Iterations + 1}
Mo0 <- Model(Initial.Values, Data)
if(!is.list(Mo0))
stop("Model must return a list.", file=LogFile, append=TRUE)
if(length(Mo0) != 5)
stop("Model must return five components.", file=LogFile,
append=TRUE)
if(any(names(Mo0) != c("LP","Dev","Monitor","yhat","parm")))
stop("Name mismatch in returned list of Model function.",
file=LogFile, append=TRUE)
if(length(Mo0[["LP"]]) > 1)
stop("Multiple joint posteriors exist!", file=LogFile,
append=TRUE)
if(!identical(length(Mo0[["Monitor"]]), length(Data[["mon.names"]])))
stop("Length of mon.names differs from length of monitors.",
file=LogFile, append=TRUE)
as.character.function <- function(x, ... )
{
fname <- deparse(substitute(x))
f <- match.fun(x)
out <- c(sprintf('"%s" <- ', fname), capture.output(f))
if(grepl("^[<]", tail(out, 1))) out <- head(out, -1)
return(out)
}
acount <- length(grep("apply", as.character.function(Model)))
if(acount > 0) {
cat("Suggestion:", acount, "possible instance(s) of apply functions\n",
file=LogFile, append=TRUE)
cat(" were found in the Model specification. Iteration speed will\n",
file=LogFile, append=TRUE)
cat(" increase if apply functions are vectorized in R or coded\n",
file=LogFile, append=TRUE)
cat(" in a faster language such as C++ via the Rcpp package.\n",
file=LogFile, append=TRUE)}
acount <- length(grep("for", as.character.function(Model)))
if(acount > 0) {
cat("Suggestion:", acount, "possible instance(s) of for loops\n",
file=LogFile, append=TRUE)
cat(" were found in the Model specification. Iteration speed will\n",
file=LogFile, append=TRUE)
cat(" increase if for loops are vectorized in R or coded in a\n",
file=LogFile, append=TRUE)
cat(" faster language such as C++ via the Rcpp package.\n",
file=LogFile, append=TRUE)}
rm(acount)
if(!identical(Model(Mo0[["parm"]], Data)[["LP"]], Mo0[["LP"]])) {
cat("WARNING: LP differs when initial values are held constant.\n",
file=LogFile, append=TRUE)
cat(" Derivatives may be problematic if used.\n",
file=LogFile, append=TRUE)}
######################### Initial Settings #########################
Acceptance <- 0
if(!is.finite(Mo0[["LP"]])) {
cat("Generating initial values due to a non-finite posterior.\n",
file=LogFile, append=TRUE)
if(!is.null(Data[["PGF"]]))
Initial.Values <- GIV(Model, Data, PGF=TRUE)
else Initial.Values <- GIV(Model, Data)
Mo0 <- Model(Initial.Values, Data)
}
if(is.infinite(Mo0[["LP"]]))
stop("The posterior is infinite!", file=LogFile, append=TRUE)
if(is.nan(Mo0[["LP"]]))
stop("The posterior is not a number!", file=LogFile, append=TRUE)
if(is.na(Mo0[["Dev"]]))
stop("The deviance is a missing value!", file=LogFile,
append=TRUE)
if(is.infinite(Mo0[["Dev"]]))
stop("The deviance is infinite!", file=LogFile, append=TRUE)
if(is.nan(Mo0[["Dev"]]))
stop("The deviance is not a number!", file=LogFile, append=TRUE)
if(any(is.na(Mo0[["Monitor"]])))
stop("Monitored variable(s) have a missing value!",
file=LogFile, append=TRUE)
if(any(is.infinite(Mo0[["Monitor"]])))
stop("Monitored variable(s) have an infinite value!",
file=LogFile, append=TRUE)
if(any(is.nan(Mo0[["Monitor"]])))
stop("Monitored variable(s) include a value that is not a number!",
file=LogFile, append=TRUE)
if(Algorithm == "t-walk") {
Mo0 <- Model(Initial.Values, Data)
if(any(Mo0[["parm"]] == Specs[["SIV"]]))
stop("Initial.Values and SIV not unique after model update.",
file=LogFile, append=TRUE)}
###################### Laplace Approximation #######################
### Sample Size of Data
if(!is.null(Data[["n"]])) if(length(Data[["n"]]) == 1) N <- Data[["n"]]
if(!is.null(Data[["N"]])) if(length(Data[["N"]]) == 1) N <- Data[["N"]]
if(!is.null(Data[["y"]])) N <- nrow(matrix(Data[["y"]]))
if(!is.null(Data[["Y"]])) N <- nrow(matrix(Data[["Y"]]))
if(is.null(N))
stop("Sample size of Data not found in n, N, y, or Y.",
file=LogFile, append=TRUE)
if({all(Initial.Values == 0)} & {N >= 5*length(Initial.Values)}) {
cat("\nLaplace Approximation will be used on initial values.\n",
file=LogFile, append=TRUE)
LIV <- length(Initial.Values)
Fit.LA <- LaplaceApproximation(Model, Initial.Values, Data,
Method="SPG", CovEst="Identity", sir=FALSE)
Covar <- 2.381204 * 2.381204 / length(Initial.Values) *
Fit.LA$Covar
Initial.Values <- Fit.LA$Summary1[1:length(Initial.Values),1]
cat("The covariance matrix from Laplace Approximation has been scaled\n",
file=LogFile, append=TRUE)
cat("for Laplace's Demon, and the posterior modes are now the initial\n",
file=LogFile, append=TRUE)
cat("values for Laplace's Demon.\n\n", file=LogFile, append=TRUE)}
######################### Prepare for MCMC #########################
Mo0 <- Model(Initial.Values, Data)
Dev <- matrix(Mo0[["Dev"]], floor(Iterations/Thinning)+1, 1)
Mon <- matrix(Mo0[["Monitor"]], floor(Iterations/Thinning)+1,
length(Mo0[["Monitor"]]), byrow=TRUE)
LIV <- length(Initial.Values)
thinned <- matrix(Initial.Values, floor(Iterations/Thinning)+1,
length(Initial.Values), byrow=TRUE)
ScaleF <- 2.381204 * 2.381204 / LIV
if(Algorithm %in% c("Adaptive Metropolis",
"Adaptive-Mixture Metropolis",
"Delayed Rejection Adaptive Metropolis",
"Delayed Rejection Metropolis", "Interchain Adaptation",
"Metropolis-Coupled Markov Chain Monte Carlo",
"Random-Walk Metropolis")) {
### Algorithms that require both VarCov and tuning
if(is.list(Covar) & Algorithm != "Adaptive-Mixture Metropolis" &
Algorithm != "Random-Walk Metropolis") {
Covar <- NULL}
else if(is.matrix(Covar) & !is.list(Covar)) {
diag(Covar)[which(diag(Covar) < 1e-100)] <- 1e-100
tuning <- sqrt(diag(Covar))
VarCov <- Covar
}
else if(is.vector(Covar) & !is.list(Covar)) {
tuning <- abs(as.vector(Covar))
if(length(tuning) != LIV) tuning <- rep(ScaleF, LIV)
tuning[which(tuning < 1e-100)] <- 1e-100
VarCov <- matrix(0, LIV, LIV)
diag(VarCov) <- tuning
}
else if(is.null(Covar)) {
tuning <- rep(ScaleF, LIV)
VarCov <- matrix(0, LIV, LIV)
diag(VarCov) <- tuning
}
else if(is.list(Covar)) {
tuning <- Covar
for (i in 1:length(tuning)) {
tuning[[i]] <- sqrt(diag(tuning[[i]]))}
VarCov <- Covar}
if(is.matrix(VarCov) & !is.list(VarCov)) {
DiagCovar <- matrix(diag(VarCov), 1, LIV)}
else if(is.list(VarCov)) {
DiagCovar <- matrix(1, 1, LIV)
for (b in 1:length(Specs[["B"]])) {
DiagCovar[Specs[["B"]][[b]]] <- diag(VarCov[[b]])}}
}
else if(Algorithm %in% c("Adaptive Directional Metropolis-within-Gibbs",
"Automated Factor Slice Sampler",
"Elliptical Slice Sampler",
"Independence Metropolis",
"Metropolis-Adjusted Langevin Algorithm",
"Oblique Hyperrectangle Slice Sampler",
"Preconditioned Crank-Nicolson",
"Robust Adaptive Metropolis",
"Univariate Eigenvector Slice Sampler")) {
### Algorithms that require VarCov, but not tuning
if(is.list(Covar)) VarCov <- Covar
else if(is.matrix(Covar) & !is.list(Covar)) VarCov <- Covar
else if(is.vector(Covar) & !is.list(Covar)) {
VarCov <- matrix(0, LIV, LIV)
diag(VarCov) <- abs(as.vector(Covar))
diag(VarCov)[which(diag(VarCov) < 1e-100)] <- 1e-100
}
else if(is.null(Covar)) {
VarCov <- matrix(0, LIV, LIV)
diag(VarCov) <- rep(ScaleF, LIV)
}
else if(is.list(Covar)) VarCov <- Covar
if(is.matrix(VarCov) & !is.list(VarCov))
DiagCovar <- matrix(diag(VarCov), 1, LIV)
else if(is.list(VarCov)) {
DiagCovar <- matrix(1, 1, LIV)
for (b in 1:length(Specs[["B"]])) {
DiagCovar[Specs[["B"]][[b]]] <- diag(VarCov[[b]])}}
}
else if(Algorithm %in% c("Adaptive Griddy-Gibbs",
"Adaptive Metropolis-within-Gibbs",
"Gibbs Sampler",
"Metropolis-within-Gibbs",
"Multiple-Try Metropolis",
"Sequential Adaptive Metropolis-within-Gibbs",
"Sequential Metropolis-within-Gibbs",
"Updating Sequential Adaptive Metropolis-within-Gibbs",
"Updating Sequential Metropolis-within-Gibbs")) {
### Algorithms that do not require VarCov, but require tuning
if(is.list(Covar)) Covar <- NULL
else if(is.matrix(Covar) & !is.list(Covar)) {
tuning <- sqrt(diag(Covar))
tuning[which(tuning < 1e-100)] <- 1e-100
}
else if(is.vector(Covar) & !is.list(Covar)) {
tuning <- abs(as.vector(Covar))
if(length(tuning) != length(Initial.Values))
tuning <- rep(ScaleF, LIV)
tuning[which(tuning < 1e-100)] <- 1e-100
}
else if(is.null(Covar)) {
tuning <- rep(ScaleF, LIV)}
VarCov <- NULL
DiagCovar <- matrix(tuning, 1, LIV)
}
else {
### Algorithms that do not require VarCov or tuning
VarCov <- NULL
DiagCovar <- matrix(1, 1, LIV)
}
rm(Covar)
############################ Begin MCMC ############################
cat("Algorithm:", Algorithm, "\n", file=LogFile, append=TRUE)
cat("\nLaplace's Demon is beginning to update...\n", file=LogFile,
append=TRUE)
options(warn=2)
on.exit(options(warn=0))
if(Algorithm == "Adaptive Directional Metropolis-within-Gibbs") {
mcmc.out <- .mcmcadmg(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, VarCov, Debug, LogFile)}
else if(Algorithm == "Adaptive Griddy-Gibbs") {
mcmc.out <- .mcmcagg(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, tuning, Debug, LogFile)}
else if(Algorithm == "Adaptive Hamiltonian Monte Carlo") {
mcmc.out <- .mcmcahmc(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, Debug, LogFile)}
else if(Algorithm == "Affine-Invariant Ensemble Sampler") {
mcmc.out <- .mcmcaies(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, Debug, LogFile)}
else if(Algorithm == "Adaptive Metropolis") {
mcmc.out <- .mcmcam(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, tuning, VarCov, Debug, LogFile)}
else if(Algorithm == "Adaptive-Mixture Metropolis" & !is.list(VarCov)) {
mcmc.out <- .mcmcamm(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, tuning, VarCov, Debug, LogFile)}
else if(Algorithm == "Adaptive-Mixture Metropolis" & is.list(VarCov)) {
mcmc.out <- .mcmcamm.b(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, tuning, VarCov, Debug, LogFile)}
else if(Algorithm == "Adaptive Metropolis-within-Gibbs") {
mcmc.out <- .mcmcamwg(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, tuning, Debug, LogFile)}
else if(Algorithm == "Automated Factor Slice Sampler") {
mcmc.out <- .mcmcafss(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, VarCov, Debug, LogFile)}
else if(Algorithm == "Componentwise Hit-And-Run Metropolis") {
mcmc.out <- .mcmccharm(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, Debug, LogFile)}
else if(Algorithm == "Delayed Rejection Adaptive Metropolis") {
mcmc.out <- .mcmcdram(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, tuning, VarCov, Debug, LogFile)}
else if(Algorithm == "Delayed Rejection Metropolis") {
mcmc.out <- .mcmcdrm(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, tuning, VarCov, Debug, LogFile)}
else if(Algorithm == "Differential Evolution Markov Chain") {
mcmc.out <- .mcmcdemc(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, Debug, LogFile)}
else if(Algorithm == "Elliptical Slice Sampler") {
mcmc.out <- .mcmcess(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, VarCov, Debug, LogFile)}
else if(Algorithm == "Experimental") {
# mcmc.out <- .mcmcexperimental(Model, Data, Iterations, Status,
# Thinning, Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0,
# ScaleF, thinned, Debug, LogFile)}
stop("Experimental function not found.", file=LogFile,
append=TRUE)}
else if(Algorithm == "Gibbs Sampler") {
mcmc.out <- .mcmcgibbs(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, tuning, Debug, LogFile)}
else if(Algorithm == "Griddy-Gibbs") {
mcmc.out <- .mcmcgg(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, Debug, LogFile)}
else if(Algorithm == "Hamiltonian Monte Carlo") {
mcmc.out <- .mcmchmc(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, VarCov, Debug, LogFile)}
else if(Algorithm == "Hamiltonian Monte Carlo with Dual-Averaging") {
mcmc.out <- .mcmchmcda(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, Debug, LogFile)}
else if(Algorithm == "Hit-And-Run Metropolis") {
mcmc.out <- .mcmcharm(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, Debug, LogFile)}
else if(Algorithm == "Independence Metropolis") {
mcmc.out <- .mcmcim(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, VarCov, Debug, LogFile)}
else if(Algorithm == "Interchain Adaptation") {
mcmc.out <- .mcmcinca(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, tuning, VarCov, Debug, LogFile)}
else if(Algorithm == "Metropolis-Adjusted Langevin Algorithm") {
mcmc.out <- .mcmcmala(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, VarCov, Debug, LogFile)}
else if(Algorithm == "Metropolis-Coupled Markov Chain Monte Carlo") {
mcmc.out <- .mcmcmcmcmc(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, tuning, VarCov, Debug, LogFile)}
else if(Algorithm == "Multiple-Try Metropolis") {
mcmc.out <- .mcmcmtm(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, thinned,
tuning, Debug, LogFile)}
else if(Algorithm == "Metropolis-within-Gibbs") {
mcmc.out <- .mcmcmwg(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, tuning, Debug, LogFile)}
else if(Algorithm == "No-U-Turn Sampler") {
mcmc.out <- .mcmcnuts(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, Debug, LogFile)}
else if(Algorithm == "Oblique Hyperrectangle Slice Sampler") {
mcmc.out <- .mcmcohss(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, VarCov, Debug, LogFile)}
else if(Algorithm == "Preconditioned Crank-Nicolson") {
mcmc.out <- .mcmcpcn(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, VarCov, Debug, LogFile)}
else if(Algorithm == "Random Dive Metropolis-Hastings") {
mcmc.out <- .mcmcrdmh(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, Debug, LogFile)}
else if(Algorithm == "Random-Walk Metropolis") {
mcmc.out <- .mcmcrwm(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, tuning, VarCov, Debug, LogFile)}
else if(Algorithm == "Refractive Sampler") {
mcmc.out <- .mcmcrefractive(Model, Data, Iterations, Status,
Thinning, Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0,
thinned, Debug, LogFile)}
else if(Algorithm == "Reflective Slice Sampler") {
mcmc.out <- .mcmcrss(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, thinned,
Debug, LogFile)}
else if(Algorithm == "Reversible-Jump") {
mcmc.out <- .mcmcrj(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, Debug, LogFile)}
else if(Algorithm == "Robust Adaptive Metropolis") {
mcmc.out <- .mcmcram(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, VarCov, Debug, LogFile)}
else if(Algorithm == "Sequential Adaptive Metropolis-within-Gibbs") {
mcmc.out <- .mcmcsamwg(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, tuning, parm.names=Data[["parm.names"]], Debug,
LogFile)}
else if(Algorithm == "Sequential Metropolis-within-Gibbs") {
mcmc.out <- .mcmcsmwg(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, tuning, parm.names=Data[["parm.names"]], Debug,
LogFile)}
else if(Algorithm == "Stochastic Gradient Langevin Dynamics") {
mcmc.out <- .mcmcsgld(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, Debug, LogFile)}
else if(Algorithm == "Slice Sampler") {
mcmc.out <- .mcmcslice(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, Debug, LogFile)}
else if(Algorithm == "Tempered Hamiltonian Monte Carlo") {
mcmc.out <- .mcmcthmc(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, Debug, LogFile)}
else if(Algorithm == "t-walk") {
mcmc.out <- .mcmctwalk(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, Debug, LogFile)}
else if(Algorithm == "Univariate Eigenvector Slice Sampler") {
mcmc.out <- .mcmcuess(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, VarCov, Debug, LogFile)}
else if(Algorithm == "Updating Sequential Adaptive Metropolis-within-Gibbs") {
mcmc.out <- .mcmcusamwg(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, tuning, parm.names=Data[["parm.names"]], Debug,
LogFile)}
else if(Algorithm == "Updating Sequential Metropolis-within-Gibbs") {
mcmc.out <- .mcmcusmwg(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF,
thinned, tuning, parm.names=Data[["parm.names"]], Debug,
LogFile)}
else stop("The algorithm is unrecognized.", file=LogFile, append=TRUE)
options(warn=0)
######################### MCMC is Finished #########################
Acceptance <- mcmc.out$Acceptance
Dev <- mcmc.out$Dev
DiagCovar <- mcmc.out$DiagCovar
Mon <- mcmc.out$Mon
thinned <- mcmc.out$thinned
VarCov <- mcmc.out$VarCov
remove(mcmc.out)
rownames(DiagCovar) <- NULL
colnames(DiagCovar) <- Data[["parm.names"]]
thinned <- matrix(thinned[-1,], nrow(thinned)-1, ncol(thinned))
Dev <- matrix(Dev[-1,], nrow(Dev)-1, 1)
Mon <- matrix(Mon[-1,], nrow(Mon)-1, ncol(Mon))
if(is.matrix(VarCov) & !is.list(VarCov)) {
colnames(VarCov) <- rownames(VarCov) <- Data[["parm.names"]]}
else if(is.vector(VarCov) & !is.list(VarCov)) {
names(VarCov) <- Data[["parm.names"]]}
thinned.rows <- nrow(thinned)
### Warnings (After Updating)
if(any(Acceptance == 0))
cat("\nWARNING: All proposals were rejected.\n", file=LogFile,
append=TRUE)
### Real Values
thinned[which(!is.finite(thinned))] <- 0
Dev[which(!is.finite(Dev))] <- 0
Mon[which(!is.finite(Mon))] <- 0
### Assess Stationarity
cat("\nAssessing Stationarity\n", file=LogFile, append=TRUE)
if(thinned.rows %% 10 == 0) thinned2 <- thinned
if(thinned.rows %% 10 != 0) thinned2 <- thinned[1:(10*trunc(thinned.rows/10)),]
HD <- BMK.Diagnostic(thinned2, batches=10)
Ind <- 1 * (HD > 0.5)
BurnIn <- thinned.rows
batch.list <- seq(from=1, to=nrow(thinned2), by=floor(nrow(thinned2)/10))
for (i in 1:9) {
if(sum(Ind[,i:9]) == 0) {
BurnIn <- batch.list[i] - 1
break}}
Stat.at <- BurnIn + 1
rm(batch.list, HD, Ind, thinned2)
### Assess Thinning and ESS Size for all parameter samples
cat("Assessing Thinning and ESS\n", file=LogFile, append=TRUE)
acf.rows <- trunc(10*log10(thinned.rows))
acf.temp <- matrix(1, acf.rows, LIV)
ESS1 <- Rec.Thin <- rep(1, LIV)
for (j in 1:LIV) {
temp0 <- acf(thinned[,j], lag.max=acf.rows, plot=FALSE)
if(length(temp0$acf[-1,1,1]) == acf.rows)
acf.temp[,j] <- abs(temp0$acf[-1,1,1])
ESS1[j] <- ESS(thinned[,j])
Rec.Thin[j] <- which(acf.temp[,j] <= 0.1)[1]*Thinning}
Rec.Thin[which(is.na(Rec.Thin))] <- nrow(acf.temp)
ESS3 <- ESS(Mon)
### Posterior Summary Table 1: All Thinned Samples
cat("Creating Summaries\n", file=LogFile, append=TRUE)
Num.Mon <- ncol(Mon)
Summ1 <- matrix(NA, LIV, 7, dimnames=list(Data[["parm.names"]],
c("Mean","SD","MCSE","ESS","LB","Median","UB")))
Summ1[,1] <- colMeans(thinned)
Summ1[,2] <- sqrt(.colVars(thinned))
Summ1[,3] <- 0
Summ1[,4] <- ESS1
rm(ESS1)
Summ1[,5] <- apply(thinned, 2, quantile, c(0.025), na.rm=TRUE)
Summ1[,6] <- apply(thinned, 2, quantile, c(0.500), na.rm=TRUE)
Summ1[,7] <- apply(thinned, 2, quantile, c(0.975), na.rm=TRUE)
for (i in 1:ncol(thinned)) {
temp <- try(MCSE(thinned[,i]), silent=!Debug[["DB.MCSE"]])
if(!inherits(temp, "try-error")) Summ1[i,3] <- temp
else {
if(Debug[["DB.MCSE"]] == TRUE)
cat("MCSE of", Data[["parm.names"]][i],
"failed in Summary1\n", file=LogFile, append=TRUE)
Summ1[i,3] <- MCSE(thinned[,i], method="sample.variance")}}
Deviance <- rep(NA,7)
Deviance[1] <- mean(Dev)
Deviance[2] <- sd(as.vector(Dev))
temp <- try(MCSE(as.vector(Dev)), silent=!Debug[["DB.MCSE"]])
if(inherits(temp, "try-error")) {
if(Debug[["DB.MCSE"]] == TRUE)
cat("MCSE of deviance failed in Summary1\n", file=LogFile,
append=TRUE)
temp <- MCSE(as.vector(Dev), method="sample.variance")}
Deviance[3] <- temp
Deviance[4] <- ESS(Dev)
Deviance[5] <- as.numeric(quantile(Dev, probs=0.025, na.rm=TRUE))
Deviance[6] <- as.numeric(quantile(Dev, probs=0.500, na.rm=TRUE))
Deviance[7] <- as.numeric(quantile(Dev, probs=0.975, na.rm=TRUE))
Summ1 <- rbind(Summ1, Deviance)
for (j in 1:Num.Mon) {
Monitor <- rep(NA,7)
Monitor[1] <- mean(Mon[,j])
Monitor[2] <- sd(as.vector(Mon[,j]))
temp <- try(MCSE(as.vector(Mon[,j])), silent=!Debug[["DB.MCSE"]])
if(inherits(temp, "try-error")) {
if(Debug[["DB.MCSE"]] == TRUE)
cat("MCSE of", Data[["mon.names"]][j],
"failed in Summary1\n", file=LogFile, append=TRUE)
temp <- MCSE(Mon[,j], method="sample.variance")}
Monitor[3] <- temp
Monitor[4] <- ESS3[j]
Monitor[5] <- as.numeric(quantile(Mon[,j], probs=0.025,
na.rm=TRUE))
Monitor[6] <- as.numeric(quantile(Mon[,j], probs=0.500,
na.rm=TRUE))
Monitor[7] <- as.numeric(quantile(Mon[,j], probs=0.975,
na.rm=TRUE))
Summ1 <- rbind(Summ1, Monitor)
rownames(Summ1)[nrow(Summ1)] <- Data[["mon.names"]][j]}
rm(ESS3)
### Posterior Summary Table 2: Stationary Samples
Summ2 <- matrix(NA, LIV, 7, dimnames=list(Data[["parm.names"]],
c("Mean","SD","MCSE","ESS","LB","Median","UB")))
if(Stat.at < thinned.rows) {
ESS6 <- ESS(Mon[Stat.at:thinned.rows,])
thinned2 <- matrix(thinned[Stat.at:thinned.rows,],
thinned.rows-Stat.at+1, ncol(thinned))
Dev2 <- matrix(Dev[Stat.at:thinned.rows,],
thinned.rows-Stat.at+1, ncol(Dev))
Mon2 <- matrix(Mon[Stat.at:thinned.rows,],
thinned.rows-Stat.at+1, ncol(Mon))
Summ2[,1] <- colMeans(thinned2)
Summ2[,2] <- sqrt(.colVars(thinned2))
Summ2[,3] <- 0
Summ2[,4] <- ESS(thinned[Stat.at:thinned.rows,])
Summ2[,5] <- apply(thinned2, 2, quantile, c(0.025), na.rm=TRUE)
Summ2[,6] <- apply(thinned2, 2, quantile, c(0.500), na.rm=TRUE)
Summ2[,7] <- apply(thinned2, 2, quantile, c(0.975), na.rm=TRUE)
for (i in 1:ncol(thinned2)) {
temp <- try(MCSE(thinned2[,i]), silent=!Debug[["DB.MCSE"]])
if(!inherits(temp, "try-error")) Summ2[i,3] <- temp
else {
if(Debug[["DB.MCSE"]] == TRUE)
cat("MCSE of", Data[["parm.names"]][i],
"failed in Summary2\n", file=LogFile,
append=TRUE)
Summ2[i,3] <- MCSE(thinned2[,i],
method="sample.variance")}}
Deviance <- rep(NA,7)
Deviance[1] <- mean(Dev2)
Deviance[2] <- sd(as.vector(Dev2))
temp <- try(MCSE(as.vector(Dev2)), silent=!Debug[["DB.MCSE"]])
if(inherits(temp, "try-error")) {
if(Debug[["DB.MCSE"]] == TRUE)
cat("MCSE of deviance failed in Summary2\n",
file=LogFile, append=TRUE)
temp <- MCSE(as.vector(Dev2), method="sample.variance")}
Deviance[3] <- temp
Deviance[4] <- ESS(Dev[Stat.at:thinned.rows,])
Deviance[5] <- as.numeric(quantile(Dev2, probs=0.025,
na.rm=TRUE))
Deviance[6] <- as.numeric(quantile(Dev2, probs=0.500,
na.rm=TRUE))
Deviance[7] <- as.numeric(quantile(Dev2, probs=0.975,
na.rm=TRUE))
Summ2 <- rbind(Summ2, Deviance)
for (j in 1:Num.Mon) {
Monitor <- rep(NA,7)
Monitor[1] <- mean(Mon2[,j])
Monitor[2] <- sd(as.vector(Mon2[,j]))
temp <- try(MCSE(as.vector(Mon2[,j])),
silent=!Debug[["DB.MCSE"]])
if(inherits(temp, "try-error")) {
if(Debug[["DB.MCSE"]] == TRUE)
cat("MCSE of", Data[["mon.names"]][j],
"failed in Summary2\n", file=LogFile,
append=TRUE)
temp <- MCSE(Mon2[,j], method="sample.variance")}
Monitor[3] <- temp
Monitor[4] <- ESS6[j]
Monitor[5] <- as.numeric(quantile(Mon2[,j],
probs=0.025, na.rm=TRUE))
Monitor[6] <- as.numeric(quantile(Mon2[,j],
probs=0.500, na.rm=TRUE))
Monitor[7] <- as.numeric(quantile(Mon2[,j],
probs=0.975, na.rm=TRUE))
Summ2 <- rbind(Summ2, Monitor)
rownames(Summ2)[nrow(Summ2)] <- Data[["mon.names"]][j]}
rm(ESS6)
}
### Column names to samples
if(identical(ncol(Mon), length(Data[["mon.names"]])))
colnames(Mon) <- Data[["mon.names"]]
if(identical(ncol(thinned), length(Data[["parm.names"]]))) {
colnames(thinned) <- Data[["parm.names"]]}
### Logarithm of the Marginal Likelihood
LML <- list(LML=NA, VarCov=NA)
if(Algorithm %in% c("Adaptive Griddy-Gibbs",
"Affine-Invariant Ensemble Sampler",
"Automated Factor Slice Sampler",
"Componentwise Hit-And-Run Metropolis",
"Delayed Rejection Metropolis",
"Elliptical Slice Sampler",
"Gibbs Sampler",
"Griddy-Gibbs",
"Hamiltonian Monte Carlo",
"Hit-And-Run Metropolis",
"Independence Metropolis",
"Metropolis-Adjusted Langevin Algorithm",
"Metropolis-Coupled Markov Chain Monte Carlo",
"Metropolis-within-Gibbs",
"Multiple-Try Metropolis",
"No-U-Turn Sampler",
"Oblique Hyperrectangle Slice Sampler",
"Preconditioned Crank-Nicolson",
"Random Dive Metropolis-Hastings",
"Random-Walk Metropolis",
"Reflective Slice Sampler",
"Refractive Sampler",
"Reversible-Jump",
"Sequential Metropolis-within-Gibbs",
"Slice Sampler",
"Stochastic Gradient Langevin Dynamics",
"Tempered Hamiltonian Monte Carlo",
"t-walk",
"Univariate Eigenvector Slice Sampler") &
{Stat.at < thinned.rows}) {
cat("Estimating Log of the Marginal Likelihood\n", file=LogFile,
append=TRUE)
LML <- LML(theta=thinned2, LL=as.vector(Dev2)*(-1/2),
method="NSIS")}
time2 <- proc.time()
### Compile Output
cat("Creating Output\n", file=LogFile, append=TRUE)
LaplacesDemon.out <- list(Acceptance.Rate=round(Acceptance/Iterations,7),
Algorithm=Algorithm,
Call=LDcall,
Covar=VarCov,
CovarDHis=DiagCovar,
Deviance=as.vector(Dev),
DIC1=c(mean(as.vector(Dev)),
var(as.vector(Dev))/2,
mean(as.vector(Dev)) + var(as.vector(Dev))/2),
DIC2=if(Stat.at < thinned.rows) {
c(mean(as.vector(Dev2)),
var(as.vector(Dev2))/2,
mean(as.vector(Dev2)) +
var(as.vector(Dev2))/2)}
else rep(NA,3),
Initial.Values=Initial.Values,
Iterations=Iterations,
LML=LML[[1]],
Minutes=round(as.vector(time2[3] - time1[3]) / 60,2),
Model=Model,
Monitor=Mon,
Parameters=LIV,
Posterior1=thinned,
Posterior2=if(Stat.at < thinned.rows) {
thinned[Stat.at:thinned.rows,]}
else thinned[thinned.rows,],
Rec.BurnIn.Thinned=BurnIn,
Rec.BurnIn.UnThinned=BurnIn*Thinning,
Rec.Thinning=min(1000, max(Rec.Thin)),
Specs=Specs,
Status=Status,
Summary1=Summ1,
Summary2=Summ2,
Thinned.Samples=thinned.rows,
Thinning=Thinning)
class(LaplacesDemon.out) <- "demonoid"
cat("\nLaplace's Demon has finished.\n", file=LogFile, append=TRUE)
return(LaplacesDemon.out)
}
.mcmcadmg <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, VarCov,
Debug, LogFile)
{
n <- Specs[["n"]]
Periodicity <- Specs[["Periodicity"]]
Acceptance <- matrix(0, 1, LIV)
AccRate <- rep(0, LIV)
obs.sum <- matrix(Mo0[["parm"]]*n, LIV, 1)
obs.scatter <- tcrossprod(Mo0[["parm"]])*n
s <- svd(VarCov)
U <- diag(s$u)
tol <- LIV*max(s$d)*.Machine$double.eps
problem <- any(s$d <= tol)
DiagCovar <- matrix(diag(VarCov), floor(Iterations/Thinning)+1, LIV,
byrow=TRUE)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Random-Scan Componentwise Estimation
if(iter > 10) AccRate <- Acceptance / {iter - 1}
if(problem == FALSE) lambda <- U*rnorm(LIV, 0,
sqrt(0.01 + s$d*exp(2*s$d*(AccRate - 0.3))))
else lambda <- rnorm(LIV, 0, sqrt(diag(VarCov)))
for (j in sample.int(LIV)) {
### Propose new parameter values
prop <- Mo0[["parm"]]
prop[j] <- prop[j] + lambda[j]
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed for",
Data[["parm.names"]][j], ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
u <- log(runif(1)) < (Mo1[["LP"]] - Mo0[["LP"]])
if(u == TRUE) {
Mo0 <- Mo1
Acceptance[j] <- Acceptance[j] + 1}}}
### Update Sample and Scatter Sum
obs.sum <- obs.sum + Mo0[["parm"]]
obs.scatter <- obs.scatter + tcrossprod(Mo0[["parm"]])
### Adaptation
if(iter %% Periodicity == 0) {
VarCov <- obs.scatter/{n + iter} -
tcrossprod(obs.sum/{n + iter})
diag(VarCov) <- diag(VarCov) + 1e-05
s <- svd(VarCov)
U <- diag(s$u)
tol <- LIV*max(s$d)*.Machine$double.eps
problem <- any(s$d <= tol)}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]
DiagCovar[t.iter,] <- diag(VarCov)}
}
### Output
out <- list(Acceptance=mean(as.vector(Acceptance)),
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=VarCov)
return(out)
}
.mcmcafss <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, VarCov,
Debug, LogFile)
{
A <- Specs[["A"]]
Block <- Specs[["B"]]
m <- Specs[["m"]]
n <- Specs[["n"]]
w <- Specs[["w"]]
B <- length(Block)
targetRatio <- 0.5
if(B == 0) {
if(!is.symmetric.matrix(VarCov)) {
cat("\nAsymmetric Covar, correcting now...\n", file=LogFile,
append=TRUE)
VarCov <- as.symmetric.matrix(VarCov)}
if(!is.positive.definite(VarCov)) {
cat("\nNon-Positive-Definite Covar, correcting now...\n",
file=LogFile, append=TRUE)
VarCov <- as.positive.definite(VarCov)}
decomp.freq <- max(LIV * floor(Iterations / Thinning / 100), 10)
cat("\nEigendecomposition will occur every", decomp.freq,
"iterations.\n\n", file=LogFile, append=TRUE)
factors <- eigen(VarCov)$vectors
obs.sum <- matrix(Mo0[["parm"]]*n, LIV, 1)
obs.scatter <- tcrossprod(Mo0[["parm"]])*n
DiagCovar <- matrix(w, floor(Iterations/Thinning)+1, LIV,
byrow=TRUE)
nExpands <- nShrinks <- rep(0, LIV)
IterPerAdapt <- 1
nProposals <- 0
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Random-Scan Componentwise Estimation
for (j in sample.int(LIV)) {
y.slice <- Mo0[["LP"]] - rexp(1)
upper <- runif(1,0,w[j])
lower <- upper - w[j]
### Step Out
count <- 0
while (count <= m[j]) {
Mo1 <- try(Model(Mo0[["parm"]] +
lower*factors[,j], Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out the lower",
"bound failed for",
Data[["parm.names"]][j],
"in step", count+1, ".\n",
file=LogFile, append=TRUE)
lower <- lower + w[j]
break}
else if(!is.finite(Mo1[["LP"]])) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out the lower",
"bound for", Data[["parm.names"]][j],
"resulted in a non-finite LP",
"in step", count+1, ".\n",
file=LogFile, append=TRUE)
lower <- lower + w[j]
break}
nExpands[j] <- nExpands[j] + 1
if(Mo1[["LP"]] <= y.slice) break
lower <- lower - w[j]
count <- count + 1
}
count <- 0
while (count <= m[j]) {
Mo1 <- try(Model(Mo0[["parm"]] +
upper*factors[,j], Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out the upper",
"bound failed for",
Data[["parm.names"]][j],
"in step", count+1, ".\n",
file=LogFile, append=TRUE)
upper <- upper - w[j]
break}
else if(!is.finite(Mo1[["LP"]])) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out the upper",
"bound for", Data[["parm.names"]][j],
"resulted in a non-finite LP",
"in step", count+1, ".\n",
file=LogFile, append=TRUE)
upper <- upper - w[j]
break}
nExpands[j] <- nExpands[j] + 1
if(Mo1[["LP"]] <= y.slice) break
upper <- upper + w[j]
count <- count + 1
}
### Rejection Sampling
repeat {
lower <- -abs(min(lower, upper))
upper <- abs(max(lower, upper))
prop <- runif(1, lower, upper)
Mo1 <- try(Model(Mo0[["parm"]] + prop *
factors[,j], Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Rejection sampling",
"failed for",
Data[["parm.names"]][j], "\n",
file=LogFile, append=TRUE)
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Rejection sampling for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
Mo1 <- Mo0}
if(Mo1[["LP"]] >= y.slice) break
else if(abs(prop) < 1e-100) break
nShrinks[j] <- nShrinks[j] + 1
if(prop < 0) lower <- prop
else upper <- prop
}
Mo0 <- Mo1
}
nProposals <- nProposals + 1
obs.sum <- obs.sum + Mo0[["parm"]]
obs.scatter <- obs.scatter + tcrossprod(Mo0[["parm"]])
### Adaptation
if({iter <= A} & {A - iter >= decomp.freq}) {
### Tune Interval Widths
if(nProposals %% IterPerAdapt == 0) {
denom <- nExpands + nShrinks
for (j in 1:LIV) {
if(denom[j] > 0) {
ratio <- nExpands[j] / denom[j]
if(ratio == 0) ratio <- 1 / denom[j]
multiplier <- ratio / targetRatio
w[j] <- w[j]*multiplier
}
}
nExpands <- nShrinks <- rep(0,LIV)
nProposals <- 0
IterPerAdapt <- IterPerAdapt * 2}
### Tune Sampling Factors
if(iter %% decomp.freq == 0) {
VarCov <- obs.scatter/{n + iter} -
tcrossprod(obs.sum/{n + iter})
factors <- eigen(VarCov)$vectors
nExpands <- nShrinks <- rep(0,LIV)
IterPerAdapt <- 1
nProposals <- 0}
}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]
DiagCovar[t.iter,] <- w}
}
}
else {
if(!identical(length(VarCov), B))
stop("Number of components in Covar differs from number ",
"of blocks.", file=LogFile, append=TRUE)
factors <- obs.sum <- obs.scatter <- list()
decomp.freq <- rep(0, length(B))
for (b in 1:B) {
if(length(Block[[b]]) == 1)
stop("Single-parameter blocks are not allowed in AFSS.",
file=LogFile, append=TRUE)
if(!identical(length(Block[[b]]), length(diag(VarCov[[b]]))))
stop("Diagonal of Covar[[",b,"]] differs from block length.")
if(!is.symmetric.matrix(VarCov[[b]])) {
cat("\nAsymmetric Covar block, correcting now...\n",
file=LogFile, append=TRUE)
VarCov[[b]] <- as.symmetric.matrix(VarCov[[b]])}
if(!is.positive.definite(VarCov[[b]])) {
cat("\nNon-Positive-Definite Covar block,",
"correcting now...\n", file=LogFile, append=TRUE)
VarCov[[b]] <- as.positive.definite(VarCov[[b]])}
decomp.freq[b] <- max(length(Block[[b]]) *
floor(Iterations / Thinning / 100), 10)
factors[[b]] <-try(eigen(VarCov[[b]])$vectors,
silent=!Debug[["DB.eigen"]])
if(inherits(factors[[b]], "try-error")) {
if(Debug[["DB.eigen"]] == TRUE)
cat("\nWARNING: Eigendecomposition of covariance",
"matrix failed for block", b, ".\n",
file=LogFile, append=TRUE)
cat(" Eigendecomposition of an identity matrix",
"occurs instead.\n", file=LogFile, append=TRUE)
factors[[b]] <- diag(length(Block[[b]]))}
obs.sum[[b]] <- matrix(Mo0[["parm"]][Block[[b]]]*n,
length(Block[[b]]), 1)
obs.scatter[[b]] <- tcrossprod(Mo0[["parm"]][Block[[b]]])*n}
if(all(decomp.freq == decomp.freq[1]))
cat("\nEigendecomposition will occur every", decomp.freq[1],
"iterations.\n\n", file=LogFile, append=TRUE)
else cat("\nEigendecomposition frequency varies by block,",
"and will occur between\n",
min(decomp.freq), "and", max(decomp.freq),
"iterations.\n\n", file=LogFile, append=TRUE)
DiagCovar <- matrix(w, floor(Iterations/Thinning)+1, LIV,
byrow=TRUE)
nExpands <- nShrinks <- rep(0, LIV)
IterPerAdapt <- rep(1, B)
nProposals <- rep(0, B)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Blockwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Proceed by Block
for (b in 1:B) {
### Random-Scan Componentwise Estimation
for (j in sample(Block[[b]])) {
bj <- which(Block[[b]] == j)
y.slice <- Mo0[["LP"]] - rexp(1)
upper <- runif(1,0,w[j])
lower <- upper - w[j]
### Step Out
count <- 0
while (count <= m[j]) {
prop <- Mo0[["parm"]]
prop[Block[[b]]] <- prop[Block[[b]]] +
lower*factors[[b]][,bj]
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out the lower",
"bound failed for",
Data[["parm.names"]][j],
"in step", count+1, ".\n",
file=LogFile, append=TRUE)
lower <- lower + w[j]
break}
else if(!is.finite(Mo1[["LP"]])) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out the lower",
"bound for", Data[["parm.names"]][j],
"resulted in a non-finite LP",
"in step", count+1, ".\n",
file=LogFile, append=TRUE)
lower <- lower + w[j]
break}
nExpands[j] <- nExpands[j] + 1
if(Mo1[["LP"]] <= y.slice) break
lower <- lower - w[j]
count <- count + 1
}
count <- 0
while (count <= m[j]) {
prop <- Mo0[["parm"]]
prop[Block[[b]]] <- prop[Block[[b]]] +
upper*factors[[b]][,bj]
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out the upper",
"bound failed for",
Data[["parm.names"]][j],
"in step", count+1, ".\n",
file=LogFile, append=TRUE)
upper <- upper - w[j]
break}
else if(!is.finite(Mo1[["LP"]])) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out the upper",
"bound for", Data[["parm.names"]][j],
"resulted in a non-finite LP",
"in step", count+1, ".\n",
file=LogFile, append=TRUE)
upper <- upper - w[j]
break}
nExpands[j] <- nExpands[j] + 1
if(Mo1[["LP"]] <= y.slice) break
upper <- upper + w[j]
count <- count + 1
}
### Rejection Sampling
repeat {
prop <- Mo0[["parm"]]
lower <- -abs(min(lower, upper))
upper <- abs(max(lower, upper))
u <- runif(1, lower, upper)
prop[Block[[b]]] <- prop[Block[[b]]] +
u*factors[[b]][,bj]
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Rejection sampling",
"failed for",
Data[["parm.names"]][j], "\n",
file=LogFile, append=TRUE)
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Rejection sampling for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
Mo1 <- Mo0}
if(Mo1[["LP"]] >= y.slice) break
else if(abs(u) < 1e-100) break
nShrinks[j] <- nShrinks[j] + 1
if(u < 0) lower <- u
else upper <- u
}
Mo0 <- Mo1
}
nProposals[b] <- nProposals[b] + 1
obs.sum[[b]] <- obs.sum[[b]] + Mo0[["parm"]][Block[[b]]]
obs.scatter[[b]] <- obs.scatter[[b]] +
tcrossprod(Mo0[["parm"]][Block[[b]]])
### Adaptation
if({iter <= A} & {A - iter >= decomp.freq[b]}) {
### Tune Interval Widths
if(nProposals[b] %% IterPerAdapt[b] == 0) {
for (j in Block[[b]]) {
denom <- nExpands[j] + nShrinks[j]
if(denom > 0) {
ratio <- nExpands[j] / denom
if(ratio == 0) ratio <- 1 / denom
multiplier <- ratio / targetRatio
w[j] <- w[j]*multiplier
}
}
nExpands[Block[[b]]] <- rep(0,length(Block[[b]]))
nShrinks[Block[[b]]] <- rep(0,length(Block[[b]]))
nProposals[b] <- 0
IterPerAdapt[b] <- IterPerAdapt[b] * 2}
### Tune Sampling Factors
if(iter %% decomp.freq[b] == 0) {
VarCov[[b]] <- obs.scatter[[b]]/{n + iter} -
tcrossprod(obs.sum[[b]]/{n + iter})
factors[[b]] <- eigen(VarCov[[b]])$vectors
nExpands[Block[[b]]] <- rep(0,length(Block[[b]]))
nShrinks[Block[[b]]] <- rep(0,length(Block[[b]]))
IterPerAdapt[b] <- 1
nProposals[b] <- 0}
}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]
DiagCovar[t.iter,] <- w}
}
}
}
### Output
out <- list(Acceptance=Iterations,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=VarCov)
return(out)
}
.mcmcagg <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, tuning,
Debug, LogFile)
{
Grid <- Specs[["Grid"]]
dparm <- Specs[["dparm"]]
smax <- Specs[["smax"]]
CPUs <- Specs[["CPUs"]]
Packages <- Specs[["Packages"]]
Dyn.libs <- Specs[["Dyn.libs"]]
AGGCP <- function(Model, Data, j, Mo0, Grid, tuning, smax, Debug,
LogFile)
{
G <- length(Grid[[j]])
x <- Grid[[j]] * sqrt(2) * tuning[j]
LP.grid <- rep(0, G)
prop <- Mo0[["parm"]]
theta <- prop[j] + x
for (g in 1:G) {
prop[j] <- theta[g]
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating",
Data[["parm.names"]][j], "at",
round(prop[j],5), "failed.\n", file=LogFile,
append=TRUE)
Mo1 <- Mo0}
LP.grid[g] <- Mo1[["LP"]]
theta[g] <- Mo1[["parm"]][j]}
if(all(!is.finite(LP.grid))) LP.grid <- rep(0, G)
LP.grid[which(!is.finite(LP.grid))] <- min(LP.grid[which(is.finite(LP.grid))])
LP.grid <- exp(LP.grid - logadd(LP.grid))
LP.grid <- LP.grid / sum(LP.grid)
s <- spline(theta, LP.grid, n=1000)
s$y <- interval(s$y, 0, Inf, reflect=FALSE)
if(length(which(s$y > 0)) == 0)
prop[j] <- theta[which.max(LP.grid)[1]]
else prop[j] <- sample(s$x, 1, prob=s$y)
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating", Data[["parm.names"]][j],
"at", round(prop[j],5), "failed.\n",
file=LogFile, append=TRUE)
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating", Data[["parm.names"]][j],
"at", round(prop[j],5),
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
Mo1 <- Mo0
}
else tuning[j] <- min(max(sqrt(sum(LP.grid * x^2)),
1e-10), smax)
Mo0 <- Mo1
return(list(Mo0=Mo0, tuning=tuning))
}
AGGCPP <- function(Model, Data, j, Mo0, Grid, tuning, smax, Debug,
LogFile, cl)
{
G <- length(Grid[[j]])
x <- Grid[[j]] * sqrt(2) * tuning[j]
LP.grid <- rep(0, G)
LIV <- length(Mo0[["parm"]])
prop <- matrix(Mo0[["parm"]], G, LIV, byrow=TRUE)
prop[, j] <- prop[, j] + x
Mo1 <- parLapply(cl, 1:G,
function(x) Model(prop[x,], Data))
LP.grid <- as.vector(unlist(lapply(Mo1,
function(x) x[["LP"]])))
prop <- matrix(as.vector(unlist(lapply(Mo1,
function(x) x[["parm"]]))), G, LIV, byrow=TRUE)
theta <- prop[, j]
if(all(!is.finite(LP.grid))) LP.grid <- rep(0, G)
LP.grid[which(!is.finite(LP.grid))] <- min(LP.grid[which(is.finite(LP.grid))])
LP.grid <- exp(LP.grid - logadd(LP.grid))
LP.grid <- LP.grid / sum(LP.grid)
s <- spline(theta, LP.grid, n=1000)
s$y <- interval(s$y, 0, Inf, reflect=FALSE)
prop <- Mo0[["parm"]]
if(length(which(s$y > 0)) == 0)
prop[j] <- theta[which.max(LP.grid)[1]]
else prop[j] <- sample(s$x, 1, prob=s$y)
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating", Data[["parm.names"]][j],
"at", round(prop[j],5), "failed.\n",
file=LogFile, append=TRUE)
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating", Data[["parm.names"]][j],
"at", round(prop[j],5),
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
Mo1 <- Mo0
}
else tuning[j] <- min(max(sqrt(sum(LP.grid * x^2)),
1e-10), smax)
Mo0 <- Mo1
return(list(Mo0=Mo0, tuning=tuning))
}
Acceptance <- matrix(0, 1, LIV)
Grid.orig <- Grid
post <- matrix(Mo0[["parm"]], Iterations, LIV, byrow=TRUE)
if(CPUs == 1) {
for (iter in 1:Iterations) {
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
for (j in sample.int(LIV)) {
if(j %in% dparm)
Mo0 <- .mcmcggdp(Model, Data, j, Mo0, Grid, Debug,
LogFile)
else {
agg <- AGGCP(Model, Data, j, Mo0, Grid, tuning,
smax, Debug, LogFile)
Mo0 <- agg$Mo0
tuning[j] <- agg$tuning[j]}}
if(iter %% Thinning == 0) {
t.iter <- floor(iter/Thinning) + 1
thinned[t.iter, ] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter, ] <- Mo0[["Monitor"]]
DiagCovar <- rbind(DiagCovar, tuning)}}
}
else {
detectedCores <- detectCores()
cat("\n\nCPUs Detected:", detectedCores, "\n", file=LogFile,
append=TRUE)
if(CPUs > detectedCores) {
cat("\nOnly", detectedCores, "will be used.\n",
file=LogFile, append=TRUE)
CPUs <- detectedCores}
cat("\nLaplace's Demon is preparing environments for CPUs...",
file=LogFile, append=TRUE)
cat("\n##################################################\n",
file=LogFile, append=TRUE)
cl <- makeCluster(CPUs)
cat("\n##################################################\n",
file=LogFile, append=TRUE)
on.exit(stopCluster(cl))
varlist <- unique(c(ls(), ls(envir=.GlobalEnv),
ls(envir=parent.env(environment()))))
clusterExport(cl, varlist=varlist, envir=environment())
clusterSetRNGStream(cl)
wd <- getwd()
clusterExport(cl, varlist=c("Packages", "Dyn.libs", "wd"),
envir=environment())
for (iter in 1:Iterations) {
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
for (j in sample.int(LIV)) {
if(j %in% dparm)
Mo0 <- .mcmcggdpp(Model, Data, j, Mo0, Grid,
Debug, LogFile, cl)
else {
agg <- AGGCPP(Model, Data, j, Mo0, Grid,
tuning, smax, Debug, LogFile, cl)
Mo0 <- agg$Mo0
tuning[j] <- agg$tuning[j]}
}
if(iter %% Thinning == 0) {
t.iter <- floor(iter/Thinning) + 1
thinned[t.iter, ] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter, ] <- Mo0[["Monitor"]]
DiagCovar <- rbind(DiagCovar, tuning)}}}
DiagCovar <- DiagCovar[-1,]
out <- list(Acceptance=Iterations, Dev=Dev, DiagCovar=DiagCovar,
Mon=Mon, thinned=thinned, VarCov=.colVars(thinned))
return(out)
}
.mcmcahmc <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, Debug,
LogFile)
{
epsilon <- Specs[["epsilon"]]
L <- Specs[["L"]]
m <- Specs[["m"]]
invm <- as.inverse(m)
U <- chol(m)
Periodicity <- Specs[["Periodicity"]]
post <- matrix(Mo0[["parm"]], Iterations, LIV, byrow=TRUE)
DiagCovar <- matrix(epsilon, floor(Iterations/Periodicity), LIV,
byrow=TRUE)
gr0 <- partial(Model, post[1,], Data)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Propose new parameter values
prop <- post[iter,] <- Mo0[["parm"]]
momentum0 <- as.vector(rnorm(LIV) %*% U)
kinetic0 <- t(momentum0) %*% invm %*% momentum0 / 2
momentum1 <- momentum0 + (epsilon / 2) * gr0
Mo0.1 <- Mo0
for (l in 1:L) {
prop <- prop + as.vector(epsilon %*% invm) * momentum1
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed in leapfrog", l,
".\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0.1
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in leapfrog", l,
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0.1}
if(any(Mo0.1[["parm"]] == Mo1[["parm"]])) {
nomove <- which(Mo0.1[["parm"]] == Mo1[["parm"]])
momentum1[nomove] <- -momentum1[nomove]
prop[nomove] <- prop[nomove] + momentum1[nomove]
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed in leapfrog",
l, ".\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),
")",sep=""), "\n", file=LogFile,
append=TRUE)}
Mo1 <- Mo0.1
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in leapfrog",
l, "resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),
")", sep=""), "\n", file=LogFile,
append=TRUE)}
Mo1 <- Mo0.1}}
Mo0.1 <- Mo1
prop <- Mo1[["parm"]]
gr1 <- partial(Model, prop, Data)
if(l < L) momentum1 <- momentum1 + epsilon * gr1}
momentum1 <- momentum1 + (epsilon / 2) * gr1
momentum1 <- -momentum1
kinetic1 <- t(momentum1) %*% invm %*% momentum1 / 2
### Accept/Reject
H0 <- -Mo0[["LP"]] + kinetic0
H1 <- -Mo1[["LP"]] + kinetic1
delta <- H1 - H0
alpha <- min(1, exp(-delta))
if(!is.finite(alpha)) alpha <- 0
if(runif(1) < alpha) {
Mo0 <- Mo1
post[iter,] <- Mo1[["parm"]]
kinetic0 <- kinetic1
gr0 <- gr1
Acceptance <- Acceptance + 1
}
### Adaptation
if(iter %% Periodicity == 0) {
if(iter > 10) {
acceptances <- length(unique(post[(iter-9):iter,1]))
if(acceptances <= 1) epsilon <- epsilon * 0.8
else if(acceptances > 7) epsilon <- epsilon * 1.2}
a.iter <- floor(iter / Periodicity)
DiagCovar[a.iter,] <- epsilon}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=cov(thinned))
return(out)
}
.mcmcaies <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, Debug,
LogFile)
{
Nc <- Specs[["Nc"]]
Z <- Specs[["Z"]]
beta <- Specs[["beta"]]
CPUs <- Specs[["CPUs"]]
Packages <- Specs[["Packages"]]
Dyn.libs <- Specs[["Dyn.libs"]]
Mo0 <- list(Mo0=Mo0)
if(is.null(Z)) {
Z <- matrix(Mo0[[1]][["parm"]], Nc, LIV, byrow=TRUE)
for (i in 2:Nc) {
if(!is.null(Data[["PGF"]])) {
Z[i,] <- GIV(Model, Data, PGF=TRUE)
}
else Z[i,] <- GIV(Model, Data)
}
}
for (i in 2:Nc) Mo0[[i]] <- Model(Z[i,], Data)
if(CPUs == 1) {
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter, sep="", file=LogFile,
append=TRUE)
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[[1]][["parm"]]
Dev[t.iter] <- Mo0[[1]][["Dev"]]
Mon[t.iter,] <- Mo0[[1]][["Monitor"]]}
for (i in 1:Nc) {
### Propose new parameter values with stretch move
z <- 1 / sqrt(runif(1, 1 / beta, beta))
s <- sample(c(1:Nc)[-i], 1)
prop <- Mo0[[s]][["parm"]] +
z*(Mo0[[i]][["parm"]] - Mo0[[s]][["parm"]])
if(i == 1 & iter %% Status == 0)
cat(", Proposal: Multivariate, LP: ",
round(Mo0[[1]][["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed in walker",
i, ".\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),
")",sep=""), "\n", file=LogFile,
append=TRUE)}
Mo1 <- Mo0[[i]]
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in walker", i,
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),
")",sep=""), "\n", file=LogFile,
append=TRUE)}
Mo1 <- Mo0[[i]]}
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- (LIV-1)*log(z) + Mo1[["LP"]] -
Mo0[[i]][["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
else if(log.u < log.alpha) {
Mo0[[i]] <- Mo1
if(i == 1) {
Acceptance <- Acceptance + 1
if(iter %% Thinning == 0) {
thinned[t.iter,] <- Mo1[["parm"]]
Dev[t.iter] <- Mo1[["Dev"]]
Mon[t.iter,] <- Mo1[["Monitor"]]}
}
}
}
}
}
else {
detectedCores <- detectCores()
cat("\n\nCPUs Detected:", detectedCores, "\n", file=LogFile,
append=TRUE)
if(CPUs > detectedCores) {
cat("\nOnly", detectedCores, "will be used.\n", file=LogFile,
append=TRUE)
CPUs <- detectedCores}
cat("\nLaplace's Demon is preparing environments for CPUs...",
file=LogFile, append=TRUE)
cat("\n##################################################\n",
file=LogFile, append=TRUE)
cl <- makeCluster(CPUs)
cat("\n##################################################\n",
file=LogFile, append=TRUE)
on.exit(stopCluster(cl))
varlist <- unique(c(ls(), ls(envir=.GlobalEnv),
ls(envir=parent.env(environment()))))
clusterExport(cl, varlist=varlist, envir=environment())
clusterSetRNGStream(cl)
wd <- getwd()
clusterExport(cl, varlist=c("Packages", "Dyn.libs", "wd"),
envir=environment())
model.wrapper <- function(x, ...)
{
if(!is.null(Packages)) {
sapply(Packages,
function(x) library(x, character.only=TRUE,
quietly=TRUE))}
if(!is.null(Dyn.libs)) {
sapply(Dyn.libs,
function(x) dyn.load(paste(wd, x, sep = "/")))
on.exit(sapply(Dyn.libs,
function(x) dyn.unload(paste(wd, x, sep = "/"))))}
Model(prop[x,], Data)
}
prop <- Z
batch1 <- 1:(Nc/2)
batch2 <- batch1 + (Nc/2)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter, sep="", file=LogFile,
append=TRUE)
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[[1]][["parm"]]
Dev[t.iter] <- Mo0[[1]][["Dev"]]
Mon[t.iter,] <- Mo0[[1]][["Monitor"]]}
for (i in 1:Nc) {
### Propose new parameter values with stretch move
z <- 1 / sqrt(runif(1, 1 / beta, beta))
if(i <= (Nc/2)) s <- sample(batch2, 1)
else s <- sample(batch1, 1)
prop[i,] <- Mo0[[s]][["parm"]] +
z*(Mo0[[i]][["parm"]] - Mo0[[s]][["parm"]])
if(i == 1 & iter %% Status == 0)
cat(", Proposal: Multivariate\n", file=LogFile,
append=TRUE)}
### Log-Posterior of the proposed state
Mo1 <- clusterApply(cl, 1:Nc, model.wrapper,
Model, Data, prop)
for (i in 1:Nc) {
if(any(!is.finite(c(Mo1[[i]][["LP"]],
Mo1[[i]][["Dev"]], Mo1[[i]][["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in walker", i,
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[i,],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo1[[i]] <- Mo0[[i]]}
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- (LIV-1)*log(z) + Mo1[[i]][["LP"]] -
Mo0[[i]][["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
else if(log.u < log.alpha) {
Mo0[[i]] <- Mo1[[i]]
if(i == 1) {
Acceptance <- Acceptance + 1
if(iter %% Thinning == 0) {
thinned[t.iter,] <- Mo1[[i]][["parm"]]
Dev[t.iter] <- Mo1[[i]][["Dev"]]
Mon[t.iter,] <- Mo1[[i]][["Monitor"]]}
}
}
}
}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
.mcmcam <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, tuning,
VarCov, Debug, LogFile)
{
Adaptive <- Specs[["Adaptive"]]
Periodicity <- Specs[["Periodicity"]]
post <- matrix(Mo0[["parm"]], Iterations, LIV, byrow=TRUE)
Iden.Mat <- diag(LIV)
DiagCovar <- matrix(diag(VarCov), floor(Iterations/Periodicity), LIV,
byrow=TRUE)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter, sep="", file=LogFile, append=TRUE)
### Current Posterior
if(iter > 1) post[iter,] <- post[iter-1,]
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- post[iter,]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
### Propose new parameter values
MVNz <- try(rbind(rnorm(LIV)) %*% chol(VarCov),
silent=!Debug[["DB.chol"]])
if(!inherits(MVNz, "try-error") &
((Acceptance / iter) >= 0.05)) {
if(iter %% Status == 0)
cat(", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
MVNz <- as.vector(MVNz)
prop <- t(post[iter,] + t(MVNz))}
else {
if(iter %% Status == 0)
cat(", Proposal: Single-Component, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
if(Debug[["DB.chol"]] == TRUE)
cat("\nWARNING: Cholesky decomposition failed for",
"proposal in iteration", iter, ".\n",
file=LogFile, append=TRUE)
prop <- post[iter,]
j <- ceiling(runif(1,0,LIV))
prop[j] <- rnorm(1, post[iter,j], tuning[j])}
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",sep=""),
"\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal resulted in non-finite",
"value(s).\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",sep=""),
"\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0}
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
else if(log.u < log.alpha) {
Mo0 <- Mo1
post[iter,] <- Mo1[["parm"]]
Acceptance <- Acceptance + 1
if(iter %% Thinning == 0) {
thinned[t.iter,] <- Mo1[["parm"]]
Dev[t.iter] <- Mo1[["Dev"]]
Mon[t.iter,] <- Mo1[["Monitor"]]}}
### Shrinkage of Adaptive Proposal Variance
if({Adaptive < Iterations} & {Acceptance > 5} &
{Acceptance / iter < 0.05}) {
VarCov <- VarCov * {1 - {1 / Iterations}}
tuning <- tuning * {1 - {1 / Iterations}}}
### Adapt the Proposal Variance
if({iter >= Adaptive} & {iter %% Periodicity == 0}) {
### Covariance Matrix (Preferred if it works)
VarCov <- {ScaleF * cov(post[1:iter,])} +
{ScaleF * 1.0E-5 * Iden.Mat}
a.iter <- floor(iter / Periodicity)
DiagCovar[a.iter,] <- diag(VarCov)
### Univariate Standard Deviations
tuning <- sqrt(ScaleF * .colVars(post[1:iter,]) +
ScaleF * 1.0E-5)
}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=VarCov)
return(out)
}
.mcmcamm <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, tuning,
VarCov, Debug, LogFile)
{
Adaptive <- Specs[["Adaptive"]]
Block <- Specs[["B"]]
n <- Specs[["n"]]
Periodicity <- Specs[["Periodicity"]]
w <- Specs[["w"]]
obs.sum <- matrix(Mo0[["parm"]]*n, LIV, 1)
obs.scatter <- tcrossprod(Mo0[["parm"]])*n
if(all(upper.triangle(VarCov) == 0)) prop.R <- NULL
else prop.R <- ScaleF * chol(VarCov)
tuning <- sqrt(0.0001 * ScaleF)
DiagCovar <- matrix(diag(VarCov), floor(Iterations/Periodicity), LIV,
byrow=TRUE)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter, sep="", file=LogFile, append=TRUE)
### Propose new parameter values from a mixture
if(is.null(prop.R) || runif(1) < w) {
prop <- rnorm(LIV, Mo0[["parm"]], tuning)
if(iter %% Status == 0)
cat(", Proposal: Non-Adaptive Component, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)}
else {
prop <- Mo0[["parm"]] +
as.vector(rbind(rnorm(LIV)) %*% prop.R)
if(iter %% Status == 0)
cat(", Proposal: Adaptive Component, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)}
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",sep=""),
"\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal resulted in non-finite",
"value(s).\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",sep=""),
"\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
Acceptance <- Acceptance + 1}}
### Update Sample and Scatter Sum
obs.sum <- obs.sum + Mo0[["parm"]]
obs.scatter <- obs.scatter + tcrossprod(Mo0[["parm"]])
### Adapt the Proposal Variance
if({iter >= Adaptive} & {iter %% Periodicity == 0}) {
VarCov <- obs.scatter/{n + iter} -
tcrossprod(obs.sum/{n + iter})
diag(VarCov) <- diag(VarCov) + 1e-05
a.iter <- floor(iter / Periodicity)
DiagCovar[a.iter,] <- diag(VarCov)
prop.R <- try(ScaleF * chol(VarCov),
silent=!Debug[["DB.chol"]])
if(Debug[["DB.chol"]] == TRUE)
cat("\nWARNING: Cholesky decomposition failed for",
"proposal covariance in iteration", iter, ".\n",
file=LogFile, append=TRUE)
if(!is.matrix(prop.R)) prop.R <- NULL}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=VarCov)
return(out)
}
.mcmcamm.b <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, tuning,
VarCov, Debug, LogFile)
{
Adaptive <- Specs[["Adaptive"]]
Block <- Specs[["B"]]
n <- Specs[["n"]]
Periodicity <- Specs[["Periodicity"]]
w <- Specs[["w"]]
B <- length(Block)
if(!identical(length(VarCov), B))
stop("Number of components in Covar differs from ",
"number of blocks.", file=LogFile, append=TRUE)
obs.scatter <- obs.sum <- prop.R <- list()
for (b in 1:B) {
if(!identical(length(Block[[b]]), length(diag(VarCov[[b]]))))
stop("Diagonal of Covar[[",b,"]] differs from ",
"block length.", file=LogFile, append=TRUE)
obs.sum[[b]] <- matrix(Mo0[["parm"]][Block[[b]]]*n,
length(Block[[b]]), 1)
obs.scatter[[b]] <- matrix(tcrossprod(Mo0[["parm"]][Block[[b]]])*n,
length(Block[[b]]), length(Block[[b]]))
if(all(upper.triangle(VarCov[[b]]) == 0)) prop.R[[b]] <- NA
else prop.R[[b]] <- ScaleF * chol(VarCov[[b]])}
tuning <- sqrt(0.0001 * ScaleF)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter, sep="", file=LogFile, append=TRUE)
### Proceed by Block
for (b in 1:B) {
### Propose new parameter values from a mixture
prop <- Mo0[["parm"]]
if(any(is.na(prop.R[[b]])) || runif(1) < w) {
prop[Block[[b]]] <- rnorm(length(Block[[b]]),
Mo0[["parm"]][Block[[b]]], tuning)
if(b == 1 & iter %% Status == 0)
cat(", Proposal: Blockwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)}
else {
prop[Block[[b]]] <- Mo0[["parm"]][Block[[b]]] +
as.vector(rbind(rnorm(length(Block[[b]]))) %*%
prop.R[[b]])
if(b == 1 & iter %% Status == 0)
cat(", Proposal: Blockwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)}
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal resulted in non-finite",
"value(s).\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
Acceptance <- Acceptance +
length(Block[[b]]) / LIV}}
### Update Sample and Scatter Sum
obs.sum[[b]] <- obs.sum[[b]] + Mo0[["parm"]][Block[[b]]]
obs.scatter[[b]] <- obs.scatter[[b]] +
tcrossprod(Mo0[["parm"]][Block[[b]]])
### Adapt the Proposal Variance
if({iter >= Adaptive} & {iter %% Periodicity == 0}) {
VarCov[[b]] <- obs.scatter[[b]]/{n + iter} -
tcrossprod(obs.sum[[b]]/{n + iter})
diag(VarCov[[b]]) <- diag(VarCov[[b]]) + 1e-05
if(b == 1) DiagCovar <- rbind(DiagCovar, rep(0,LIV))
DiagCovar[nrow(DiagCovar),Block[[b]]] <- diag(VarCov[[b]])
prop.R[[b]] <- try(ScaleF * chol(VarCov[[b]]),
silent=!Debug[["DB.chol"]])
if(Debug[["DB.chol"]] == TRUE)
cat("\nWARNING: Cholesky decomposition failed for",
"proposal covariance in iteration", iter,
".\n", file=LogFile, append=TRUE)
if(!is.matrix(prop.R[[b]])) prop.R[[b]] <- NA}
}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=VarCov)
return(out)
}
.mcmcamwg <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, tuning,
Debug, LogFile)
{
Block <- Specs[["B"]]
n <- Specs[["n"]]
Periodicity <- Specs[["Periodicity"]]
Acceptance <- rep(0, LIV)
B <- length(Block)
DiagCovar <- matrix(tuning, floor(Iterations/Periodicity), LIV,
byrow=TRUE)
if(B == 0) {
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Random-Scan Componentwise Estimation
propdraw <- rnorm(LIV,0,tuning)
for (j in sample.int(LIV)) {
### Propose new parameter values
prop <- Mo0[["parm"]]
prop[j] <- prop[j] + propdraw[j]
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed for",
Data[["parm.names"]][j], ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
u <- log(runif(1)) < {Mo1[["LP"]] - Mo0[["LP"]]}
if(u == TRUE) {
Mo0 <- Mo1
Acceptance[j] <- Acceptance[j] + 1}}}
### Adapt the Proposal Variance
if(iter %% Periodicity == 0) {
size <- 1 / min(100, sqrt(n + iter))
Acceptance.Rate <- Acceptance / iter
log.tuning <- log(tuning)
tuning.num <- which(Acceptance.Rate > 0.44)
log.tuning[tuning.num] <- log.tuning[tuning.num] + size
tuning.num <- which(Acceptance.Rate <= 0.44)
log.tuning[tuning.num] <- log.tuning[tuning.num] - size
tuning <- exp(log.tuning)
a.iter <- floor(iter / Periodicity)
DiagCovar[a.iter,] <- tuning}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
}
else {
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Random-Scan Componentwise Estimation
propdraw <- rnorm(LIV,0,tuning)
for (b in 1:B) {
for (j in sample(Block[[b]])) {
### Propose new parameter values
prop <- Mo0[["parm"]]
prop[j] <- prop[j] + propdraw[j]
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed for",
Data[["parm.names"]][j], ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
u <- log(runif(1)) < {Mo1[["LP"]] -
Mo0[["LP"]]}
if(u == TRUE) {
Mo0 <- Mo1
Acceptance[j] <- Acceptance[j] + 1}}}}
### Adapt the Proposal Variance
if(iter %% Periodicity == 0) {
size <- 1 / min(100, sqrt(n + iter))
Acceptance.Rate <- Acceptance / iter
log.tuning <- log(tuning)
tuning.num <- which(Acceptance.Rate > 0.44)
log.tuning[tuning.num] <- log.tuning[tuning.num] + size
tuning.num <- which(Acceptance.Rate <= 0.44)
log.tuning[tuning.num] <- log.tuning[tuning.num] - size
tuning <- exp(log.tuning)
a.iter <- floor(iter / Periodicity)
DiagCovar[a.iter,] <- tuning}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
}
### Output
out <- list(Acceptance=mean(Acceptance),
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=tuning)
return(out)
}
.mcmccharm <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, Debug,
LogFile)
{
alpha.star <- Specs[["alpha.star"]]
if(is.na(alpha.star)) {
Acceptance <- matrix(0, 1, LIV)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Random-Scan Componentwise Estimation
theta <- rnorm(LIV)
theta <- theta / sqrt(sum(theta*theta))
lambda <- runif(1)
for (j in sample.int(LIV)) {
### Propose new parameter values
prop <- Mo0[["parm"]]
prop[j] <- prop[j] + lambda*theta[j]
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed for",
Data[["parm.names"]][j], ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
u <- log(runif(1)) < (Mo1[["LP"]] - Mo0[["LP"]])
if(u == TRUE) {
Mo0 <- Mo1
Acceptance[j] <- Acceptance[j] + 1}}}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=mean(as.vector(Acceptance)),
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
else {
tau <- rep(1, LIV)
Acceptance <- matrix(0, 1, LIV)
DiagCovar <- matrix(tau, nrow(thinned), LIV)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Random-Scan Componentwise Estimation
theta <- rnorm(LIV)
theta <- theta / sqrt(sum(theta*theta))
lambda <- runif(1)
for (j in sample.int(LIV)) {
### Propose new parameter values
prop <- Mo0[["parm"]]
prop[j] <- prop[j] + tau[j]*lambda*theta[j]
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed for",
Data[["parm.names"]][j], ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
u <- log(runif(1)) < (Mo1[["LP"]] - Mo0[["LP"]])
if(u == TRUE) {
Mo0 <- Mo1
Acceptance[j] <- Acceptance[j] + 1
tau[j] <- tau[j] + (tau[j] / (alpha.star *
(1 - alpha.star))) * (1 - alpha.star) / iter
}
else {
tau[j] <- abs(tau[j] - (tau[j] / (alpha.star *
(1 - alpha.star))) * alpha.star / iter)}}}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]
DiagCovar[t.iter,] <- tau}
}
### Output
out <- list(Acceptance=mean(as.vector(Acceptance)),
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
}
.mcmcdemc <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, Debug,
LogFile)
{
Nc <- Specs[["Nc"]]
Z <- Specs[["Z"]]
gamma <- Specs[["gamma"]]
w <- Specs[["w"]]
const <- 2.381204 / sqrt(2)
Mo0 <- list(Mo0=Mo0)
if(is.null(Z)) {
cat("\nGenerating Z...\n", file=LogFile, append=TRUE)
Z <- array(0, dim=c(floor(Iterations/Thinning)+1, LIV, Nc))
for (t in 1:dim(Z)[1]) {
for (i in 1:Nc) {
if(t == 1 & i == 1) {
Z[t,,i] <- Mo0[[1]][["parm"]]
}
else {
if(!is.null(Data[["PGF"]])) {
Z[t,,i] <- GIV(Model, Data, PGF=TRUE)}
else Z[t,,i] <- GIV(Model, Data)
}
}
}
}
else Z[1,,1] <- Mo0[[1]][["parm"]]
for (i in 2:Nc) Mo0[[i]] <- Model(Z[1,,i], Data)
for (iter in 1:Iterations) {
### Thinned Iteration
t.iter <- floor(iter / Thinning) + 1
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter, sep="", file=LogFile, append=TRUE)
### Save Thinned Samples
if(iter %% Thinning == 0) {
Z[t.iter,,] <- Z[t.iter-1,,]
thinned[t.iter,] <- Mo0[[1]][["parm"]]
Dev[t.iter] <- Mo0[[1]][["Dev"]]
Mon[t.iter,] <- Mo0[[1]][["Monitor"]]}
omega <- runif(1)
for (i in 1:Nc) {
r <- sample(dim(Z)[1], 2)
s <- sample(c(1:Nc)[-i], 2)
if(omega > w) {
### Parallel Direction Move
prop <- Mo0[[i]][["parm"]] +
gamma*(Z[r[1],,s[1]] - Z[r[2],,s[2]]) +
runif(LIV, -0.001, 0.001)^LIV
}
else {
### Snooker Move
si <- sample(c(1:Nc)[-i], 1)
prop <- Mo0[[i]][["parm"]] + const*
({Mo0[[si]][["parm"]] - Z[r[1],,s[1]]} -
{Mo0[[si]][["parm"]] - Z[r[2],,s[2]]})}
if(i == 1 & iter %% Status == 0)
cat(", Proposal: Multivariate, LP: ",
round(Mo0[[1]][["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed in chain", i,
".\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0[[i]]
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in chain", i,
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0[[i]]
}
else {
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[[i]][["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0[[i]] <- Mo1
Z[t.iter,,i] <- Mo1[["parm"]]
if(i == 1) {
Acceptance <- Acceptance + 1
if(iter %% Thinning == 0) {
thinned[t.iter,] <- Mo1[["parm"]]
Dev[t.iter] <- Mo1[["Dev"]]
Mon[t.iter,] <- Mo1[["Monitor"]]}
}
}
}
}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=thinned,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
.mcmcdram <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, tuning,
VarCov, Debug, LogFile)
{
Adaptive <- Specs[["Adaptive"]]
DR <- 1
Periodicity <- Specs[["Periodicity"]]
post <- matrix(Mo0[["parm"]], Iterations, LIV, byrow=TRUE)
Iden.Mat <- diag(LIV)
DiagCovar <- matrix(diag(VarCov), floor(Iterations/Periodicity), LIV,
byrow=TRUE)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter, sep="", file=LogFile, append=TRUE)
### Current Posterior
if(iter > 1) post[iter,] <- post[iter-1,]
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- post[iter,]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
### Propose new parameter values
MVNz <- try(rbind(rnorm(LIV)) %*% chol(VarCov),
silent=!Debug[["DB.chol"]])
if(!inherits(MVNz, "try-error") &
((Acceptance / iter) >= 0.05)) {
if(iter %% Status == 0)
cat(", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
MVNz <- as.vector(MVNz)
prop <- t(post[iter,] + t(MVNz))}
else {
if(iter %% Status == 0)
cat(", Proposal: Single-Component, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
if(Debug[["DB.chol"]] == TRUE)
cat("\nWARNING: Cholesky decomposition failed for",
"proposal 1 in iteration", iter, ".\n",
file=LogFile, append=TRUE)
prop <- post[iter,]
j <- ceiling(runif(1,0,LIV))
prop[j] <- rnorm(1, post[iter,j], tuning[j])}
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal 1 failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",sep=""),
"\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal 1 resulted in non-finite",
"value(s).\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",sep=""),
"\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0}
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
post[iter,] <- Mo1[["parm"]]
Acceptance <- Acceptance + 1
if(iter %% Thinning == 0) {
thinned[t.iter,] <- Mo1[["parm"]]
Dev[t.iter] <- Mo1[["Dev"]]
Mon[t.iter,] <- Mo1[["Monitor"]]}
}
### Delayed Rejection: Second Stage Proposals
else if(log.u >= log.alpha) {
MVNz <- try(rbind(rnorm(LIV)) %*%
chol(VarCov * 0.5), silent=!Debug[["DB.chol"]])
if(!inherits(MVNz, "try-error") &
((Acceptance / iter) >= 0.05)) {
MVNz <- as.vector(MVNz)
prop <- t(post[iter,] + t(MVNz))}
else {
if(Debug[["DB.chol"]] == TRUE)
cat("\nWARNING: Cholesky decomposition failed for",
"proposal 2 in iteration", iter, ".\n",
file=LogFile, append=TRUE)
prop <- post[iter,]
j <- ceiling(runif(1,0,LIV))
prop[j] <- rnorm(1, post[iter,j], tuning[j])}
### Log-Posterior of the proposed state
Mo2 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo2, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal 2 failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo2 <- Mo0
}
else if(any(!is.finite(c(Mo2[["LP"]], Mo2[["Dev"]],
Mo2[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal 2 resulted in non-finite",
"value(s).\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo2 <- Mo0
}
else {
### Accept/Reject
log.u <- log(runif(1))
options(warn=-1)
log.alpha.comp <- log(1 - exp(Mo1[["LP"]] -
Mo2[["LP"]]))
options(warn=0)
if(!is.finite(log.alpha.comp)) log.alpha.comp <- 0
log.alpha <- Mo2[["LP"]] + log.alpha.comp -
{Mo0[["LP"]] + log(1 - exp(Mo1[["LP"]] -
Mo0[["LP"]]))}
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo2
post[iter,] <- Mo2[["parm"]]
Acceptance <- Acceptance + 1
if(iter %% Thinning == 0) {
thinned[t.iter,] <- Mo1[["parm"]]
Dev[t.iter] <- Mo1[["Dev"]]
Mon[t.iter,] <- Mo1[["Monitor"]]}
}
}
}
### Shrinkage of Adaptive Proposal Variance
if({Adaptive < Iterations} & {Acceptance > 5} &
{Acceptance / iter < 0.05}) {
VarCov <- VarCov * {1 - {1 / Iterations}}
tuning <- tuning * {1 - {1 / Iterations}}}
### Adapt the Proposal Variance
if({iter >= Adaptive} & {iter %% Periodicity == 0}) {
### Covariance Matrix (Preferred if it works)
VarCov <- {ScaleF * cov(post[1:iter,])} +
{ScaleF * 1.0E-5 * Iden.Mat}
a.iter <- floor(iter / Periodicity)
DiagCovar[a.iter,] <- diag(VarCov)
### Univariate Standard Deviations
tuning <- sqrt(ScaleF * .colVars(post[1:iter,]) +
ScaleF * 1.0E-5)
}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=VarCov)
return(out)
}
.mcmcdrm <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, tuning,
VarCov, Debug, LogFile)
{
DR <- 1
U <- chol(VarCov)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter, sep="", file=LogFile, append=TRUE)
### Propose new parameter values
MVNz <- try(rbind(rnorm(LIV)) %*% U, silent=TRUE)
if(!inherits(MVNz, "try-error") &
((Acceptance / iter) >= 0.05)) {
if(iter %% Status == 0)
cat(", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
MVNz <- as.vector(MVNz)
prop <- t(as.vector(Mo0[["parm"]]) + t(MVNz))}
else {
if(iter %% Status == 0)
cat(", Proposal: Single-Component, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
prop <- Mo0[["parm"]]
j <- ceiling(runif(1,0,LIV))
prop[j] <- rnorm(1, Mo0[["parm"]][j], tuning[j])}
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal 1 failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",sep=""),
"\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal 1 resulted in non-finite",
"value(s).\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",sep=""),
"\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0}
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
Acceptance <- Acceptance + 1}
### Delayed Rejection: Second Stage Proposals
else if(log.u >= log.alpha) {
MVNz <- try(rbind(rnorm(LIV)) %*%
chol(VarCov * 0.5), silent=!Debug[["DB.chol"]])
if(!inherits(MVNz, "try-error") &
((Acceptance / iter) >= 0.05)) {
MVNz <- as.vector(MVNz)
prop <- t(as.vector(Mo0[["parm"]]) + t(MVNz))}
else {
if(Debug[["DB.chol"]] == TRUE)
cat("\nWARNING: Cholesky decomposition failed for",
"proposal 2 in iteration", iter, ".\n",
file=LogFile, append=TRUE)
prop <- Mo0[["parm"]]
j <- ceiling(runif(1,0,LIV))
prop[j] <- rnorm(1, Mo0[["parm"]][j], tuning[j])}
### Log-Posterior of the proposed state
Mo2 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo2, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal 2 failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo2 <- Mo0
}
else if(any(!is.finite(c(Mo2[["LP"]], Mo2[["Dev"]],
Mo2[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal 2 resulted in non-finite",
"value(s).\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""),"\n", file=LogFile, append=TRUE)}
Mo2 <- Mo0
}
else {
### Accept/Reject
log.u <- log(runif(1))
options(warn=-1)
log.alpha.comp <- log(1 - exp(Mo1[["LP"]] -
Mo2[["LP"]]))
options(warn=0)
if(!is.finite(log.alpha.comp)) log.alpha.comp <- 0
log.alpha <- Mo2[["LP"]] + log.alpha.comp -
{Mo0[["LP"]] + log(1 - exp(Mo1[["LP"]] -
Mo0[["LP"]]))}
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo2
Acceptance <- Acceptance + 1}}
}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=VarCov)
return(out)
}
.mcmcess <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, VarCov,
Debug, LogFile)
{
Block <- Specs[["B"]]
if(length(Block) == 0) {
if(!is.symmetric.matrix(VarCov)) {
cat("\nAsymmetric Covar, correcting now...\n", file=LogFile,
append=TRUE)
VarCov <- as.symmetric.matrix(VarCov)}
if(!is.positive.definite(VarCov)) {
cat("\nNon-Positive-Definite Covar, correcting now...\n",
file=LogFile, append=TRUE)
VarCov <- as.positive.definite(VarCov)}
nu <- rnorm(LIV, 0, diag(VarCov))
U <- chol(VarCov)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Propose new parameter values
nu <- as.vector(rbind(rnorm(LIV)) %*% U)
theta <- theta.max <- runif(1, 0, 2*pi)
theta.min <- theta - 2*pi
shrink <- TRUE
log.u <- log(runif(1))
### Rejection Sampling
while (shrink == TRUE) {
prop <- Mo0[["parm"]] * cos(theta) + nu*sin(theta)
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Rejection sampling failed.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Rejection sampling resulted",
"in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0}
### Accept/Reject
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
shrink <- FALSE
}
else {
if(theta < 0) theta.min <- theta
else theta.max <- theta
theta <- runif(1, theta.min, theta.max)}}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
}
else {
B <- length(Block)
if(!identical(length(VarCov), B))
stop("Number of components in Covar differs from ",
"number of blocks.", file=LogFile, append=TRUE)
nu <- rep(NA, LIV)
for (b in 1:B) {
if(!identical(length(Block[[b]]), length(diag(VarCov[[b]]))))
stop("Diagonal of Covar[[",b,"]] differs from ",
"block length.", file=LogFile, append=TRUE)
if(!is.symmetric.matrix(VarCov[[b]])) {
cat("\nAsymmetric Covar block, correcting now...\n",
file=LogFile, append=TRUE)
VarCov[[b]] <- as.symmetric.matrix(VarCov[[b]])}
if(!is.positive.definite(VarCov[[b]])) {
cat("\nNon-Positive-Definite Covar block,",
"correcting now...\n", file=LogFile, append=TRUE)
VarCov[[b]] <- as.positive.definite(VarCov[[b]])}
nu[Block[[b]]] <- rnorm(length(Block[[b]]), 0,
diag(VarCov[[b]]))}
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Blockwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Proceed by Block
for (b in 1:B) {
### Propose new parameter values
blen <- length(Block[[b]])
nu[Block[[b]]] <- as.vector(rbind(rnorm(blen)) %*%
chol(VarCov[[b]]))
theta <- theta.max <- runif(1, 0, 2*pi)
theta.min <- theta - 2*pi
shrink <- TRUE
log.u <- log(runif(1))
### Rejection Sampling
while (shrink == TRUE) {
prop <- Mo0[["parm"]]
prop[Block[[b]]] <- Mo0[["parm"]][Block[[b]]] *
cos(theta) + nu[Block[[b]]]*sin(theta)
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Rejection sampling failed.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Rejection sampling resulted",
"in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo1 <- Mo0}
### Accept/Reject
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
shrink <- FALSE
}
else {
if(theta < 0) theta.min <- theta
else theta.max <- theta
theta <- runif(1, theta.min, theta.max)}}
}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
}
### Output
out <- list(Acceptance=Iterations,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=cov(thinned))
return(out)
}
.mcmcgibbs <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, tuning,
Debug, LogFile)
{
FC <- Specs[["FC"]]
MWG <- Specs[["MWG"]]
if(is.null(MWG)) {
Acceptance <- Iterations
MWGlen <- 0}
else {
MWGlen <- length(MWG)
Acceptance <- matrix(0, 1, LIV)}
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Gibbs Sampling of Full Conditionals
prop <- try(FC(Mo0[["parm"]], Data), silent=!Debug[["DB.Model"]])
if(inherits(prop, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Gibbs proposal for full conditionals",
"failed.\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(Mo0[["parm"]], collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
prop <- Mo0[["parm"]]}
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Gibbs proposal failed.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",sep=""),
"\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0}
Mo0 <- Mo1
### Metropolis-within-Gibbs
if(MWGlen > 0) {
### Random-Scan Componentwise Estimation
for (j in sample(MWG)) {
### Propose new parameter values
prop <- Mo0[["parm"]]
prop[j] <- rnorm(1, prop[j], tuning[j])
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: MWG proposal failed for",
Data[["parm.names"]][j], ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: MWG proposal for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
u <- log(runif(1)) < (Mo1[["LP"]] - Mo0[["LP"]])
if(u == TRUE) {
Mo0 <- Mo1
Acceptance[j] <- Acceptance[j] + 1}}}
}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
if(MWGlen > 0) Acceptance <- mean(as.vector(Acceptance[,MWG]))
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=tuning)
return(out)
}
.mcmcgg <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, Debug,
LogFile)
{
Grid <- Specs[["Grid"]]
dparm <- Specs[["dparm"]]
CPUs <- Specs[["CPUs"]]
Packages <- Specs[["Packages"]]
Dyn.libs <- Specs[["Dyn.libs"]]
if(CPUs == 1) {
for (iter in 1:Iterations) {
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
for (j in sample.int(LIV)) {
if(j %in% dparm)
Mo0 <- .mcmcggdp(Model, Data, j, Mo0, Grid, Debug,
LogFile)
else Mo0 <- .mcmcggcp(Model, Data, j, Mo0, Grid, Debug,
LogFile)
}
if(iter %% Thinning == 0) {
t.iter <- floor(iter/Thinning) + 1
thinned[t.iter, ] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter, ] <- Mo0[["Monitor"]]}}
}
else {
detectedCores <- detectCores()
cat("\n\nCPUs Detected:", detectedCores, "\n", file=LogFile,
append=TRUE)
if(CPUs > detectedCores) {
cat("\nOnly", detectedCores, "will be used.\n",
file=LogFile, append=TRUE)
CPUs <- detectedCores}
cat("\nLaplace's Demon is preparing environments for CPUs...",
file=LogFile, append=TRUE)
cat("\n##################################################\n",
file=LogFile, append=TRUE)
cl <- makeCluster(CPUs)
cat("\n##################################################\n",
file=LogFile, append=TRUE)
on.exit(stopCluster(cl))
varlist <- unique(c(ls(), ls(envir=.GlobalEnv),
ls(envir=parent.env(environment()))))
clusterExport(cl, varlist=varlist, envir=environment())
clusterSetRNGStream(cl)
wd <- getwd()
clusterExport(cl, varlist=c("Packages", "Dyn.libs", "wd"),
envir=environment())
for (iter in 1:Iterations) {
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
for (j in sample.int(LIV)) {
if(j %in% dparm)
Mo0 <- .mcmcggdpp(Model, Data, j, Mo0, Grid,
Debug, LogFile, cl)
else Mo0 <- .mcmcggcpp(Model, Data, j, Mo0, Grid,
Debug, LogFile, cl)
}
if(iter %% Thinning == 0) {
t.iter <- floor(iter/Thinning) + 1
thinned[t.iter, ] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter, ] <- Mo0[["Monitor"]]}}}
out <- list(Acceptance=Iterations, Dev=Dev, DiagCovar=DiagCovar,
Mon=Mon, thinned=thinned, VarCov=.colVars(thinned))
return(out)
}
### Griddy-Gibbs Continuous Parameter (Non-Parallelized)
.mcmcggcp <- function(Model, Data, j, Mo0, Grid, Debug, LogFile)
{
G <- length(Grid[[j]])
LP.grid <- rep(0, G)
prop <- Mo0[["parm"]]
theta <- prop[j] + Grid[[j]]
for (g in 1:G) {
prop[j] <- theta[g]
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating",
Data[["parm.names"]][j], "at",
round(prop[j],5), "failed.\n", file=LogFile,
append=TRUE)
Mo1 <- Mo0}
LP.grid[g] <- Mo1[["LP"]]
theta[g] <- Mo1[["parm"]][j]}
if(all(!is.finite(LP.grid))) LP.grid <- rep(0, G)
LP.grid[which(!is.finite(LP.grid))] <- min(LP.grid[which(is.finite(LP.grid))])
LP.grid <- exp(LP.grid - logadd(LP.grid))
LP.grid <- LP.grid / sum(LP.grid)
s <- spline(theta, LP.grid, n=1000)
s$y <- interval(s$y, 0, Inf, reflect=FALSE)
if(length(which(s$y > 0)) == 0)
prop[j] <- theta[which.max(LP.grid)[1]]
else prop[j] <- sample(s$x, 1, prob=s$y)
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating", Data[["parm.names"]][j],
"at", round(prop[j],5), "failed.\n",
file=LogFile, append=TRUE)
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating", Data[["parm.names"]][j],
"at", round(prop[j],5),
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
Mo1 <- Mo0}
Mo0 <- Mo1
return(Mo0)
}
### Griddy-Gibbs Continuous Parameter (Parallelized)
.mcmcggcpp <- function(Model, Data, j, Mo0, Grid, Debug, LogFile, cl)
{
G <- length(Grid[[j]])
LP.grid <- rep(0, G)
LIV <- length(Mo0[["parm"]])
prop <- matrix(Mo0[["parm"]], G, LIV, byrow=TRUE)
prop[, j] <- prop[, j] + Grid[[j]]
Mo1 <- parLapply(cl, 1:G,
function(x) Model(prop[x,], Data))
LP.grid <- as.vector(unlist(lapply(Mo1,
function(x) x[["LP"]])))
prop <- matrix(as.vector(unlist(lapply(Mo1,
function(x) x[["parm"]]))), G, LIV, byrow=TRUE)
theta <- prop[, j]
if(all(!is.finite(LP.grid))) LP.grid <- rep(0, G)
LP.grid[which(!is.finite(LP.grid))] <- min(LP.grid[which(is.finite(LP.grid))])
LP.grid <- exp(LP.grid - logadd(LP.grid))
LP.grid <- LP.grid / sum(LP.grid)
s <- spline(theta, LP.grid, n=1000)
s$y <- interval(s$y, 0, Inf, reflect=FALSE)
prop <- Mo0[["parm"]]
if(length(which(s$y > 0)) == 0)
prop[j] <- theta[which.max(LP.grid)[1]]
else prop[j] <- sample(s$x, 1, prob=s$y)
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating", Data[["parm.names"]][j],
"at", round(prop[j],5), "failed.\n",
file=LogFile, append=TRUE)
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating", Data[["parm.names"]][j],
"at", round(prop[j],5),
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
Mo1 <- Mo0}
Mo0 <- Mo1
return(Mo0)
}
### Griddy-Gibbs Discrete Parameter (Non-Parallelized)
#where j is which parameter, and Grid are discrete values
.mcmcggdp <- function(Model, Data, j, Mo0, Grid, Debug, LogFile)
{
G <- length(Grid[[j]])
LP.grid <- rep(0, G)
prop <- Mo0[["parm"]]
theta <- Grid[[j]]
for (g in 1:G) {
prop[j] <- theta[g]
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating",
Data[["parm.names"]][j], "at",
round(prop[j],5), "failed.\n", file=LogFile,
append=TRUE)
Mo1 <- Mo0}
LP.grid[g] <- Mo1[["LP"]]
theta[g] <- Mo1[["parm"]][j]}
if(all(!is.finite(LP.grid))) LP.grid <- rep(0, G)
LP.grid[which(!is.finite(LP.grid))] <- min(LP.grid[which(is.finite(LP.grid))])
LP.grid <- exp(LP.grid - logadd(LP.grid))
LP.grid <- LP.grid / sum(LP.grid)
prop[j] <- sample(theta, 1, prob=LP.grid)
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating", Data[["parm.names"]][j],
"at", round(prop[j],5), "failed.\n",
file=LogFile, append=TRUE)
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating", Data[["parm.names"]][j],
"at", round(prop[j],5),
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
Mo1 <- Mo0}
Mo0 <- Mo1
return(Mo0)
}
### Griddy-Gibbs Discrete Parameter (Parallelized)
.mcmcggdpp <- function(Model, Data, j, Mo0, Grid, Debug, LogFile, cl)
{
G <- length(Grid[[j]])
LP.grid <- rep(0, G)
LIV <- length(Mo0[["parm"]])
prop <- matrix(Mo0[["parm"]], G, LIV, byrow=TRUE)
prop[, j] <- prop[, j] + Grid[[j]]
Mo1 <- parLapply(cl, 1:G,
function(x) Model(prop[x,], Data))
LP.grid <- as.vector(unlist(lapply(Mo1,
function(x) x[["LP"]])))
prop <- matrix(as.vector(unlist(lapply(Mo1,
function(x) x[["parm"]]))), G, LIV, byrow=TRUE)
theta <- prop[, j]
prop <- Mo0[["parm"]]
if(all(!is.finite(LP.grid))) LP.grid <- rep(0, G)
LP.grid[which(!is.finite(LP.grid))] <- min(LP.grid[which(is.finite(LP.grid))])
LP.grid <- exp(LP.grid - logadd(LP.grid))
LP.grid <- LP.grid / sum(LP.grid)
prop[j] <- sample(theta, 1, prob=LP.grid)
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating", Data[["parm.names"]][j],
"at", round(prop[j],5), "failed.\n",
file=LogFile, append=TRUE)
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating", Data[["parm.names"]][j],
"at", round(prop[j],5),
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
Mo1 <- Mo0}
Mo0 <- Mo1
return(Mo0)
}
.mcmcharm <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned,
Debug, LogFile)
{
alpha.star <- Specs[["alpha.star"]]
Block <- Specs[["B"]]
if(is.na(alpha.star) & {length(Block) == 0}) {
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter, sep="", file=LogFile,
append=TRUE)
### Propose new parameter values
theta <- rnorm(LIV)
d <- theta / sqrt(sum(theta*theta))
prop <- Mo0[["parm"]] + runif(1) * d
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal resulted in non-finite",
"value(s).\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
Acceptance <- Acceptance + 1}}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
else if(is.na(alpha.star) & {length(Block) > 0}) {
B <- length(Block)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter, sep="", file=LogFile,
append=TRUE)
### Proceed by Block
for (b in 1:B) {
### Propose new parameter values
theta <- rnorm(length(Block[[b]]))
d <- theta / sqrt(sum(theta*theta))
prop <- Mo0[["parm"]]
prop[Block[[b]]] <- prop[Block[[b]]] + runif(1) * d
if({b == 1} & {iter %% Status == 0})
cat(", Proposal: Blockwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal resulted in",
"non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
Acceptance <- Acceptance +
length(Block[[b]]) / LIV}}
}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
else if(length(Block) == 0) {
tau <- 1
DiagCovar <- matrix(tau, nrow(thinned), LIV)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter, sep="", file=LogFile,
append=TRUE)
### Propose new parameter values
theta <- rnorm(LIV)
d <- theta / sqrt(sum(theta*theta))
prop <- Mo0[["parm"]] + runif(1,0,tau) * d
if(iter %% Status == 0)
cat(", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal resulted in non-finite",
"value(s).\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
Acceptance <- Acceptance + 1
tau <- tau + (tau / (alpha.star *
(1 - alpha.star))) * (1 - alpha.star) / iter
}
else {
tau <- abs(tau - (tau / (alpha.star *
(1 - alpha.star))) * alpha.star / iter)}}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]
DiagCovar[t.iter,] <- tau}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
else {
B <- length(Block)
tau <- rep(1,B)
DiagCovar <- matrix(1, nrow(thinned), LIV)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter, sep="", file=LogFile,
append=TRUE)
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
### Proceed by Block
for (b in 1:B) {
### Propose new parameter values
theta <- rnorm(length(Block[[b]]))
d <- theta / sqrt(sum(theta*theta))
prop <- Mo0[["parm"]]
prop[Block[[b]]] <- prop[Block[[b]]] +
runif(1,0,tau[b]) * d
if({b == 1} & {iter %% Status == 0})
cat(", Proposal: Blockwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal resulted in",
"non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
Acceptance <- Acceptance +
length(Block[[b]]) / LIV
tau[b] <- tau[b] + (tau[b] / (alpha.star *
(1 - alpha.star))) * (1 - alpha.star) / iter
if(iter %% Thinning == 0) {
thinned[t.iter,] <- Mo1[["parm"]]
Dev[t.iter] <- Mo1[["Dev"]]
Mon[t.iter,] <- Mo1[["Monitor"]]
DiagCovar[t.iter, Block[[b]]] <- tau[b]}
}
else {
tau[b] <- abs(tau[b] - (tau[b] / (alpha.star *
(1 - alpha.star))) * alpha.star / iter)
if(iter %% Thinning == 0)
DiagCovar[t.iter, Block[[b]]] <- tau[b]}
}
}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
}
.mcmchmc <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, VarCov,
Debug, LogFile)
{
epsilon <- Specs[["epsilon"]]
L <- Specs[["L"]]
m <- Specs[["m"]]
invm <- as.inverse(m)
U <- chol(m)
gr0 <- partial(Model, Mo0[["parm"]], Data)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Propose new parameter values
prop <- Mo0[["parm"]]
momentum0 <- as.vector(rnorm(LIV) %*% U)
kinetic0 <- t(momentum0) %*% invm %*% momentum0 / 2
momentum1 <- momentum0 + (epsilon/2) * gr0
Mo0.1 <- Mo0
for (l in 1:L) {
prop <- prop + as.vector(epsilon %*% invm) * momentum1
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed in leapfrog", l,
".\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0.1
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in leapfrog", l,
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0.1}
if(any(Mo0.1[["parm"]] == Mo1[["parm"]])) {
nomove <- which(Mo0.1[["parm"]] == Mo1[["parm"]])
momentum1[nomove] <- -momentum1[nomove]
prop[nomove] <- prop[nomove] + momentum1[nomove]
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed in leapfrog",
l, ".\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0.1
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in leapfrog",
l, "resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0.1}}
Mo0.1 <- Mo1
prop <- Mo1[["parm"]]
gr1 <- partial(Model, prop, Data)
if(l < L) momentum1 <- momentum1 + epsilon * gr1}
momentum1 <- momentum1 + (epsilon/2) * gr1
momentum1 <- -momentum1
kinetic1 <- t(momentum1) %*% invm %*% momentum1 / 2
### Accept/Reject
H0 <- -Mo0[["LP"]] + kinetic0
H1 <- -Mo1[["LP"]] + kinetic1
delta <- H1 - H0
alpha <- min(1, exp(-delta))
if(!is.finite(alpha)) alpha <- 0
if(runif(1) < alpha) {
Mo0 <- Mo1
kinetic0 <- kinetic1
gr0 <- gr1
Acceptance <- Acceptance + 1}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=matrix(epsilon, 1, LIV),
Mon=Mon,
thinned=thinned,
VarCov=cov(thinned))
return(out)
}
.mcmchmcda <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, Debug,
LogFile)
{
A <- Specs[["A"]]
delta <- Specs[["delta"]]
epsilon <- Specs[["epsilon"]]
Lmax <- Specs[["Lmax"]]
lambda <- Specs[["lambda"]]
leapfrog <- function(theta, r, grad, epsilon, Model, Data, Mo0, Debug)
{
rprime <- r + 0.5 * epsilon * grad
thetaprime <- theta + epsilon * rprime
Mo1 <- try(Model(thetaprime, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed in leapfrog.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(thetaprime, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in leapfrog",
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(thetaprime, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0}
thetaprime <- Mo1[["parm"]]
gradprime <- partial(Model, thetaprime, Data)
rprime <- rprime + 0.5 * epsilon * gradprime
out <- list(thetaprime=thetaprime,
rprime=rprime,
gradprime=gradprime,
Mo1=Mo1)
return(out)
}
find.reasonable.epsilon <- function(theta0, grad0, Mo0, Model, Data,
LogFile)
{
cat("\nFinding a reasonable initial value for epsilon...",
file=LogFile, append=TRUE)
epsilon <- 0.001
r0 <- runif(length(theta0))
### Figure out which direction to move epsilon
leap <- leapfrog(theta0, r0, grad0, epsilon, Model, Data, Mo0,
Debug)
if(!is.finite(leap$Mo1[["LP"]]))
stop("LP is not finite in find.reasonable.epsilon().",
file=LogFile, append=TRUE)
acceptprob <- exp(leap$Mo1[["LP"]] - Mo0[["LP"]] - 0.5 *
(as.vector(leap$rprime %*% leap$rprime) -
as.vector(r0 %*% r0)))
a <- 2 * (acceptprob > 0.5) - 1
### Keep moving epsilon in that direction until acceptprob
### crosses 0.5
while (acceptprob^a > 2^(-a)) {
epsilon <- epsilon * 2^a
leap <- leapfrog(theta0, r0, grad0, epsilon, Model, Data,
Mo0, Debug)
if(!is.finite(leap$Mo1[["LP"]]))
stop("LP is not finite in find.reasonable.epsilon().",
file=LogFile, append=TRUE)
acceptprob <- exp(leap$Mo1[["LP"]] - Mo0[["LP"]] - 0.5 *
(as.vector(leap$rprime %*% leap$rprime) -
as.vector(r0 %*% r0)))
}
cat("\nepsilon: ", round(max(epsilon,0.001),5), "\n\n", sep="",
file=LogFile, append=TRUE)
return(epsilon)
}
gr0 <- partial(Model, Mo0[["parm"]], Data)
if(is.null(epsilon))
epsilon <- find.reasonable.epsilon(Mo0[["parm"]], gr0, Mo0, Model,
Data, LogFile)
DiagCovar[1,] <- epsilon
L <- max(1, round(lambda / epsilon))
L <- min(L, Lmax)
### Dual-Averaging Parameters
epsilonbar <- 1
gamma <- 0.05
Hbar <- 0
kappa <- 0.75
mu <- log(10*epsilon)
t0 <- 10
### Begin HMCDA
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Propose new parameter values
prop <- Mo0[["parm"]]
momentum1 <- momentum0 <- runif(LIV)
joint <- Mo0[["LP"]] - 0.5 * as.vector(momentum0 %*% momentum0)
L <- max(1, round(lambda / epsilon))
L <- min(L, Lmax)
gr1 <- gr0
Mo0.1 <- Mo0
### Leapfrog Function
for (l in 1:L) {
momentum1 <- momentum1 + 0.5 * epsilon * gr1
prop <- prop + epsilon * momentum1
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed in leapfrog", l,
".\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""),"\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0.1
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in leapfrog", l,
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0.1}
if(any(Mo0.1[["parm"]] == Mo1[["parm"]])) {
nomove <- which(Mo0.1[["parm"]] == Mo1[["parm"]])
momentum1[nomove] <- -momentum1[nomove]
prop[nomove] <- prop[nomove] + momentum1[nomove]
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed in leapfrog",
l, ".\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0.1
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in leapfrog", l,
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0.1}}
Mo0.1 <- Mo1
prop <- Mo1[["parm"]]
gr1 <- partial(Model, prop, Data)
momentum1 <- momentum1 + epsilon * gr1}
### Accept/Reject
alpha <- min(1,
exp(prop - 0.5 * as.vector(momentum1 %*% momentum1) - joint))
if(!is.finite(alpha)) alpha <- 0
if(runif(1) < alpha) {
Mo0 <- Mo1
gr0 <- gr1
Acceptance <- Acceptance + 1}
### Adaptation
if(iter > 1) {
eta <- 1 / (iter - 1 + t0)
Hbar <- (1 - eta) * Hbar + eta * (delta - alpha)
if(iter <= A) {
epsilon <- exp(mu - sqrt(iter-1)/gamma * Hbar)
eta <- (iter-1)^-kappa
epsilonbar <- exp((1 - eta) * log(epsilonbar) +
eta * log(epsilon))
DiagCovar <- rbind(DiagCovar, epsilon)}
else epsilon <- epsilonbar}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
.mcmcim <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, VarCov,
Debug, LogFile)
{
mu <- Specs[["mu"]]
VarCov <- as.positive.definite(as.symmetric.matrix(VarCov * 1.1))
Omega <- as.inverse(VarCov)
U <- chol(VarCov)
d <- eigen(VarCov, symmetric=TRUE)$values
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter, sep="", file=LogFile, append=TRUE)
### Propose new parameter values
MVNz <- try(rbind(rnorm(LIV)) %*% U, silent=TRUE)
if(!inherits(MVNz, "try-error")) {
if(iter %% Status == 0)
cat(", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
prop <- as.vector(mu) + as.vector(MVNz)}
else {prop <- as.vector(Mo0[["parm"]])}
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal resulted in non-finite",
"value(s).\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
### Importance Densities (dmvn)
ss <- prop - mu
z <- rowSums({ss %*% Omega} * ss)
d1 <- sum(-0.5 * (LIV * log(2*pi) + sum(log(d))) - (0.5*z))
ss <- Mo0[["parm"]] - mu
z <- rowSums({ss %*% Omega} * ss)
d0 <- sum(-0.5 * (LIV * log(2*pi) + sum(log(d))) - (0.5*z))
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]] + d1 - d0
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
Acceptance <- Acceptance + 1}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=cov(thinned))
return(out)
}
.mcmcinca <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, tuning,
VarCov, Debug, LogFile)
{
Adaptive <- Specs[["Adaptive"]]
Periodicity <- Specs[["Periodicity"]]
post <- matrix(Mo0[["parm"]], Iterations, LIV, byrow=TRUE)
Iden.Mat <- diag(LIV)
con <- get("con")
Chains <- get("Chains")
DiagCovar <- matrix(0, floor(Iterations/Periodicity), LIV)
### Store all posteriors
INCA_iter <- 1
INCA_first <- TRUE
tmpMean <- numeric(LIV)
tmpCov <- matrix(0, LIV, LIV)
tmpAlpha <- numeric(Periodicity)
lambda <- ScaleF
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter, sep="", file=LogFile, append=TRUE)
### Current Posterior
if(iter > 1) post[iter,] <- post[iter-1,]
### Propose new parameter values
MVNz <- try(rbind(rnorm(LIV)) %*% chol(VarCov),
silent=!Debug[["DB.chol"]])
if(!inherits(MVNz, "try-error") &
((Acceptance / iter) >= 0.05)) {
if(iter %% Status == 0)
cat(", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
prop <- as.vector(post[iter,]) + as.vector(MVNz)}
else {
if(iter %% Status == 0)
cat(", Proposal: Single-Component, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
if(Debug[["DB.chol"]] == TRUE)
cat("\nWARNING: Cholesky decomposition failed for",
"proposal in iteration", iter, ".\n",
file=LogFile, append=TRUE)
prop <- post[iter,]
j <- ceiling(runif(1,0,LIV))
prop[j] <- rnorm(1, post[iter,j], tuning[j])}
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal resulted in non-finite",
"value(s).\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
post[iter,] <- Mo1[["parm"]]
Acceptance <- Acceptance + 1}}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- post[iter,]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
### Save log.alpha
if({iter %% Periodicity} == 0)
tmpAlpha[Periodicity] <- min(1, exp(log.alpha))
else tmpAlpha[(iter %% Periodicity)] <- min(1, exp(log.alpha))
### Shrinkage of Adaptive Proposal Variance
if({iter < Adaptive} & {Acceptance > 5} &
{Acceptance / iter < 0.05}) {
VarCov <- VarCov * {1 - {1 / Iterations}}
tuning <- tuning * {1 - {1 / Iterations}}}
### Adapt the Proposal Variance
if({iter >= Adaptive} & {iter %% Periodicity == 0}) {
select_post <- cbind(post[(iter-Periodicity+1):iter,],
tmpAlpha)
### Ask for last posteriors to hpc_server
tmp <- unserialize(con)
### Send new posteriors matrix to hpc_server
serialize(select_post, con)
if(is.matrix(tmp) && INCA_first == FALSE) {
for (i in 1:nrow(select_post)) {
tmpMean <- tmpMean + 1/(INCA_iter+1) *
(select_post[i, 1:LIV]-tmpMean)
tmpCov <- (INCA_iter-1)/INCA_iter * tmpCov +
1/INCA_iter *
tcrossprod(select_post[i, 1:LIV]-tmpMean)
INCA_iter <- INCA_iter + 1}
for (i in 1:nrow(tmp)) {
tmpMean <- tmpMean + 1/(INCA_iter+1) *
(tmp[i, 1:LIV]-tmpMean)
tmpCov <- (INCA_iter-1)/INCA_iter * tmpCov +
1/INCA_iter *
tcrossprod(tmp[i, 1:LIV]-tmpMean)
INCA_iter <- INCA_iter + 1}
eta <- INCA_iter^-0.6
m1 <- median(select_post[, LIV+1])
m2 <- median(tmp[, LIV+1])
lambda <- exp(log(lambda) + eta * (m1 - 0.234))
lambda <- exp(log(lambda) + eta * (m2 - 0.234))}
if(INCA_first == TRUE) {
for (i in 1:iter) {
tmpMean <- tmpMean + 1/(INCA_iter+1) *
(post[i, ]-tmpMean)
tmpCov <- (INCA_iter-1)/INCA_iter * tmpCov +
1/INCA_iter *
tcrossprod(post[i, ] - tmpMean)
INCA_iter <- INCA_iter + 1}
INCA_first <- FALSE}
VarCov <- lambda * (tmpCov + 1e-9 * Iden.Mat)
a.iter <- floor(iter / Periodicity)
DiagCovar[a.iter,] <- diag(VarCov)
### Univariate Standard Deviations
tuning <- sqrt(diag(VarCov))}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=VarCov)
return(out)
}
.mcmcmala <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned,
VarCov, Debug, LogFile)
{
A <- Specs[["A"]]
alpha.star <- Specs[["alpha.star"]]
delta <- Specs[["delta"]]
gamma.const <- Specs[["gamma"]]
epsilon <- Specs[["epsilon"]]
Gamm <- as.positive.definite(VarCov)
mu <- Mo0[["parm"]]
sigma2 <- 1 / (LIV*LIV)
DiagCovar <- matrix(diag(Gamm), nrow(thinned), LIV)
Iden <- diag(LIV)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Propose new parameter values
gr <- partial(Model, Mo0[["parm"]], Data)
Dx <- {delta/max(delta, abs(gr))}*gr
gamm <- min(gamma.const/iter, 1)
Lambda <- Gamm + epsilon[2]*Iden
U <- try(chol(sigma2*Lambda), silent=!Debug[["DB.chol"]])
if(inherits(U, "try-error")) {
if(Debug[["DB.chol"]] == TRUE)
cat("\nWARNING: Cholesky decomposition failed for",
"proposal in iteration", iter, ".\n",
file=LogFile, append=TRUE)
U <- chol(as.positive.definite(sigma2*Lambda))}
prop <- as.vector((Mo0[["parm"]] +
{sigma2/2}*as.vector(Lambda %*% Dx)*Dx) +
rbind(rnorm(LIV)) %*% U)
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal resulted in non-finite",
"value(s).\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
Acceptance <- Acceptance + 1}}
### Adapt Gamma (first, since it uses mu[t] not [t+1])
xmu <- Mo0[["parm"]] - mu
Gamm.prop <- Gamm + gamm*{xmu %*% t(xmu) - Gamm}
norm.Gamm <- norm(Gamm.prop, type="F")
if(norm.Gamm <= A) Gamm <- Gamm.prop
else if(!is.finite(norm.Gamm)) Gamm <- sigma2*Iden
else Gamm <- {A/norm.Gamm}*Gamm.prop
### Adapt mu
mu.prop <- mu + gamm*(Mo0[["parm"]] - mu)
norm.mu <- sqrt(sum(mu.prop*mu.prop))
if(norm.mu <= A) mu <- mu.prop
else mu <- {A/norm.mu}*mu.prop
### Adapt sigma
sigma2 <- interval(sqrt(sigma2) +
gamm*(min(exp(log.alpha),1) - alpha.star),
epsilon[1], A, reflect=FALSE)^2
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]
DiagCovar[t.iter,] <- diag(Lambda)}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=Lambda)
return(out)
}
.mcmcmcmcmc <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, tuning,
VarCov, Debug, LogFile)
{
lambda <- Specs[["lambda"]]
CPUs <- Specs[["CPUs"]]
Packages <- Specs[["Packages"]]
Dyn.libs <- Specs[["Dyn.libs"]]
detectedCores <- detectCores()
cat("\n\nCPUs Detected:", detectedCores, "\n", file=LogFile,
append=TRUE)
if(CPUs > detectedCores) {
cat("\nOnly", detectedCores, "will be used.\n",
file=LogFile, append=TRUE)
CPUs <- detectedCores}
cat("\nLaplace's Demon is preparing environments for CPUs...",
file=LogFile, append=TRUE)
cat("\n##################################################\n",
file=LogFile, append=TRUE)
cl <- makeCluster(CPUs)
cat("\n##################################################\n",
file=LogFile, append=TRUE)
on.exit(stopCluster(cl))
varlist <- unique(c(ls(), ls(envir=.GlobalEnv),
ls(envir=parent.env(environment()))))
clusterExport(cl, varlist=varlist, envir=environment())
clusterSetRNGStream(cl)
wd <- getwd()
clusterExport(cl, varlist=c("Packages", "Dyn.libs", "wd"),
envir=environment())
if(length(lambda) == 1) Temperature <- 1/(1 + lambda*(c(1:CPUs) - 1))
else if(length(lambda) == LIV) Temperature <- lambda
else Temperature <- 1/(1 + lambda[1]*(c(1:CPUs) - 1))
coolest <- which.max(Temperature)[1]
temp <- Mo0
Mo0 <- list()
for (i in 1:CPUs) Mo0[[i]] <- temp
prop <- matrix(Mo0[[1]][["parm"]], CPUs, LIV, byrow=TRUE)
Acceptance.swap <- 0
U <- chol(VarCov)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[[coolest]][["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[[coolest]][["parm"]]
Dev[t.iter] <- Mo0[[coolest]][["Dev"]]
Mon[t.iter,] <- Mo0[[coolest]][["Monitor"]]}
### Propose new parameter values
for (i in 1:CPUs)
prop[i,] <- Mo0[[i]][["parm"]] + rbind(rnorm(LIV)) %*% U
### Log-Posterior of the proposed state
Mo1 <- parLapply(cl, 1:CPUs, function(x)
try(Model(prop[x,], Data), silent=!Debug[["DB.Model"]]))
for (i in 1:CPUs) {
if(inherits(Mo1[[i]], "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed in chain", i,
".\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[i,], collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1[[i]] <- Mo0[[i]]
}
else if(any(!is.finite(c(Mo1[[i]][["LP"]], Mo1[[i]][["Dev"]],
Mo1[[i]][["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in chain", i,
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[i,], collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1[[i]] <- Mo0[[i]]
}
}
### Accept/Reject
for (i in 1:CPUs) {
log.u <- log(runif(1))
log.alpha <- (Mo1[[i]][["LP"]] - Mo0[[i]][["LP"]]) /
Temperature[i]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0[[i]] <- Mo1[[i]]
if(i == coolest) {
Acceptance <- Acceptance + 1
if(iter %% Thinning == 0) {
thinned[t.iter,] <- Mo1[[i]][["parm"]]
Dev[t.iter] <- Mo1[[i]][["Dev"]]
Mon[t.iter,] <- Mo1[[i]][["Monitor"]]}}}}
### Swap
swap <- sample.int(CPUs, 2)
log.u <- log(runif(1))
log.alpha <- {(Mo0[[swap[1]]][["LP"]] - Mo0[[swap[2]]][["LP"]]) /
Temperature[swap[2]]} +
{(Mo0[[swap[2]]][["LP"]] - Mo0[[swap[1]]][["LP"]]) /
Temperature[swap[1]]}
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Acceptance.swap <- Acceptance.swap + 1
temp <- Mo0[[swap[2]]]
Mo0[[swap[2]]] <- Mo0[[swap[1]]]
Mo0[[swap[1]]] <- temp
if({swap[1] == coolest} & {iter %% Thinning == 0}) {
thinned[t.iter,] <- Mo0[[swap[1]]][["parm"]]
Dev[t.iter] <- Mo0[[swap[1]]][["Dev"]]
Mon[t.iter,] <- Mo0[[swap[1]]][["Monitor"]]}}
}
cat("\nSwap Acceptance Rate:",
round(Acceptance.swap / Iterations, 5), "\n", file=LogFile,
append=TRUE)
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=VarCov)
return(out)
}
.mcmcmtm <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, thinned, tuning, Debug,
LogFile)
{
K <- Specs[["K"]]
CPUs <- Specs[["CPUs"]]
Packages <- Specs[["Packages"]]
Dyn.libs <- Specs[["Dyn.libs"]]
if(CPUs > 1) {
detectedCores <- detectCores()
cat("\n\nCPUs Detected:", detectedCores, "\n", file=LogFile,
append=TRUE)
if(CPUs > detectedCores) {
cat("\nOnly", detectedCores, "will be used.\n",
file=LogFile, append=TRUE)
CPUs <- detectedCores}
cat("\nLaplace's Demon is preparing environments for CPUs...",
file=LogFile, append=TRUE)
cat("\n##################################################\n",
file=LogFile, append=TRUE)
cl <- makeCluster(CPUs)
cat("\n##################################################\n",
file=LogFile, append=TRUE)
on.exit(stopCluster(cl))
varlist <- unique(c(ls(), ls(envir=.GlobalEnv),
ls(envir=parent.env(environment()))))
clusterExport(cl, varlist=varlist, envir=environment())
clusterSetRNGStream(cl)
wd <- getwd()
clusterExport(cl, varlist=c("Packages", "Dyn.libs", "wd"),
envir=environment())}
Acceptance <- matrix(0, 1, LIV)
Mo1 <- list()
for (k in 1:K) Mo1[[k]] <- Mo0
LW <- LP <- rep(0, K)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Random-Scan Componentwise Estimation
for (j in sample.int(LIV)) {
### Propose new parameter values
prop1 <- matrix(Mo0[["parm"]], K, LIV, byrow=TRUE)
prop1[,j] <- rnorm(K, prop1[,j], tuning[j])
### Log-Posterior of the proposed states
if(CPUs == 1) {
### Non-parallel
for (k in 1:K) {
Mo1[[k]] <- try(Model(prop1[k,], Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1[[k]], "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal ", k,
"failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop1[k,j],5),
file=LogFile, append=TRUE)}
Mo1[[k]] <- Mo0
}
else if(any(!is.finite(c(Mo1[[k]][["LP"]],
Mo1[[k]][["Dev"]],
Mo1[[k]][["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal ", k,
"resulted in non-finite",
"value(s).\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop1[k,j],5),
file=LogFile, append=TRUE)}
Mo1[[k]] <- Mo0}
LP[k] <- LW[k] <- Mo1[[k]][["LP"]]
prop1[k,] <- Mo1[[k]][["parm"]]}
}
else {
### Parallel
Mo1 <- parLapply(cl, 1:K, function(x)
try(Model(prop1[x,], Data),
silent=!Debug[["DB.Model"]]))
for (k in 1:K) {
if(inherits(Mo1[[k]], "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal ", k,
"failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop1[k,j],5),
file=LogFile, append=TRUE)}
Mo1[[k]] <- Mo0
}
else if(any(!is.finite(c(Mo1[[k]][["LP"]],
Mo1[[k]][["Dev"]],
Mo1[[k]][["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal ", k,
"resulted in non-finite",
"value(s).\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop1[k,j],5),
file=LogFile, append=TRUE)}
Mo1[[k]] <- Mo0}
LP[k] <- LW[k] <- Mo1[[k]][["LP"]]
prop1[k,] <- Mo1[[k]][["parm"]]}
}
### Normalize Weights
w <- exp(LW - logadd(LW))
if(all(w == 0)) w <- rep(1/K, K)
### Sample a Proposal
prop5 <- Mo0[["parm"]]
prop2 <- sample(prop1[,j], size=1, prob=w)
prop5[j] <- prop2
### Create Reference Set
Mo2 <- try(Model(prop5, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo2, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop5[j],5),
file=LogFile, append=TRUE)}
Mo2 <- Mo0}
prop3 <- c(rnorm(K-1, Mo2[["parm"]][j], tuning[j]),
Mo2[["parm"]][j])
prop4 <- prop1
prop4[,j] <- prop3
### Calculate Acceptance Probability
numerator <- logadd(LP)
denom <- rep(0, K)
if(CPUs == 1) {
### Non-parallel
for (k in 1:K) {
Mo1[[k]] <- try(Model(prop4[k,], Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1[[k]], "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal ", k,
"failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop4[k,j],5),
file=LogFile, append=TRUE)}
Mo1[[k]] <- Mo0
}
else if(any(!is.finite(c(Mo1[[k]][["LP"]],
Mo1[[k]][["Dev"]],
Mo1[[k]][["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal ", k,
"resulted in non-finite",
"value(s).\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop4[k,j],5),
file=LogFile, append=TRUE)}
Mo1[[k]] <- Mo0}
denom[k] <- Mo1[[k]][["LP"]]}
}
else {
### Parallel
Mo1 <- parLapply(cl, 1:K, function(x)
try(Model(prop4[x,], Data),
silent=!Debug[["DB.Model"]]))
for (k in 1:K) {
if(inherits(Mo1[[k]], "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal ", k,
"failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop4[k,j],5),
file=LogFile, append=TRUE)}
Mo1[[k]] <- Mo0
}
else if(any(!is.finite(c(Mo1[[k]][["LP"]],
Mo1[[k]][["Dev"]],
Mo1[[k]][["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal ", k,
"resulted in non-finite",
"value(s).\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop4[k,j],5),
file=LogFile, append=TRUE)}
Mo1[[k]] <- Mo0}
denom[k] <- Mo1[[k]][["LP"]]}}
denom <- logadd(denom)
### Accept/Reject
u <- log(runif(1)) < (numerator - denom)
if(u == TRUE) {
Mo0 <- Mo2
Acceptance[j] <- Acceptance[j] + 1}}
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=mean(as.vector(Acceptance)),
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
.mcmcmwg <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, tuning,
Debug, LogFile)
{
Block <- Specs[["B"]]
B <- length(Block)
Acceptance <- matrix(0, 1, LIV)
if(B == 0) {
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Random-Scan Componentwise Estimation
propdraw <- rnorm(LIV,0,tuning)
for (j in sample.int(LIV)) {
### Propose new parameter values
prop <- Mo0[["parm"]]
prop[j] <- prop[j] + propdraw[j]
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed for",
Data[["parm.names"]][j], ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
u <- log(runif(1)) < {Mo1[["LP"]] - Mo0[["LP"]]}
if(u == TRUE) {
Mo0 <- Mo1
Acceptance[j] <- Acceptance[j] + 1}}}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
}
else {
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Random-Scan Componentwise Estimation
propdraw <- rnorm(LIV,0,tuning)
### Proceed by Block
for (b in 1:B) {
for (j in sample(Block[[b]])) {
### Propose new parameter values
prop <- Mo0[["parm"]]
prop[j] <- prop[j] + propdraw[j]
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed for",
Data[["parm.names"]][j], ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
u <- log(runif(1)) < {Mo1[["LP"]] -
Mo0[["LP"]]}
if(u == TRUE) {
Mo0 <- Mo1
Acceptance[j] <- Acceptance[j] + 1}}}}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
}
### Output
out <- list(Acceptance=mean(as.vector(Acceptance)),
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=tuning)
return(out)
}
.mcmcnuts <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, Debug,
LogFile)
{
A <- Specs[["A"]]
delta <- Specs[["delta"]]
epsilon <- Specs[["epsilon"]]
Lmax <- Specs[["Lmax"]]
post <- matrix(Mo0[["parm"]], Iterations, LIV, byrow=TRUE)
leapfrog <- function(theta, r, grad, epsilon, Model, Data, Mo0, Debug)
{
rprime <- r + 0.5 * epsilon * grad
thetaprime <- theta + epsilon * rprime
Mo1 <- try(Model(thetaprime, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed in leapfrog.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(thetaprime, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in leapfrog",
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(thetaprime, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0}
thetaprime <- Mo1[["parm"]]
gradprime <- partial(Model, thetaprime, Data)
rprime <- rprime + 0.5 * epsilon * gradprime
out <- list(thetaprime=thetaprime,
rprime=rprime,
gradprime=gradprime,
Mo1=Mo1)
return(out)
}
stop.criterion <- function(thetaminus, thetaplus, rminus, rplus)
{
thetavec <- thetaplus - thetaminus
criterion <- (thetavec %*% rminus >= 0) &&
(thetavec %*% rplus >= 0)
return(criterion)
}
build.tree <- function(theta, r, grad, logu, v, j, epsilon, joint0, Mo0)
{
if(j == 0) {
### Base case: Take a single leapfrog step in direction v
leap <- leapfrog(theta=theta, r=r, grad=grad,
epsilon=v*epsilon, Model=Model, Data=Data, Mo0=Mo0,
Debug=Debug)
rprime <- leap$rprime
thetaprime <- leap$thetaprime
Mo1 <- leap$Mo1
gradprime <- leap$gradprime
joint <- Mo1[["LP"]] - 0.5 * as.vector(rprime %*% rprime)
### Is the new point in the slice?
nprime <- logu < joint
### Is the simulation wildly inaccurate?
sprime <- logu - 1000 < joint
# Set the return values---minus=plus for all things here,
# since the "tree" is of depth 0.
thetaminus <- thetaprime
thetaplus <- thetaprime
rminus <- rprime
rplus <- rprime
gradminus <- gradprime
gradplus <- gradprime
### Compute the acceptance probability
alphaprime <- min(1, exp(Mo1[["LP"]] - 0.5 *
as.vector(rprime %*% rprime) - joint0))
nalphaprime <- 1}
else {
# Recursion: Implicitly build the height j-1 left and
# right subtrees
tree <- build.tree(theta=theta, r=r, grad=grad, logu=logu,
v=v, j=j-1, epsilon=epsilon, joint=joint0, Mo0=Mo0)
thetaminus <- tree$thetaminus
rminus <- tree$rminus
gradminus <- tree$gradminus
thetaplus <- tree$thetaplus
rplus <- tree$rplus
gradplus <- tree$gradplus
thetaprime <- tree$thetaprime
gradprime <- tree$gradprime
Mo1 <- tree$Mo1
nprime <- tree$nprime
sprime <- tree$sprime
alphaprime <- tree$alphaprime
nalphaprime <- tree$nalphaprime
### If the first subtree stopping criterion is met, then stop
if(sprime == 1) {
if(v == -1) {
tree <- build.tree(theta=thetaminus, r=rminus,
grad=gradminus, logu=logu, v=v, j=j-1,
epsilon=epsilon, joint0=joint0, Mo0=Mo0)
thetaminus <- tree$thetaminus
rminus <- tree$rminus
gradminus <- tree$gradminus
thetaprime2 <- tree$thetaprime
gradprime2 <- tree$gradprime
Mo12 <- tree$Mo1
nprime2 <- tree$nprime
sprime2 <- tree$sprime
alphaprime2 <- tree$alphaprime
nalphaprime2 <- tree$nalphaprime
}
else {
tree <- build.tree(theta=thetaplus, r=rplus,
grad=gradplus, logu=logu, v=v, j=j-1,
epsilon=epsilon, joint0=joint0, Mo0=Mo0)
thetaplus <- tree$thetaplus
rplus <- tree$rplus
gradplus <- tree$gradplus
thetaprime2 <- tree$thetaprime
gradprime2 <- tree$gradprime
Mo12 <- tree$Mo1
nprime2 <- tree$nprime
sprime2 <- tree$sprime
alphaprime2 <- tree$alphaprime
nalphaprime2 <- tree$nalphaprime
}
### Choose a subtree to propagate a sample up from
temp <- nprime2 / (nprime + nprime2)
if(!is.finite(temp)) temp <- 0
if(runif(1) < temp) {
thetaprime <- thetaprime2
gradprime <- gradprime2
Mo1 <- Mo12}
### Update the number of valid points
nprime <- nprime + nprime2
### Update the stopping criterion
sprime <- sprime && sprime2 &&
stop.criterion(thetaminus, thetaplus, rminus,
rplus)
### Update acceptance probability statistics
alphaprime <- alphaprime + alphaprime2
nalphaprime <- nalphaprime + nalphaprime2}}
out <- list(thetaminus=thetaminus,
rminus=rminus,
gradminus=gradminus,
thetaplus=thetaplus,
rplus=rplus,
gradplus=gradplus,
thetaprime=thetaprime,
gradprime=gradprime,
Mo1=Mo1,
nprime=nprime,
sprime=sprime,
alphaprime=alphaprime,
nalphaprime=nalphaprime)
return(out)
}
find.reasonable.epsilon <- function(theta0, grad0, Mo0, Model, Data,
LogFile)
{
cat("\nFinding a reasonable initial value for epsilon...",
file=LogFile, append=TRUE)
epsilon <- 0.001
r0 <- runif(length(theta0))
### Figure out which direction to move epsilon
leap <- leapfrog(theta=theta0, r=r0, grad=grad0,
epsilon=epsilon, Model=Model, Data=Data, Mo0=Mo0,
Debug=Debug)
if(!is.finite(leap$Mo1[["LP"]]))
stop("LP is not finite in find.reasonable.epsilon().",
file=LogFile, append=TRUE)
acceptprob <- exp(leap$Mo1[["LP"]] - Mo0[["LP"]] - 0.5 *
(as.vector(leap$rprime %*% leap$rprime) -
as.vector(r0 %*% r0)))
a <- 2 * (acceptprob > 0.5) - 1
### Keep moving epsilon in that direction until acceptprob
### crosses 0.5
while (acceptprob^a > 2^(-a)) {
epsilon <- epsilon * 2^a
leap <- leapfrog(theta=theta0, r=r0, grad=grad0,
epsilon=epsilon, Model=Model, Data=Data, Mo0=Mo0,
Debug=Debug)
if(!is.finite(leap$Mo1[["LP"]]))
stop("LP is not finite in find.reasonable.epsilon().",
file=LogFile, append=TRUE)
acceptprob <- exp(leap$Mo1[["LP"]] - Mo0[["LP"]] - 0.5 *
(as.vector(leap$rprime %*% leap$rprime) -
as.vector(r0 %*% r0)))
}
cat("\nepsilon: ", round(max(epsilon,0.001),5), "\n\n", sep="",
file=LogFile, append=TRUE)
return(epsilon)
}
Count <- 0
evals <- 0
grad <- partial(Model, post[1,], Data)
if(is.null(epsilon))
epsilon <- find.reasonable.epsilon(theta0=post[1,], grad0=grad,
Mo0=Mo0, Model=Model, Data=Data, LogFile=LogFile)
DiagCovar[1,] <- epsilon
### Dual-Averaging Parameters
epsilonbar <- 1
gamma <- 0.05
Hbar <- 0
kappa <- 0.75
mu <- log(10*epsilon)
t0 <- 10
### Reset Dev, Mon, and thinned
if(A < Iterations) {
Dev <- matrix(Dev[1:(floor((Iterations-A)/Thinning)+1),])
Mon <- matrix(Mo0[["Monitor"]], floor((Iterations-A)/Thinning)+1,
length(Mo0[["Monitor"]]), byrow=TRUE)
thinned <- matrix(0, floor((Iterations-A)/Thinning)+1, LIV)}
### Begin NUTS
for (iter in 2:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Current Posterior
if(iter > 1) post[iter,] <- post[iter-1,]
### Save Thinned Samples
if(iter > A) {
if((iter-A) %% Thinning == 0) {
thinned[((iter-A)/Thinning+1),] <- post[iter,]
Dev[((iter-A)/Thinning+1)] <- Mo0[["Dev"]]
Mon[((iter-A)/Thinning+1),] <- Mo0[["Monitor"]]}}
else if(A >= Iterations) {
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- post[iter,]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}}
prop <- post[iter,]
r0 <- runif(LIV) ### r0 is momenta
### Joint log-probability of theta and momenta r
joint <- Mo0[["LP"]] - 0.5 * as.vector(r0 %*% r0)
### Resample u ~ U([0, exp(joint)])
logu <- joint - rexp(1)
### Initialize Tree
thetaminus <- prop
thetaplus <- prop
rminus <- r0
rplus <- r0
gradminus <- grad
gradplus <- grad
j <- 0 ### Initial height j=0
n <- 1 ### Initially, the only valid point is the initial point
s <- 1 ### Loop until s == 0
while (s == 1) {
### Choose a direction: -1=backward, 1=forward.
v <- 2*(runif(1) < 0.5) - 1
### Double the size of the tree.
if(v == -1) {
tree <- build.tree(theta=thetaminus, r=rminus,
grad=gradminus, logu=logu, v=v, j=j,
epsilon=epsilon, joint0=joint, Mo0=Mo0)
thetaminus <- tree$thetaminus
rminus <- tree$rminus
gradminus <- tree$gradminus
thetaprime <- tree$thetaprime
gradprime <- tree$gradprime
Mo1 <- tree$Mo1
nprime <- tree$nprime
sprime <- tree$sprime
alpha <- tree$alphaprime
nalpha <- tree$nalphaprime}
else {
tree <- build.tree(theta=thetaplus, r=rplus,
grad=gradplus, logu, v=v, j=j, epsilon=epsilon,
joint0=joint, Mo0=Mo0)
thetaplus <- tree$thetaplus
rplus <- tree$rplus
gradplus <- tree$gradplus
thetaprime <- tree$thetaprime
gradprime <- tree$gradprime
Mo1 <- tree$Mo1
nprime <- tree$nprime
sprime <- tree$sprime
alpha <- tree$alphaprime
nalpha <- tree$nalphaprime}
### Accept/Reject
Count <- Count + 1
if((sprime == 1) && (runif(1) < nprime/n)) {
post[iter,] <- thetaprime
Mo0 <- Mo1
grad <- gradprime
Acceptance <- Acceptance + 1
if(iter > A) {
if((iter-A) %% Thinning == 0) {
thinned[((iter-A)/Thinning+1),] <- Mo1[["parm"]]
Dev[((iter-A)/Thinning+1)] <- Mo1[["Dev"]]
Mon[((iter-A)/Thinning+1),] <- Mo1[["Monitor"]]}}
else if(A >= Iterations) {
if(iter %% Thinning == 0) {
thinned[t.iter,] <- Mo1[["parm"]]
Dev[t.iter] <- Mo1[["Dev"]]
Mon[t.iter,] <- Mo1[["Monitor"]]}}}
### Update number of observed valid points
n <- n + nprime
### Decide if it is time to stop
s <- sprime &&
stop.criterion(thetaminus, thetaplus, rminus, rplus)
### Increment depth
j <- j + 1
if(j*j >= Lmax) s <- 0}
### Adaptation of epsilon
eta <- 1 / (iter - 1 + t0)
Hbar <- (1 - eta) * Hbar + eta * (delta - alpha / nalpha)
if(iter <= A) {
epsilon <- exp(mu - sqrt(iter-1)/gamma * Hbar)
eta <- (iter-1)^-kappa
epsilonbar <- exp((1 - eta) * log(epsilonbar) +
eta * log(epsilon))
DiagCovar <- rbind(DiagCovar, epsilon)}
else epsilon <- epsilonbar
}
Acceptance <- round(Acceptance / Count * Iterations)
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
.mcmcohss <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned,
VarCov, Debug, LogFile)
{
A <- Specs[["A"]]
n <- Specs[["n"]]
w <- 0.05 # as with Roberts & Rosenthal
if(!is.symmetric.matrix(VarCov)) {
cat("\nAsymmetric Covar, correcting now...\n", file=LogFile,
append=TRUE)
VarCov <- as.symmetric.matrix(VarCov)}
if(!is.positive.definite(VarCov)) {
cat("\nNon-Positive-Definite Covar, correcting now...\n",
file=LogFile, append=TRUE)
VarCov <- as.positive.definite(VarCov)}
decomp.freq <- max(floor(Iterations / Thinning / 100), 10)
cat("\nEigendecomposition will occur every", decomp.freq,
"iterations.\n\n", file=LogFile, append=TRUE)
S.eig <-try(eigen(VarCov), silent=!Debug[["DB.eigen"]])
if(inherits(S.eig, "try-error")) {
if(Debug[["DB.eigen"]] == TRUE)
cat("\nWARNING: Eigendecomposition failed.\n",
file=LogFile, append=TRUE)
S.eig <- NULL
DiagCovar <- matrix(0, floor(Iterations/Thinning)+1, LIV)
}
else DiagCovar <- matrix(diag(S.eig$vectors),
floor(Iterations/Thinning)+1, LIV, byrow=TRUE)
tuning <- 1 #Tuning
edge.scale <- 5 #Tuning
if(A > Iterations)
post <- matrix(Mo0[["parm"]], Iterations, LIV, byrow=TRUE)
else post <- matrix(Mo0[["parm"]], A, LIV, byrow=TRUE)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Eigenvectors of the Sample Covariance Matrix
if({iter %% decomp.freq == 0} & {iter > 2} & {iter <= A}) {
VarCov2 <- try({VarCov*n +
cov(post[1:(iter-1),,drop=FALSE])*(iter-1)}/{n+iter-1},
silent=TRUE)
if(inherits(VarCov2, "try-error")) VarCov2 <- VarCov
if(!is.symmetric.matrix(VarCov2))
VarCov2 <- as.symmetric.matrix(VarCov2)
if(!is.positive.definite(VarCov2))
VarCov2 <- as.positive.definite(VarCov2)
S.eig <- try(eigen(VarCov2), silent=!Debug[["DB.eigen"]])
if(inherits(S.eig, "try-error")) {
if(Debug[["DB.eigen"]] == TRUE)
cat("\nWARNING: Eigendecomposition failed in",
"iteration", iter, ".\n",
file=LogFile, append=TRUE)
S.eig <- eigen(VarCov)}}
### Hypercube or Eigenvector
if(runif(1) < w || is.null(S.eig)) {
vals <- rep(tuning, LIV)
vecs <- diag(1, nrow=LIV)
}
else {
vals <- S.eig$values
vecs <- S.eig$vectors}
### Slice Interval
Mo0.1 <- try(Model(Mo0[["parm"]], Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo0.1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(Mo0[["parm"]], collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo0.1 <- Mo0}
Mo0 <- Mo0.1
y.slice <- Mo0[["LP"]] - rexp(1)
L <- -1 * runif(LIV)
U <- L + 1
### Rejection Sampling
repeat {
wt <- runif(LIV, min=L, max=U)
v <- as.numeric(vecs %*% {edge.scale * wt * vals})
prop <- Mo0[["parm"]] + v
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Rejection sampling failed.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Rejection sampling resulted",
"in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0}
if(Mo1[["LP"]] >= y.slice) break
else if(all(abs(wt) < 1e-100)) {
Mo1 <- Mo0
break}
L[wt < 0] <- wt[wt < 0]
U[wt > 0] <- wt[wt > 0]}
Mo0 <- Mo1
if(iter <= A) post[iter,] <- Mo0[["parm"]]
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]
DiagCovar[t.iter,] <- diag(S.eig$vectors)}
}
if(A > 0) VarCov <- VarCov2
### Output
out <- list(Acceptance=Iterations,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=VarCov)
return(out)
}
.mcmcpcn <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, VarCov,
Debug, LogFile)
{
beta <- Specs[["beta"]]
U <- chol(VarCov)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Propose new parameter values
prop <- as.vector(sqrt(1 - beta*beta)*Mo0[["parm"]] +
beta*(rbind(rnorm(LIV)) %*% U))
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal resulted in non-finite",
"value(s).\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
Acceptance <- Acceptance + 1}}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=VarCov)
return(out)
}
.mcmcram <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, VarCov,
Debug, LogFile)
{
alpha.star <- Specs[["alpha.star"]]
Block <- Specs[["B"]]
Dist <- Specs[["Dist"]]
gamma <- Specs[["gamma"]]
n <- Specs[["n"]]
B <- length(Block)
if(B == 0) {
if(!is.symmetric.matrix(VarCov)) {
cat("\nAsymmetric Covar, correcting now...\n", file=LogFile,
append=TRUE)
VarCov <- as.symmetric.matrix(VarCov)}
if(!is.positive.definite(VarCov)) {
cat("\nNon-Positive-Definite Covar, correcting now...\n",
file=LogFile, append=TRUE)
VarCov <- as.positive.definite(VarCov)}
Iden.Mat <- diag(LIV)
S.z <- try(t(chol(VarCov)), silent=!Debug[["DB.chol"]])
if(!inherits(S.z, "try-error")) {
if(Debug[["DB.chol"]] == TRUE)
cat("\nWARNING: Cholesky decomposition failed for",
"proposal.\n", file=LogFile, append=TRUE)
S <- S.z}
else S <- Iden.Mat
DiagCovar <- matrix(diag(VarCov), floor(Iterations/Thinning)+1,
LIV, byrow=TRUE)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Propose New Parameter Values
if(Dist == "t") U <- rt(LIV, df=5)
else U <- rnorm(LIV)
prop <- Mo0[["parm"]] + rbind(U) %*% S
### Log-Posterior
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal resulted in non-finite",
"value(s).\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
Acceptance <- Acceptance + 1}}
### Adaptation
eta <- min(1, LIV*{n + iter}^(-gamma))
VarCov.test <- S %*% {Iden.Mat +
eta*(min(1, exp(log.alpha)) - alpha.star) *
U %*% t(U) / sum(U*U)} %*% t(S)
if(missing(VarCov.test) || !all(is.finite(VarCov.test)) ||
!is.matrix(VarCov.test)) {VarCov.test <- VarCov}
if(!is.symmetric.matrix(VarCov.test))
VarCov.test <- as.symmetric.matrix(VarCov.test)
if(is.positive.definite(VarCov.test)) {
S.z <- try(t(chol(VarCov)), silent=!Debug[["DB.chol"]])
if(!inherits(S.z, "try-error")) {
VarCov <- VarCov.test
S <- S.z
}
else if(Debug[["DB.chol"]] == TRUE)
cat("\nWARNING: Cholesky decomposition failed for",
"proposal in iteration", iter, ".\n",
file=LogFile, append=TRUE)}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]
DiagCovar[t.iter,] <- diag(VarCov)}
}
}
else {
if(!identical(length(VarCov), B))
stop("Number of components in Covar differs from ",
"number of blocks.", file=LogFile, append=TRUE)
DiagCovar <- rep(0, LIV)
Iden.Mat <- S <- S.z <- list()
for (b in 1:B) {
if(!identical(length(Block[[b]]), length(diag(VarCov[[b]]))))
stop("Diagonal of Covar[[",b,"]] differs from ",
"block length.", file=LogFile, append=TRUE)
if(!is.symmetric.matrix(VarCov[[b]])) {
cat("\nAsymmetric Covar block, correcting now...\n",
file=LogFile, append=TRUE)
VarCov[[b]] <- as.symmetric.matrix(VarCov[[b]])}
if(!is.positive.definite(VarCov[[b]])) {
cat("\nNon-Positive-Definite Covar block,",
"correcting now...\n", file=LogFile, append=TRUE)
VarCov[[b]] <- as.positive.definite(VarCov[[b]])}
Iden.Mat[[b]] <- diag(length(diag(VarCov[[b]])))
S.z[[b]] <- try(t(chol(VarCov[[b]])),
silent=!Debug[["DB.chol"]])
if(!inherits(S.z[[b]], "try-error")) S[[b]] <- S.z[[b]]
else {
if(Debug[["DB.chol"]] == TRUE)
cat("\nWARNING: Cholesky decomposition failed for",
"proposal in block", b, ".\n", file=LogFile,
append=TRUE)
S[[b]] <- Iden.Mat[[b]]}
DiagCovar[Block[[b]]] <- diag(VarCov[[b]])
}
DiagCovar <- matrix(DiagCovar, floor(Iterations/Thinning)+1,
LIV, byrow=TRUE)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Blockwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Proceed by Block
for (b in 1:B) {
### Propose New Parameter Values
if(Dist == "t") U <- rt(length(Block[[b]]), df=5)
else U <- rnorm(length(Block[[b]]))
prop <- Mo0[["parm"]]
prop[Block[[b]]] <- prop[Block[[b]]] +
rbind(U) %*% S[[b]]
### Log-Posterior
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed in block",
b, ".\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in block", b,
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
Acceptance <- Acceptance +
length(Block[[b]]) / LIV}}
### Adaptation
eta <- min(1, length(Block[[b]])*{n + iter}^(-gamma))
VarCov.test <- S[[b]] %*% {Iden.Mat[[b]] +
eta*(min(1, exp(log.alpha)) - alpha.star) *
U %*% t(U) / sum(U*U)} %*% t(S[[b]])
if(missing(VarCov.test) || !all(is.finite(VarCov.test)) ||
!is.matrix(VarCov.test)) {VarCov.test <- VarCov[[b]]}
if(!is.symmetric.matrix(VarCov.test))
VarCov.test <- as.symmetric.matrix(VarCov.test)
if(is.positive.definite(VarCov.test)) {
S.z[[b]] <- try(t(chol(VarCov[[b]])),
silent=!Debug[["DB.chol"]])
if(!inherits(S.z[[b]], "try-error")) {
VarCov[[b]] <- VarCov.test
S[[b]] <- S.z[[b]]}
else if(Debug[["DB.chol"]] == TRUE)
cat("\nWARNING: Cholesky decomposition",
"failed for proposal in block", b,
"in iteration", iter, ".\n",
file=LogFile, append=TRUE)}
DiagCovar[floor(iter / Thinning)+1,Block[[b]]] <- diag(VarCov[[b]])
}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=VarCov)
return(out)
}
.mcmcrdmh <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned,
Debug, LogFile)
{
Acceptance <- matrix(0, 1, LIV)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
s <- sample(c(-1,1), LIV, replace=TRUE)
u1 <- runif(LIV, -1, 1)
epsilon1 <- u1^s
### Random-Scan Componentwise Estimation
for (j in sample.int(LIV)) {
### Propose new parameter values
prop <- Mo0[["parm"]]
prop[j] <- prop[j]*epsilon1[j]
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed for",
Data[["parm.names"]][j], ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
epsilon2 <- log(abs(Mo1[["parm"]][j] /
Mo0[["parm"]][j]))
if(!is.finite(epsilon2)) epsilon2 <- 0
### Accept/Reject
u2 <- log(runif(1)) < (epsilon2 + Mo1[["LP"]] -
Mo0[["LP"]])
if(u2 == TRUE) {
Mo0 <- Mo1
Acceptance[j] <- Acceptance[j] + 1}}}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=mean(as.vector(Acceptance)),
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
.mcmcrefractive <- function(Model, Data, Iterations, Status, Thinning,
Specs, Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, thinned, Debug,
LogFile)
{
Adaptive <- Specs[["Adaptive"]]
m <- Specs[["m"]]
w <- Specs[["w"]]
r <- Specs[["r"]]
alpha.star <- 0.65
if(Adaptive < Iterations) DiagCovar <- matrix(w, nrow(thinned), LIV)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
prop <- Mo0[["parm"]]
p <- rnorm(LIV)
a <- 1
g <- partial(Model, prop, Data)
for (i in 1:m) {
if(t(p) %*% g > 0) {
u <- g / sqrt(sum(g*g))
r1 <- 1
r2 <- r
}
else {
u <- -g / sqrt(sum(g*g))
r1 <- r
r2 <- 1}
cos.theta.1 <- (t(p) %*% u) / sqrt(sum(p*p))
cos.2.theta.1 <- cos.theta.1 * cos.theta.1
cos.2.theta.2 <- 1 - (r1^2 / r2^2)*(1 - cos.2.theta.1)
if(cos.2.theta.2 > 0) cos.theta.2 <- sqrt(cos.2.theta.2)
else cos.theta.2 <- -sqrt(abs(cos.2.theta.2))
if(cos.2.theta.2 < 0) p <- as.vector(p - 2*(t(p) %*% u) %*% u)
else {
p <- (r1 / r2)*p -
sqrt(sum(p*p))*((r1 / r2)*cos.theta.1 -
cos.theta.2)*u
a <- (r1 / r2)^(LIV-1)*(cos.theta.1 / cos.theta.2)*a}
prop <- prop + w*p
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal resulted in non-finite",
"value(s).\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
prop <- Mo1[["parm"]]}
### Accept/Reject
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]] + exp(a)
if(!is.finite(log.alpha)) log.alpha <- 0
if(log(runif(1)) < log.alpha) {
Mo0 <- Mo1
Acceptance <- Acceptance + 1
if(Adaptive < Iterations)
w <- w + (w / (alpha.star * (1 - alpha.star))) *
(1 - alpha.star) / iter
}
else if(Adaptive < Iterations)
w <- abs(w - (w / (alpha.star * (1 - alpha.star))) *
alpha.star / iter)
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]
if(Adaptive < Iterations) DiagCovar[t.iter,] <- w}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
.mcmcrj <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, Debug,
LogFile)
{
bin.n <- Specs[["bin.n"]]
bin.p <- Specs[["bin.p"]]
parm.p <- Specs[["parm.p"]]
selectable <- Specs[["selectable"]]
selected <- Specs[["selected"]]
cur.parm <- cur.sel <- selected
cur.parm[which(selectable == 0)] <- 1
nonzero.post <- rep(0, LIV)
p <- parm.p
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Propose a variable to include/exclude
v.change <- sample(LIV, 1, prob=selectable)
prop.sel <- cur.sel
prop.parm <- cur.parm
### Change proposed size, but not above bin.n
if(sum(cur.sel) < bin.n) {
prop.sel[v.change] <- 1 - prop.sel[v.change]
prop.parm[v.change] <- 1 - prop.parm[v.change]}
else if(prop.sel[v.change] == 1)
prop.parm[v.change] <- prop.sel[v.change] <- 0
### Priors
prior.cur <- sum(dbern(cur.sel, p[which(selectable == 1)], log=TRUE),
dbinom(sum(cur.sel), bin.n, bin.p, log=TRUE))
prior.prop <- sum(dbern(prop.sel, p[which(selectable == 1)], log=TRUE),
dbinom(sum(prop.sel), bin.n, bin.p, log=TRUE))
### Hit-And-Run Proposal Parameters
theta <- rnorm(LIV)
theta <- theta / sqrt(sum(theta*theta))
lambda <- runif(1)
### Random-Scan Componentwise Estimation (Within-Model)
for (j in sample(which(cur.parm == 1))) {
### Propose new parameter values
temp.post <- Mo0[["parm"]]
temp.post[which(temp.post == 0)] <- nonzero.post[which(temp.post == 0)]
temp.post[which(cur.parm == 0)] <- 0
prop <- Mo0[["parm"]] <- temp.post
prop[j] <- prop[j] + lambda*theta[j]
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Within-model proposal failed for",
Data[["parm.names"]][j], ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Within-model proposal for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
### Accept/Reject (Within-Model Move)
u <- log(runif(1)) < (Mo1[["LP"]] - Mo0[["LP"]])
if(u == TRUE) Mo0 <- Mo1
if(Mo0[["parm"]][j] != 0) nonzero.post[j] <- Mo0[["parm"]][j]
Acceptance <- Acceptance + (u * (1 / sum(cur.parm)))}
### Random-Scan Componentwise Estimation (Between-Models)
prop <- Mo0[["parm"]]
prop[v.change] <- prop.sel[v.change]*(prop[v.change] +
lambda*theta[v.change])
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Between-models proposal failed for",
Data[["parm.names"]][j], ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Between-models proposal for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
### Accept/Reject (Between-Models Move)
u <- log(runif(1)) < (Mo1[["LP"]] - Mo0[["LP"]] + prior.prop -
prior.cur)
if(u == TRUE) {
Mo0 <- Mo1
cur.sel <- prop.sel
cur.parm <- prop.parm}
if(Mo0[["parm"]][v.change] != 0)
nonzero.post[v.change] <- Mo0[["parm"]][v.change]
Acceptance <- Acceptance + (u * (1 / sum(prop.parm)))
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
.mcmcrss <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, thinned, Debug, LogFile)
{
m <- Specs[["m"]]
w <- Specs[["w"]]
reflections <- 0
Norm <- function(x) return(sqrt(sum(x*x)))
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
prop <- Mo0[["parm"]]
y.slice <- Mo0[["LP"]] - rexp(1)
g <- partial(Model, prop, Data)
p <- rnorm(LIV)
reflections <- 0
### Take m Steps
for (i in 1:m) {
prop0 <- prop
prop <- prop + w*p
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out proposal failed",
"in step", i, ".\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out proposal resulted",
"in non-finite value(s) in step", i, ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0}
prop <- Mo1[["parm"]]
### Reflect at boundary
if(y.slice > Mo1[["LP"]]) {
reflections <- reflections + 1
prop <- prop0
g <- partial(Model, prop, Data)
p <- p - 2*g*{(t(p) %*% g) / Norm(g)^2}}}
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Final proposal failed.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Final proposal resulted",
"in non-finite value(s).\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
Mo0 <- Mo1
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=Iterations,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
.mcmcrwm <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, tuning,
VarCov, Debug, LogFile)
{
Block <- Specs[["B"]]
if(length(Block) == 0) {
if(!is.symmetric.matrix(VarCov)) {
cat("\nAsymmetric Covar, correcting now...\n", file=LogFile,
append=TRUE)
VarCov <- as.symmetric.matrix(VarCov)}
if(!is.positive.definite(VarCov)) {
cat("\nNon-Positive-Definite Covar, correcting now...\n",
file=LogFile, append=TRUE)
VarCov <- as.positive.definite(VarCov)}
U <- chol(VarCov)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Propose new parameter values
prop <- as.vector(Mo0[["parm"]] +
rbind(rnorm(LIV)) %*% U)
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal resulted",
"in non-finite value(s).\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
Acceptance <- Acceptance + 1}}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
}
else {
B <- length(Block)
if(!identical(length(VarCov), B))
stop("Number of components in Covar differs from ",
"number of blocks.", file=LogFile, append=TRUE)
for (b in 1:B) {
if(!identical(length(Block[[b]]), length(diag(VarCov[[b]]))))
stop("Diagonal of Covar[[",b,"]] differs from ",
"block length.", file=LogFile, append=TRUE)
if(!is.symmetric.matrix(VarCov[[b]])) {
cat("\nAsymmetric Covar block, correcting now...\n",
file=LogFile, append=TRUE)
VarCov[[b]] <- as.symmetric.matrix(VarCov[[b]])}
if(!is.positive.definite(VarCov[[b]])) {
cat("\nNon-Positive-Definite Covar block,",
"correcting now...\n", file=LogFile, append=TRUE)
VarCov[[b]] <- as.positive.definite(VarCov[[b]])}}
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter, sep="", file=LogFile,
append=TRUE)
### Proceed by Block
for (b in 1:B) {
### Propose new parameter values
prop <- Mo0[["parm"]]
prop[Block[[b]]] <- Mo0[["parm"]][Block[[b]]] +
rbind(rnorm(length(Block[[b]]))) %*%
chol(VarCov[[b]])
if({b == 1} & {iter %% Status == 0})
cat(", Proposal: Blockwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in block", b,
"failed.\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in block", b,
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
log.u <- log(runif(1))
log.alpha <- Mo1[["LP"]] - Mo0[["LP"]]
if(!is.finite(log.alpha)) log.alpha <- 0
if(log.u < log.alpha) {
Mo0 <- Mo1
Acceptance <- Acceptance +
length(Block[[b]]) / LIV}}
}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=VarCov)
return(out)
}
.mcmcsamwg <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, tuning,
parm.names, Debug, LogFile)
{
Dyn <- Specs[["Dyn"]]
Periodicity <- Specs[["Periodicity"]]
Acceptance <- matrix(0, 1, LIV)
for (k in 1:ncol(Dyn)) {for (t in 1:nrow(Dyn)) {
Dyn[t,k] <- which(parm.names == Dyn[t,k])}}
Dyn <- matrix(as.numeric(Dyn), nrow(Dyn), ncol(Dyn))
staticparms <- c(1:LIV)[-as.vector(Dyn)]
DiagCovar <- matrix(tuning, floor(Iterations/Periodicity), LIV,
byrow=TRUE)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Select Order of Parameters
if(length(staticparms) == 1) staticsample <- staticparms
else staticsample <- sample(staticparms)
if(ncol(Dyn) == 1) dynsample <- sample(Dyn)
else dynsample <- as.vector(apply(Dyn, 1, sample))
totsample <- c(staticsample, dynsample)
### Componentwise Estimation
for (j in totsample) {
### Propose new parameter values
prop <- Mo0[["parm"]]
prop[j] <- rnorm(1, prop[j], tuning[j])
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed for",
Data[["parm.names"]][j], ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
u <- log(runif(1)) < (Mo1[["LP"]] - Mo0[["LP"]])
if(u == TRUE) {
Mo0 <- Mo1
Acceptance[j] <- Acceptance[j] + 1}}}
### Adapt the Proposal Variance
if(iter %% Periodicity == 0) {
size <- 1 / min(100, sqrt(iter))
Acceptance.Rate <- Acceptance / iter
log.tuning <- log(tuning)
tuning.num <- which(Acceptance.Rate > 0.44)
log.tuning[tuning.num] <- log.tuning[tuning.num] + size
log.tuning[-tuning.num] <- log.tuning[-tuning.num] - size
tuning <- exp(log.tuning)
a.iter <- floor(iter / Periodicity)
DiagCovar[a.iter,] <- tuning}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=mean(as.vector(Acceptance)),
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=tuning)
return(out)
}
.mcmcsgld <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, Debug,
LogFile)
{
epsilon <- Specs[["epsilon"]]
file <- Specs[["file"]]
Nr <- Specs[["Nr"]]
Nc <- Specs[["Nc"]]
size <- Specs[["size"]]
Acceptance <- matrix(Iterations, 1, LIV)
con <- file(file, open="r")
on.exit(close(con))
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Sample Data
seek(con, 0)
skip.rows <- sample.int(Nr - size, size=1)
Data[["X"]] <- matrix(scan(file=con, sep=",", skip=skip.rows,
nlines=size, quiet=TRUE), size, Nc, byrow=TRUE)
### Propose new parameter values
g <- partial(Model, Mo0[["parm"]], Data)
eta <- rnorm(LIV, 0, epsilon[iter])
prop <- Mo0[["parm"]] + {epsilon[iter]/2}*g + eta
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal resulted in non-finite",
"value(s).\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
Mo0 <- Mo1
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
.mcmcslice <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, Debug,
LogFile)
{
Block <- Specs[["B"]]
B <- length(Block)
Bounds <- Specs[["Bounds"]]
m <- Specs[["m"]]
Type <- Specs[["Type"]]
w <- Specs[["w"]]
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Proceed by Block
for (b in 1:B) {
### Random-Scan Componentwise Estimation
if(Type[[b]] == "Continuous") {
for (j in sample(Block[[b]])) {
y.slice <- Mo0[["LP"]] - rexp(1)
u <- runif(1,0,w[[b]])
intL <- intR <- prop <- Mo0[["parm"]]
L <- intL[j] - u
R <- intR[j] + (w[[b]] - u)
### Unlimited number of steps
if(is.infinite(m[[b]])) {
repeat {
if(L <= Bounds[[b]][1]) break
intL[j] <- L
MoL <- try(Model(intL, Data),
silent=!Debug[["DB.Model"]])
if(inherits(MoL, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out",
"the lower bound failed for",
Data[["parm.names"]][j],
".\n",
file=LogFile, append=TRUE)
L <- L + w[[b]]
break}
else if(!is.finite(MoL[["LP"]])) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out",
"the lower bound for",
Data[["parm.names"]][j],
"resulted in a non-finite",
"LP.\n",
file=LogFile, append=TRUE)
L <- L + w[[b]]
break}
if(MoL[["LP"]] <= y.slice) break
L <- L - w[[b]]}
repeat {
if(R >= Bounds[[b]][2]) break
intR[j] <- R
MoR <- try(Model(intR, Data),
silent=!Debug[["DB.Model"]])
if(inherits(MoR, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out",
"the upper bound failed for",
Data[["parm.names"]][j],
".\n",
file=LogFile, append=TRUE)
R <- R - w[[b]]
break}
else if(!is.finite(MoR[["LP"]])) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out",
"the upper bound for",
Data[["parm.names"]][j],
"resulted in a non-finite",
"LP.\n",
file=LogFile, append=TRUE)
R <- R - w[[b]]
break}
if(MoR[["LP"]] <= y.slice) break
R <- R + w[[b]]}
}
else if(m[[b]] > 1) {
### Limited number of steps
J <- floor(runif(1,0,m[[b]]))
K <- (m[[b]] - 1) - J
while (J > 0) {
if(L <= Bounds[[b]][1]) break
intL[j] <- L
MoL <- try(Model(intL, Data),
silent=!Debug[["DB.Model"]])
if(inherits(MoL, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out",
"the lower bound failed for",
Data[["parm.names"]][j],
".\n",
file=LogFile, append=TRUE)
L <- L + w[[b]]
break}
else if(!is.finite(MoL[["LP"]])) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out",
"the lower bound for",
Data[["parm.names"]][j],
"resulted in a non-finite",
"LP.\n",
file=LogFile, append=TRUE)
L <- L + w[[b]]
break}
if(MoL[["LP"]] <= y.slice) break
L <- L - w[[b]]
J <- J - 1}
while (K > 0) {
if(R >= Bounds[[b]][2]) break
intR[j] <- R
MoR <- try(Model(intR, Data),
silent=!Debug[["DB.Model"]])
if(inherits(MoR, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out",
"the upper bound failed for",
Data[["parm.names"]][j],
".\n",
file=LogFile, append=TRUE)
R <- R - w[[b]]
break}
else if(!is.finite(MoR[["LP"]])) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out",
"the lower bound for",
Data[["parm.names"]][j],
"resulted in a non-finite",
"LP.\n",
file=LogFile, append=TRUE)
R <- R - w[[b]]
break}
R <- R + w[[b]]
K <- K - 1}
}
### Shrink the interval to lower and upper bounds
if(L < Bounds[[b]][1]) L <- Bounds[[b]][1]
if(R > Bounds[[b]][2]) R <- Bounds[[b]][2]
### Rejection Sampling
repeat {
L <- min(L,R)
R <- max(L,R)
prop[j] <- runif(1,L,R)
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Rejection sampling",
"failed for",
Data[["parm.names"]][j], "\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
"\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Rejection sampling for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
"\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0}
if(Mo1[["LP"]] >= y.slice) break
else if(abs(R-L) < 1e-100) break
if(Mo1[["parm"]][j] > Mo0[["parm"]][j])
R <- Mo1[["parm"]][j]
else L <- Mo1[["parm"]][j]}
Mo0 <- Mo1
}
}
else if(Type[[b]] == "Nominal") {
for (j in sample(Block[[b]])) {
y.slice <- Mo0[["LP"]] - rexp(1)
LP.grid <- theta <- Bounds[[b]][1]:Bounds[[b]][2]
for (i in 1:length(LP.grid)) {
prop[j] <- theta[i]
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating",
Data[["parm.names"]][j], "at",
round(prop[j],5), "failed.\n",
file=LogFile, append=TRUE)
LP.grid[i] <- 0
}
else if(!is.finite(Mo1[["LP"]])) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Evaluating",
Data[["parm.names"]][j], "at",
round(prop[j],5), "resulted",
"in non-finite value(s).\n",
file=LogFile, append=TRUE)
LP.grid[i] <- 0
}
else if(Mo1[["LP"]] < y.slice)
LP.grid[i] <- 0
else LP.grid[i] <- exp(Mo1[["LP"]])}
if(sum(LP.grid) > 0)
LP.grid <- LP.grid / sum(LP.grid)
else LP.grid <- rep(1/length(LP.grid),
length(LP.grid))
### Rejection Sampling
repeat {
prop[j] <- theta[sample(1:length(LP.grid),1,
prob=LP.grid)]
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(is.finite(Mo1[["LP"]])) {
if(Mo1[["LP"]] >= y.slice) break}}
Mo0 <- Mo1
}
}
else { ### Ordinal
for (j in sample(Block[[b]])) {
y.slice <- Mo0[["LP"]] - rexp(1)
intL <- intR <- prop <- Mo0[["parm"]]
L <- intL[j] - w[[b]]
R <- intR[j] + w[[b]]
### Unlimited number of steps
if(is.infinite(m[[b]])) {
repeat {
if(L <= Bounds[[b]][1]) break
intL[j] <- L
MoL <- try(Model(intL, Data),
silent=!Debug[["DB.Model"]])
if(inherits(MoL, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out",
"the lower bound failed for",
Data[["parm.names"]][j],
".\n", file=LogFile,
append=TRUE)
L <- L + w[[b]]
break}
else if(!is.finite(MoL[["LP"]])) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out",
"the lower bound for",
Data[["parm.names"]][j],
"resulted in a non-finite",
"LP.\n", file=LogFile,
append=TRUE)
L <- L + w[[b]]
break}
if(MoL[["LP"]] <= y.slice) break
L <- L - w[[b]]}
repeat {
if(R >= Bounds[[b]][2]) break
intR[j] <- R
MoR <- try(Model(intR, Data),
silent=!Debug[["DB.Model"]])
if(inherits(MoR, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out",
"the upper bound failed for",
Data[["parm.names"]][j],
".\n", file=LogFile,
append=TRUE)
R <- R - w[[b]]
break}
else if(!is.finite(MoR[["LP"]])) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out",
"the upper bound for",
Data[["parm.names"]][j],
"resulted in a non-finite",
"LP.\n", file=LogFile,
append=TRUE)
R <- R - w[[b]]
break}
if(MoR[["LP"]] <= y.slice) break
R <- R + w[[b]]}
}
else if(m[[b]] > 1) {
### Limited number of steps
J <- floor(runif(1,0,m[[b]]))
K <- (m[[b]] - 1) - J
while (J > 0) {
if(L <= Bounds[[b]][1]) break
intL[j] <- L
MoL <- try(Model(intL, Data),
silent=!Debug[["DB.Model"]])
if(inherits(MoL, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out",
"the lower bound failed for",
Data[["parm.names"]][j],
".\n", file=LogFile,
append=TRUE)
L <- L + w[[b]]
break}
else if(!is.finite(MoL[["LP"]])) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out",
"the lower bound for",
Data[["parm.names"]][j],
"resulted in a non-finite",
"LP.\n", file=LogFile,
append=TRUE)
L <- L + w[[b]]
break}
if(MoL[["LP"]] <= y.slice) break
L <- L - w[[b]]
J <- J - 1}
while (K > 0) {
if(R >= Bounds[[b]][2]) break
intR[j] <- R
MoR <- try(Model(intR, Data),
silent=!Debug[["DB.Model"]])
if(inherits(MoR, "try-error")) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out",
"the upper bound failed for",
Data[["parm.names"]][j],
".\n", file=LogFile,
append=TRUE)
R <- R - w[[b]]
break}
if(!is.finite(MoR[["LP"]])) {
if(Debug[["DB.Model"]] == TRUE)
cat("\nWARNING: Stepping out",
"the lower bound for",
Data[["parm.names"]][j],
"resulted in a non-finite",
"LP.\n", file=LogFile,
append=TRUE)
R <- R - w[[b]]
break}
R <- R + w[[b]]
K <- K - 1}
}
### Shrink the interval to lower and upper bounds
if(L < Bounds[[b]][1]) L <- Bounds[[b]][1]
if(R > Bounds[[b]][2]) R <- Bounds[[b]][2]
### Rejection Sampling
repeat {
prop[j] <- sample(L:R,1)
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Rejection sampling",
"failed for",
Data[["parm.names"]][j], "\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
"\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Rejection sampling for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
"\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0}
if(Mo1[["LP"]] >= y.slice) break
else if(abs(R-L) < 1e-100) break
if(Mo1[["parm"]][j] > Mo0[["parm"]][j])
R <- Mo1[["parm"]][j]
else L <- Mo1[["parm"]][j]}
Mo0 <- Mo1
}
}
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
}
### Output
out <- list(Acceptance=Iterations,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
.mcmcsmwg <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, tuning,
parm.names, Debug, LogFile)
{
Dyn <- Specs[["Dyn"]]
Acceptance <- matrix(0, 1, LIV)
for (k in 1:ncol(Dyn)) {for (t in 1:nrow(Dyn)) {
Dyn[t,k] <- which(parm.names == Dyn[t,k])}}
Dyn <- matrix(as.numeric(Dyn), nrow(Dyn), ncol(Dyn))
staticparms <- c(1:LIV)[-as.vector(Dyn)]
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Select Order of Parameters
if(length(staticparms) == 1) staticsample <- staticparms
else staticsample <- sample(staticparms)
if(ncol(Dyn) == 1) dynsample <- sample(Dyn)
else dynsample <- as.vector(apply(Dyn, 1, sample))
totsample <- c(staticsample, dynsample)
### Componentwise Estimation
for (j in totsample) {
### Propose new parameter values
prop <- Mo0[["parm"]]
prop[j] <- rnorm(1, prop[j], tuning[j])
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed for",
Data[["parm.names"]][j], ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
u <- log(runif(1)) < (Mo1[["LP"]] - Mo0[["LP"]])
if(u == TRUE) {
Mo0 <- Mo1
Acceptance[j] <- Acceptance[j] + 1}}}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=mean(as.vector(Acceptance)),
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=tuning)
return(out)
}
.mcmcthmc <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, Debug,
LogFile)
{
epsilon <- Specs[["epsilon"]]
L <- Specs[["L"]]
m <- Specs[["m"]]
invm <- as.inverse(m)
U <- chol(m)
Temperature <- Specs[["Temperature"]]
gr <- partial(Model, Mo0[["parm"]], Data)
sqrt.Temp <- sqrt(Temperature)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Propose new parameter values
prop <- Mo0[["parm"]]
momentum1 <- momentum0 <- as.vector(rnorm(LIV) %*% U)
kinetic0 <- t(momentum0) %*% invm %*% momentum0 / 2
Mo0.1 <- Mo0
for (l in 1:L) {
if(2*(l-1) < L) momentum1 <- momentum1 * sqrt.Temp
else momentum1 <- momentum1 / sqrt.Temp
momentum1 <- momentum1 + (epsilon/2) * gr
prop <- prop + as.vector(epsilon %*% invm) * momentum1
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed in leapfrog", l,
".\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0.1
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in leapfrog", l,
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0.1}
if(any(Mo0.1[["parm"]] == Mo1[["parm"]])) {
nomove <- which(Mo0.1[["parm"]] == Mo1[["parm"]])
momentum1[nomove] <- -momentum1[nomove]
prop[nomove] <- prop[nomove] + momentum1[nomove]
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed in leapfrog",
l, ".\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0.1
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal in leapfrog",
l, "resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0.1}}
Mo0.1 <- Mo1
prop <- Mo1[["parm"]]
gr <- partial(Model, prop, Data)
momentum1 <- momentum1 + (epsilon/2) * gr
if(2*l > L) momentum1 <- momentum1 / sqrt.Temp
else momentum1 <- momentum1 * sqrt.Temp}
momentum1 <- -momentum1
kinetic1 <- t(momentum1) %*% invm %*% momentum1 / 2
### Accept/Reject
H0 <- -Mo0[["LP"]] + kinetic0
H1 <- -Mo1[["LP"]] + kinetic1
delta <- H1 - H0
alpha <- min(1, exp(-delta))
if(!is.finite(alpha)) alpha <- 0
if(runif(1) < alpha) {
Mo0 <- Mo1
kinetic0 <- kinetic1
Acceptance <- Acceptance + 1}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=matrix(epsilon, 1, LIV),
Mon=Mon,
thinned=thinned,
VarCov=cov(thinned))
return(out)
}
.mcmctwalk <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, Debug,
LogFile)
{
xp0 <- SIV <- Specs[["SIV"]]
n1 <- Specs[["n1"]]
at <- Specs[["at"]]
aw <- Specs[["aw"]]
IntProd <- function(x) {return(sum(x*x))}
DotProd <- function(x, y) {return(sum(x*y))}
Simh1 <- function(dim, pphi, x, xp, beta)
{
phi <- runif(dim) < pphi
rt <- NULL
for (i in 1:dim)
if(phi[i])
rt <- append(rt, xp[i] + beta*(xp[i] - x[i]))
else
rt <- append(rt, x[i])
return(list(rt=rt, nphi=sum(phi)))
}
Simfbeta <- function(at)
{
if(runif(1) < (at-1)/(2*at))
return(exp(1/(at + 1)*log(runif(1))))
else
return(exp(1/(1 - at)*log(runif(1))))
}
Simh2 <- function(dim, pphi, aw, x, xp)
{
u <- runif(dim)
phi <- runif(dim) < pphi
z <- (aw/(1+aw))*(aw*u^2 + 2*u -1)
z <- z*phi
return(list(rt=x + (x - xp)*z, nphi=sum(phi)))
}
Simh3 <- function(dim, pphi, x, xp)
{
phi <- runif(dim) < pphi
sigma <- max(phi*abs(xp - x))
x + sigma*rnorm(dim)*phi
return(list(rt=x + sigma*rnorm(dim)*phi, nphi=sum(phi),
sigma=sigma))
}
G3U <- function(nphi, sigma, h, x, xp)
{
if(nphi > 0)
return((nphi/2)*log(2*pi) + nphi*log(sigma) +
0.5*IntProd(h - xp)/(sigma^2))
else
return(0)
}
Simh4 <- function(dim, pphi, x, xp)
{
phi <- runif(dim) < pphi
sigma <- max(phi*abs(xp - x))/3
rt <- NULL
for (i in 1:dim)
if(phi[i])
rt <- append(rt, xp[i] + sigma*rnorm(1))
else
rt <- append(rt, x[i])
return(list(rt=rt, nphi=sum(phi), sigma=sigma))
}
G4U <- function(nphi, sigma, h, x, xp)
{
if(nphi > 0)
return((nphi/2)*log(2*pi) + nphi*log(sigma) +
0.5*IntProd((h - x))/(sigma^2))
else
return(0)
}
OneMove <- function(dim, Model, Data, x, U, xp, Up, at=at, aw=aw,
pphi=pphi, F1=0.4918, F2=0.9836, F3=0.9918, Mo0.1, Mo0.2)
{
dir <- runif(1) ### Determine which set of points
ker <- runif(1) ### Choose a kernel
if(ker < F1) {
### Kernel h1: Traverse
funh <- 1
if(dir < 0.5) {
beta <- Simfbeta(at)
tmp <- Simh1(dim, pphi, xp, x, beta)
yp <- tmp$rt
nphi <- tmp$nphi
y <- x
propU <- U
Mo1.2 <- try(Model(yp, Data),
silent=!Debug[["DB.Model"]])
check1 <- check2 <- FALSE
if(!inherits(Mo1.2, "try-error")) {
check1 <- TRUE
if(is.finite(Mo1.2[["LP"]]) &
identical(yp, as.vector(Mo1.2[["LP"]])))
check2 <- TRUE}
if(check1 & check2) {
propUp <- Mo1.2[["LP"]] * -1 ### Symmetric Proposal
if(nphi == 0)
A <- 1 ### Nothing moved
else
A <- exp((U - propU) + (Up - propUp) +
(nphi-2)*log(beta))}
else {
propUp <- NULL
A <- 0 ### Out of support, not accepted
}
}
else {
beta <- Simfbeta(at)
tmp <- Simh1(dim, pphi, x, xp, beta)
y <- tmp$rt
nphi <- tmp$nphi
yp <- xp
propUp <- Up
Mo1.1 <- try(Model(y, Data),
silent=!Debug[["DB.Model"]])
check1 <- check2 <- FALSE
if(!inherits(Mo1.1, "try-error")) {
check1 <- TRUE
if(is.finite(Mo1.1[["LP"]]) &
identical(y, as.vector(Mo1.1[["parm"]])))
check2 <- TRUE}
if(check1 & check2) {
propU <- Mo1.1[["LP"]] * -1 ### Symmetric Proposal
if(nphi == 0)
A <- 1 ### Nothing moved
else
A <- exp((U - propU) + (Up - propUp) +
(nphi-2)*log(beta))}
else {
propU <- NULL
A <- 0 ### Out of support, not accepted
}
}
}
else if(ker < F2) {
### Kernel h2: Walk
funh <- 2
if(dir < 0.5) {
### x as pivot
tmp <- Simh2(dim, pphi, aw, xp, x)
yp <- tmp$rt
nphi <- tmp$nphi
y <- x
propU <- U
Mo1.2 <- try(Model(yp, Data),
silent=!Debug[["DB.Model"]])
check1 <- check2 <- FALSE
if(!inherits(Mo1.2, "try-error")) {
check1 <- TRUE
if(is.finite(Mo1.2[["LP"]]) &
identical(yp, as.vector(Mo1.2[["parm"]])))
check2 <- TRUE}
if(check1 & check2 & !identical(yp, y)) {
propUp <- Mo1.2[["LP"]] * -1
A <- exp((U - propU) + (Up - propUp))}
else {
propUp <- NULL
A <- 0 ### Out of support, not accepted
}
}
else {
### xp as pivot
tmp <- Simh2(dim, pphi, aw, x, xp)
y <- tmp$rt
nphi <- tmp$nphi
yp <- xp
propUp <- Up
Mo1.1 <- try(Model(y, Data),
silent=!Debug[["DB.Model"]])
check1 <- check2 <- FALSE
if(!inherits(Mo1.1, "try-error")) {
check1 <- TRUE
if(is.finite(Mo1.1[["LP"]]) &
identical(y, as.vector(Mo1.1[["parm"]])))
check2 <- TRUE}
if(check1 & check2 & !identical(yp, y)) {
propU <- Mo1.1[["LP"]] * -1
A <- exp((U - propU) + (Up - propUp))}
else {
propU <- NULL
A <- 0 ### Out of support, not accepted
}
}
}
else if(ker < F3) {
### Kernel h3: Blow
funh <- 3
if(dir < 0.5) {
### x as pivot
tmp <- Simh3(dim, pphi, xp, x)
yp <- tmp$rt
nphi <- tmp$nphi
sigma <- tmp$sigma
y <- x
propU <- U
Mo1.2 <- try(Model(yp, Data),
silent=!Debug[["DB.Model"]])
check1 <- check2 <- FALSE
if(!inherits(Mo1.2, "try-error")) {
check1 <- TRUE
if(is.finite(Mo1.2[["LP"]]) &
identical(yp, as.vector(Mo1.2[["parm"]])))
check2 <- TRUE}
if(check1 & check2 & !identical(yp, x)) {
propUp <- Mo1.2[["LP"]] * -1
W1 <- G3U(nphi, sigma, yp, xp, x)
W2 <- G3U(nphi, sigma, xp, yp, x)
A <- exp((U - propU) + (Up - propUp) + (W1 - W2))}
else {
propUp <- NULL
A <- 0 ### Out of support, not accepted
}
}
else {
### xp as pivot
tmp <- Simh3(dim, pphi, x, xp)
y <- tmp$rt
nphi <- tmp$nphi
sigma <- tmp$sigma
yp <- xp
propUp <- Up
Mo1.1 <- try(Model(y, Data),
silent=!Debug[["DB.Model"]])
check1 <- check2 <- FALSE
if(!inherits(Mo1.1, "try-error")) {
check1 <- TRUE
if(is.finite(Mo1.1[["LP"]]) &
identical(y, as.vector(Mo1.1[["parm"]])))
check2 <- TRUE}
if(check1 & check2 & !identical(y, xp)) {
propU <- Mo1.1[["LP"]] * -1
W1 <- G3U(nphi, sigma, y, x, xp)
W2 <- G3U(nphi, sigma, x, y, xp)
A <- exp((U - propU) + (Up - propUp) + (W1 - W2))}
else {
propU <- NULL
A <- 0 ### Out of support, not accepted
}
}
}
else {
## Kernel h4: Hop
funh <- 4
if(dir < 0.5) {
### x as pivot
tmp <- Simh4(dim, pphi, xp, x)
yp <- tmp$rt
nphi <- tmp$nphi
sigma <- tmp$sigma
y <- x
propU <- U
Mo1.2 <- try(Model(yp, Data),
silent=!Debug[["DB.Model"]])
check1 <- check2 <- FALSE
if(!inherits(Mo1.2, "try-error")) {
check1 <- TRUE
if(is.finite(Mo1.2[["LP"]]) &
identical(yp, as.vector(Mo1.2[["parm"]])))
check2 <- TRUE}
if(check1 & check2 & !identical(yp, x)) {
propUp <- Mo1.2[["LP"]] * -1
W1 <- G4U(nphi, sigma, yp, xp, x)
W2 <- G4U(nphi, sigma, xp, yp, x)
A <- exp((U - propU) + (Up - propUp) + (W1 - W2))}
else {
propUp <- NULL
A <- 0 ### Out of support, not accepted
}
}
else {
### xp as pivot
tmp <- Simh4(dim, pphi, x, xp)
y <- tmp$rt
nphi <- tmp$nphi
sigma <- tmp$sigma
yp <- xp
propUp <- Up
Mo1.1 <- try(Model(y, Data),
silent=!Debug[["DB.Model"]])
check1 <- check2 <- FALSE
if(!inherits(Mo1.1, "try-error")) {
check1 <- TRUE
if(is.finite(Mo1.1[["LP"]]) &
identical(y, as.vector(Mo1.1[["parm"]])))
check2 <- TRUE}
if(check1 & check2 & !identical(y, xp)) {
propU <- Mo1.1[["LP"]] * -1
W1 <- G4U(nphi, sigma, y, x, xp)
W2 <- G4U(nphi, sigma, x, y, xp)
A <- exp((U - propU) + (Up - propUp) + (W1 - W2))}
else {
propU <- NULL
A <- 0 ### Out of support, not accepted
}
}
}
if(check1 & check2 & is.finite(A) & (dir < 0.5))
Mo0.2 <- Mo1.2
else if(check1 & check2 & is.finite(A) & (dir >= 0.5))
Mo0.1 <- Mo1.1
else if(!is.finite(A)) A <- 0
return(list(y=y, propU=propU, yp=yp, propUp=propUp, A=A,
funh=funh, nphi=nphi, Mo0.1=Mo0.1, Mo0.2=Mo0.2))
}
Runtwalk <- function(Iterations, dim, x0, xp0, pphi, at, aw,
F1=0.4918, F2=F1+0.4918, F3=F2+0.0082, Model, Data, Status,
Thinning, Acceptance, Dev, Mon, Mo0, thinned, Debug, LogFile)
{
x <- x0 ### Primary vector of initial values
xp <- xp0 ### Secondary vector of initial values
Mo0.1 <- try(Model(x, Data), silent=!Debug[["DB.Model"]])
Mo0.2 <- try(Model(xp, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo0.1, "try-error") | inherits(Mo0.2, "try-error"))
stop("Error in estimating the log-posterior.",
file=LogFile, append=TRUE)
if(any(!is.finite(c(Mo0.1[["LP"]], Mo0.2[["LP"]]))))
stop("The log-posterior is non-finite.", file=LogFile,
append=TRUE)
if(identical(x, as.vector(Mo0.1[["parm"]])) &
identical(xp, as.vector(Mo0.2[["parm"]]))) {
U <- Mo0.1[["LP"]] * -1
Up <- Mo0.2[["LP"]] * -1}
else {
cat("\nInitial values are out of support.", file=LogFile,
append=TRUE)
cat("\n Initial.Values=", x, file=LogFile, append=TRUE)
cat("\n SIV=", xp, file=LogFile, append=TRUE)
stop("Try re-specifying initial values.", file=LogFile,
append=TRUE)}
if(any(abs(x - xp) <= 0))
stop("\nBoth vectors of initial values are not unique.",
file=LogFile, append=TRUE)
Acceptance <- 0
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate Subset, LP: ",
round(Mo0.1[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Assign x and xp
x <- as.vector(Mo0.1[["parm"]])
xp <- as.vector(Mo0.2[["parm"]])
### Propose New Parameter Values
move <- OneMove(dim=dim, Model, Data, x, U, xp, Up,
at=at, aw=aw, pphi=pphi, F1=F1, F2=F2, F3=F3,
Mo0.1=Mo0.1, Mo0.2=Mo0.2)
### Accept/Reject
if(runif(1) < move$A) {
Mo0.1 <- move$Mo0.1
Mo0.2 <- move$Mo0.2
Acceptance <- Acceptance + 1 #move$nphi/dim
x <- move$y
U <- move$propU
xp <- move$yp
Up <- move$propUp
}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0.1[["parm"]]
Dev[t.iter] <- Mo0.1[["Dev"]]
Mon[t.iter,] <- Mo0.1[["Monitor"]]}
}
out <- list(Acceptance=Acceptance,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=.colVars(thinned))
return(out)
}
out <- Runtwalk(Iterations=Iterations, dim=LIV, x0=Mo0[["parm"]],
xp0=xp0, pphi=min(LIV, n1)/LIV, at=6, aw=1.5, Model=Model,
Data=Data, Status=Status, Thinning=Thinning,
Acceptance=Acceptance, Dev=Dev, Mon=Mon, Mo0=Mo0,
thinned=thinned, Debug=Debug, LogFile=LogFile)
### Output
return(out)
}
.mcmcuess <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned,
VarCov, Debug, LogFile)
{
A <- Specs[["A"]]
Block <- Specs[["B"]]
m <- Specs[["m"]]
n <- Specs[["n"]]
w <- 0.05
B <- length(Block)
if(B == 0) {
if(!is.symmetric.matrix(VarCov)) {
cat("\nAsymmetric Covar, correcting now...\n", file=LogFile,
append=TRUE)
VarCov <- as.symmetric.matrix(VarCov)}
if(!is.positive.definite(VarCov)) {
cat("\nNon-Positive-Definite Covar, correcting now...\n",
file=LogFile, append=TRUE)
VarCov <- as.positive.definite(VarCov)}
decomp.freq <- max(LIV * floor(Iterations / Thinning / 100), 10)
cat("\nEigendecomposition will occur every", decomp.freq,
"iterations.\n\n", file=LogFile, append=TRUE)
S.eig <-try(eigen(VarCov), silent=!Debug[["DB.eigen"]])
if(inherits(S.eig, "try-error")) S.eig <- NULL
obs.sum <- matrix(Mo0[["parm"]]*n, LIV, 1)
obs.scatter <- tcrossprod(Mo0[["parm"]])*n
DiagCovar <- matrix(diag(VarCov), floor(Iterations/Thinning)+1,
LIV, byrow=TRUE)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Multivariate, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Eigenvectors of the Sample Covariance Matrix
if({iter %% decomp.freq == 0} & {iter > 1} & {iter < A}) {
VarCov <- obs.scatter/{n + iter} -
tcrossprod(obs.sum/{n + iter})
S.eig <- eigen(VarCov)}
### Non-Adaptive or Adaptive
if(runif(1) < w || is.null(S.eig)) {
v <- rnorm(LIV)
v <- v / sqrt(sum(v*v))
}
else {
which.eig <- floor(1 + LIV * runif(1))
v <- S.eig$vectors[,which.eig] *
sqrt(abs(S.eig$values[which.eig]))}
### Slice Interval
Mo0.1 <- try(Model(Mo0[["parm"]], Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo0.1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(Mo0[["parm"]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo0.1 <- Mo0}
Mo0 <- Mo0.1
y.slice <- Mo0[["LP"]] - rexp(1)
L <- -runif(1)
U <- L + 1
if(m > 0) {
L.y <- try(Model(Mo0[["parm"]] + v*L, Data)[["LP"]],
silent=!Debug[["DB.Model"]])
if(inherits(L.y, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out the lower",
"bound failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(Mo0[["parm"]] + v*L,
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
L.y <- Mo0[["LP"]]
}
else if(!is.finite(L.y)) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out the lower",
"bound resulted in non-finite LP.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(Mo0[["parm"]] + v*L,
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
L.y <- Mo0[["LP"]]}
U.y <- try(Model(Mo0[["parm"]] + v*U, Data)[["LP"]],
silent=!Debug[["DB.Model"]])
if(inherits(U.y, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out the upper",
"bound failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(Mo0[["parm"]] + v*U,
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
U.y <- Mo0[["LP"]]
}
else if(!is.finite(U.y)) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out the upper",
"bound resulted in non-finite LP.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(Mo0[["parm"]] + v*U,
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
U.y <- Mo0[["LP"]]}
step <- 0
while({L.y > y.slice || U.y > y.slice} && step < m) {
step <- step + 1
if(runif(1) < 0.5) {
L <- L - 1
L.y <- try(Model(Mo0[["parm"]] + v*L,
Data)[["LP"]], silent=!Debug[["DB.Model"]])
if(inherits(L.y, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out the lower",
"bound failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(Mo0[["parm"]] +
v*L, collapse=","),")",sep=""),
"\n", file=LogFile, append=TRUE)}
L.y <- Mo0[["LP"]]
}
else if(!is.finite(L.y)) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out the lower",
"bound resulted in non-finite LP.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(Mo0[["parm"]] +
v*L, collapse=","),")",sep=""),
"\n", file=LogFile, append=TRUE)}
L.y <- Mo0[["LP"]]
}
}
else {
U <- U + 1
U.y <- try(Model(Mo0[["parm"]] + v*U,
Data)[["LP"]], silent=!Debug[["DB.Model"]])
if(inherits(U.y, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out the upper",
"bound failed.\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(Mo0[["parm"]] +
v*U, collapse=","),")",sep=""),
"\n", file=LogFile, append=TRUE)}
U.y <- Mo0[["LP"]]
}
else if(!is.finite(U.y)) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out the upper",
"bound resulted in non-finite LP.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(Mo0[["parm"]] +
v*U, collapse=","),")",sep=""),
"\n", file=LogFile, append=TRUE)}
U.y <- Mo0[["LP"]]}}}}
### Rejection Sampling
repeat {
prop.offset <- runif(1, min=L, max=U)
prop <- Mo0[["parm"]] + prop.offset * v
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Rejection sampling failed.\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Rejection sampling resulted",
"in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop, collapse=","),")",
sep=""), "\n", file=LogFile, append=TRUE)}
Mo1 <- Mo0}
prop <- Mo1[["parm"]]
if(Mo1[["LP"]] >= y.slice) break
else if(abs(prop.offset < 1e-100)) {
Mo1 <- Mo0
break}
if(prop.offset < 0) L <- prop.offset
else U <- prop.offset}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo1[["parm"]]
Dev[t.iter] <- Mo1[["Dev"]]
Mon[t.iter,] <- Mo1[["Monitor"]]
DiagCovar[t.iter,] <- diag(S.eig$vectors)}
obs.sum <- obs.sum + Mo1[["parm"]]
obs.scatter <- obs.scatter + tcrossprod(Mo1[["parm"]])
Mo0 <- Mo1}
}
else {
if(!identical(length(VarCov), B))
stop("Number of components in Covar differs from ",
"number of blocks.", file=LogFile, append=TRUE)
S.eig <- obs.sum <- obs.scatter <- list()
decomp.freq <- rep(0, length(B))
DiagCovar <- rep(0, LIV)
for (b in 1:B) {
if(!identical(length(Block[[b]]), length(diag(VarCov[[b]]))))
stop("Diagonal of Covar[[",b,"]] differs from block ",
"length.", file=LogFile, append=TRUE)
if(!is.symmetric.matrix(VarCov[[b]])) {
cat("\nAsymmetric Covar block, correcting now...\n",
file=LogFile, append=TRUE)
VarCov[[b]] <- as.symmetric.matrix(VarCov[[b]])}
if(!is.positive.definite(VarCov[[b]])) {
cat("\nNon-Positive-Definite Covar block,",
"correcting now...\n", file=LogFile, append=TRUE)
VarCov[[b]] <- as.positive.definite(VarCov[[b]])}
decomp.freq[b] <- max(length(Block[[b]]) *
floor(Iterations / Thinning / 100), 10)
S.eig[[b]] <-try(eigen(VarCov[[b]]),
silent=!Debug[["DB.eigen"]])
if(inherits(S.eig[[b]], "try-error")) S.eig[[b]] <- NULL
obs.sum[[b]] <- matrix(Mo0[["parm"]][Block[[b]]]*n,
length(Block[[b]]), 1)
obs.scatter[[b]] <- tcrossprod(Mo0[["parm"]][Block[[b]]])*n
DiagCovar[Block[[b]]] <- diag(VarCov[[b]])}
if(all(decomp.freq == decomp.freq[1]))
cat("\nEigendecomposition will occur every", decomp.freq[1],
"iterations.\n\n", file=LogFile, append=TRUE)
else cat("\nEigendecomposition frequency varies by block,",
"and will occur between\n",
min(decomp.freq), "and", max(decomp.freq),
"iterations.\n\n", file=LogFile, append=TRUE)
DiagCovar <- matrix(DiagCovar, floor(Iterations / Thinning)+1,
LIV, byrow=TRUE)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Blockwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Proceed by Block
for (b in 1:B) {
### Eigenvectors of the Sample Covariance Matrix
if({iter %% decomp.freq[b] == 0} & {iter > 1} &
{iter < A}) {
VarCov[[b]] <- obs.scatter[[b]]/{n + iter} -
tcrossprod(obs.sum[[b]]/{n + iter})
S.eig[[b]] <- eigen(VarCov[[b]])}
### Non-Adaptive or Adaptive
if(runif(1) < w || is.null(S.eig[[b]])) {
v <- rnorm(length(Block[[b]]))
v <- v / sqrt(sum(v*v))
}
else {
which.eig <- floor(1 + length(Block[[b]]) * runif(1))
v <- S.eig[[b]]$vectors[,which.eig] *
sqrt(abs(S.eig[[b]]$values[which.eig]))}
### Slice Interval
Mo0.1 <- try(Model(Mo0[["parm"]][Block[[b]]], Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo0.1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal for block", b,
"failed.\n", file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(Mo0[["parm"]][Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo0.1 <- Mo0}
Mo0 <- Mo0.1
y.slice <- Mo0[["LP"]] - rexp(1)
L <- -runif(1)
U <- L + 1
if(m > 0) {
prop <- Mo0[["parm"]]
prop[Block[[b]]] <- prop[Block[[b]]] + v*L
L.y <- try(Model(prop, Data)[["LP"]],
silent=!Debug[["DB.Model"]])
if(inherits(L.y, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out the lower",
"bound failed for block", b, ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
L.y <- Mo0[["LP"]]
}
else if(!is.finite(L.y)) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out the lower",
"bound resulted in non-finite LP",
"for block", b, ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
L.y <- Mo0[["LP"]]}
prop <- Mo0[["parm"]]
prop[Block[[b]]] <- prop[Block[[b]]] + v*U
U.y <- try(Model(prop, Data)[["LP"]],
silent=!Debug[["DB.Model"]])
if(inherits(U.y, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out the upper",
"bound failed for block", b, ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
U.y <- Mo0[["LP"]]
}
else if(!is.finite(U.y)) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out the upper",
"bound resulted in non-finite LP",
"for block", b, ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
U.y <- Mo0[["LP"]]}
step <- 0
while({L.y > y.slice || U.y > y.slice} && step < m) {
step <- step + 1
if(runif(1) < 0.5) {
L <- L - 1
prop <- Mo0[["parm"]]
prop[Block[[b]]] <- prop[Block[[b]]] + v*L
L.y <- try(Model(prop, Data)[["LP"]],
silent=!Debug[["DB.Model"]])
if(inherits(L.y, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out the",
"lower bound failed for",
"block", b, ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Proposal:\n", paste("c(",
paste(prop[Block[[b]]],
collapse=","),")",sep=""),
"\n", file=LogFile,
append=TRUE)}
L.y <- Mo0[["LP"]]
}
else if(!is.finite(L.y)) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out the",
"lower bound resulted in ",
"non-finite LP for block",
b, ".\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter,
"Proposal:\n", paste("c(",
paste(prop[Block[[b]]],
collapse=","),")",sep=""),
"\n", file=LogFile,
append=TRUE)}
L.y <- Mo0[["LP"]]
}
}
else {
U <- U + 1
prop <- Mo0[["parm"]]
prop[Block[[b]]] <- prop[Block[[b]]] + v*U
U.y <- try(Model(prop, Data)[["LP"]],
silent=!Debug[["DB.Model"]])
if(inherits(U.y, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out the",
"upper bound failed for",
"block", b, ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Proposal:\n", paste("c(",
paste(prop[Block[[b]]],
collapse=","),")",sep=""),
"\n", file=LogFile,
append=TRUE)}
U.y <- Mo0[["LP"]]
}
else if(!is.finite(U.y)) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Stepping out the",
"upper bound resulted in",
"non-finite LP for block",
b, ".\n", file=LogFile,
append=TRUE)
cat(" Iteration:", iter,
"Proposal:\n", paste("c(",
paste(prop[Block[[b]]],
collapse=","),")",sep=""),
"\n", file=LogFile,
append=TRUE)}
U.y <- Mo0[["LP"]]}}}}
### Rejection Sampling
repeat {
prop.offset <- runif(1, min=L, max=U)
prop <- Mo0[["parm"]]
prop[Block[[b]]] <- prop[Block[[b]]] + prop.offset*v
Mo1 <- try(Model(prop, Data),
silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Rejection sampling",
"failed for block", b, ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Rejection sampling",
"resulted in non-finite",
"value(s) for block", b, ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter, "Proposal:\n",
paste("c(",paste(prop[Block[[b]]],
collapse=","),")",sep=""), "\n",
file=LogFile, append=TRUE)}
Mo1 <- Mo0}
prop <- Mo1[["parm"]]
if(Mo1[["LP"]] >= y.slice) break
else if(abs(prop.offset < 1e-100)) {
Mo1 <- Mo0
break}
if(prop.offset < 0) L <- prop.offset
else U <- prop.offset}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo1[["parm"]]
Dev[t.iter] <- Mo1[["Dev"]]
Mon[t.iter,] <- Mo1[["Monitor"]]
DiagCovar[t.iter,Block[[b]]] <- diag(S.eig[[b]]$vectors)}
obs.sum[[b]] <- obs.sum[[b]] + Mo1[["parm"]][Block[[b]]]
obs.scatter[[b]] <- obs.scatter[[b]] +
tcrossprod(Mo1[["parm"]][Block[[b]]])
Mo0 <- Mo1}
}
}
### Output
out <- list(Acceptance=Iterations,
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=VarCov)
return(out)
}
.mcmcusamwg <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, tuning,
parm.names, Debug, LogFile)
{
Dyn <- Specs[["Dyn"]]
Periodicity <- Specs[["Periodicity"]]
Fit <- Specs[["Fit"]]
Begin <- Specs[["Begin"]]
Acceptance <- matrix(0, 1, LIV)
for (k in 1:ncol(Dyn)) {for (t in 1:nrow(Dyn)) {
Dyn[t,k] <- which(parm.names == Dyn[t,k])}}
Dyn <- matrix(as.numeric(Dyn), nrow(Dyn), ncol(Dyn))
Dyn <- matrix(Dyn[-c(1:(Begin-1)),], nrow(Dyn)-Begin+1, ncol(Dyn))
n.samples <- nrow(Fit$Posterior1)
mults <- Iterations / n.samples
samps <- rep(1:n.samples, each=mults)
if(Iterations != length(samps))
stop("Iterations not a multiple of posterior samples.",
file=LogFile, append=TRUE)
ivs <- Mo0[["parm"]]
post <- Fit$Posterior1[samps,]
post[1,as.vector(Dyn)] <- ivs[as.vector(Dyn)]
DiagCovar <- matrix(tuning, floor(Iterations/Periodicity), LIV,
byrow=TRUE)
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Store Current Posterior
if(iter > 1) post[iter,as.vector(Dyn)] <- post[iter-1,as.vector(Dyn)]
### Select Order of Parameters
if(ncol(Dyn) == 1) dynsample <- sample(Dyn)
else dynsample <- as.vector(apply(Dyn, 1, sample))
### Componentwise Estimation
for (j in dynsample) {
### Propose new parameter values
prop <- post[iter,]
prop[j] <- rnorm(1, prop[j], tuning[j])
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed for",
Data[["parm.names"]][j], ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
u <- log(runif(1)) < (Mo1[["LP"]] - Mo0[["LP"]])
if(u == TRUE) {
Mo0 <- Mo1
post[iter,] <- Mo0[["parm"]]
Acceptance[j] <- Acceptance[j] + 1}}}
### Adapt the Proposal Variance
if(iter %% Periodicity == 0) {
size <- 1 / min(100, sqrt(iter))
Acceptance.Rate <- Acceptance / iter
log.tuning <- log(tuning)
tuning.num <- which(Acceptance.Rate > 0.44)
log.tuning[tuning.num] <- log.tuning[tuning.num] + size
log.tuning[-tuning.num] <- log.tuning[-tuning.num] - size
tuning <- exp(log.tuning)
a.iter <- floor(iter / Periodicity)
DiagCovar[a.iter,] <- tuning}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- post[iter,]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=mean(as.vector(Acceptance[dynsample])),
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=tuning)
return(out)
}
.mcmcusmwg <- function(Model, Data, Iterations, Status, Thinning, Specs,
Acceptance, Dev, DiagCovar, LIV, Mon, Mo0, ScaleF, thinned, tuning,
parm.names, Debug, LogFile)
{
Dyn <- Specs[["Dyn"]]
Fit <- Specs[["Fit"]]
Begin <- Specs[["Begin"]]
Acceptance <- matrix(0, 1, LIV)
for (k in 1:ncol(Dyn)) {for (t in 1:nrow(Dyn)) {
Dyn[t,k] <- which(parm.names == Dyn[t,k])}}
Dyn <- matrix(as.numeric(Dyn), nrow(Dyn), ncol(Dyn))
Dyn <- matrix(Dyn[-c(1:(Begin-1)),], nrow(Dyn)-Begin+1, ncol(Dyn))
n.samples <- nrow(Fit$Posterior1)
mults <- Iterations / n.samples
samps <- rep(1:n.samples, each=mults)
if(Iterations != length(samps))
stop("Iterations not a multiple of posterior samples.",
file=LogFile, append=TRUE)
ivs <- Mo0[["parm"]]
post <- Fit$Posterior1[samps,]
post[1,as.vector(Dyn)] <- ivs[as.vector(Dyn)]
for (iter in 1:Iterations) {
### Print Status
if(iter %% Status == 0)
cat("Iteration: ", iter,
", Proposal: Componentwise, LP: ",
round(Mo0[["LP"]],1), "\n", sep="",
file=LogFile, append=TRUE)
### Store Current Posterior
if(iter > 1) post[iter,as.vector(Dyn)] <- post[iter-1,as.vector(Dyn)]
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
### Select Order of Parameters
if(ncol(Dyn) == 1) dynsample <- sample(Dyn)
else dynsample <- as.vector(apply(Dyn, 1, sample))
### Componentwise Estimation
for (j in dynsample) {
### Propose new parameter values
prop <- post[iter,]
prop[j] <- rnorm(1, prop[j], tuning[j])
### Log-Posterior of the proposed state
Mo1 <- try(Model(prop, Data), silent=!Debug[["DB.Model"]])
if(inherits(Mo1, "try-error")) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal failed for",
Data[["parm.names"]][j], ".\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else if(any(!is.finite(c(Mo1[["LP"]], Mo1[["Dev"]],
Mo1[["Monitor"]])))) {
if(Debug[["DB.Model"]] == TRUE) {
cat("\nWARNING: Proposal for",
Data[["parm.names"]][j],
"resulted in non-finite value(s).\n",
file=LogFile, append=TRUE)
cat(" Iteration:", iter,
"Current:", round(Mo0[["parm"]][j]),
"Proposed:", round(prop[j],5),
file=LogFile, append=TRUE)}
Mo1 <- Mo0
}
else {
### Accept/Reject
u <- log(runif(1)) < (Mo1[["LP"]] - Mo0[["LP"]])
if(u == TRUE) {
Mo0 <- Mo1
post[iter,] <- Mo0[["parm"]]
Acceptance[j] <- Acceptance[j] + 1}}}
### Save Thinned Samples
if(iter %% Thinning == 0) {
t.iter <- floor(iter / Thinning) + 1
thinned[t.iter,] <- Mo0[["parm"]]
Dev[t.iter] <- Mo0[["Dev"]]
Mon[t.iter,] <- Mo0[["Monitor"]]}
}
### Output
out <- list(Acceptance=mean(as.vector(Acceptance[dynsample])),
Dev=Dev,
DiagCovar=DiagCovar,
Mon=Mon,
thinned=thinned,
VarCov=tuning)
return(out)
}
#End
Try the LaplacesDemon package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.