From 3f97fc0e877a4705fdcff3ae0bd725e07d8c3762 Mon Sep 17 00:00:00 2001 From: Tahmina Mojumder Date: Fri, 25 Aug 2023 14:04:21 +0200 Subject: [PATCH 01/13] Updated some functions starting with b and c. --- BayesianTools/R/blockUpdate.R | 181 ++++++++++++++++---------------- BayesianTools/R/codaFunctions.R | 118 ++++++++++----------- BayesianTools/R/convertCoda.R | 105 +++++++++--------- 3 files changed, 200 insertions(+), 204 deletions(-) diff --git a/BayesianTools/R/blockUpdate.R b/BayesianTools/R/blockUpdate.R index e63fbc4..ec3d9f3 100644 --- a/BayesianTools/R/blockUpdate.R +++ b/BayesianTools/R/blockUpdate.R @@ -1,91 +1,90 @@ - -#' Determine the groups of correlated parameters -#' @author Stefan Paul -#' @param chain MCMC chain including only the parameters (not logP,ll, logP) -#' @param blockSettings list with settings -#' @return groups -#' @keywords internal -updateGroups <- function(chain,blockSettings){ - - settings <- getBlockSettings(blockSettings) - blockUpdateType <- settings$blockUpdateType - - switch(blockUpdateType, - "correlation" = { - ## (Pair wise) Correlation in the parameters - cormat <- abs(cor(chain[,1:(ncol(chain)-3),sample(1:dim(chain)[3],1)])) - diag(cormat) <- 0 - # Correct for NA and Inf values as this could cause error in as.dist() - cormat[c(which(is.na(cormat)),which(cormat == Inf),which(cormat == -Inf)) ] <- 0 - tree <- hclust(as.dist(1-cormat)) # get tree based on distance(dissimilarity = 1-cor). - cT <- cutree(tree, k = settings$k, h = settings$h) # get groups. With h we can manipulate the strength of the interaction. - }, - "user" = { - cT <- settings$groups - }, - "random" = { - pool <- c(1:settings$k, sample(1:settings$k, (ncol(chain)-3-settings$k))) - cT <- sample(pool) - } - ) - - pSel <- settings$pSel - if(is.null(pSel) && is.null(settings$pGroup)) pSel = rep(1,ncol(chain)-3) - return(list(cT = cT, pGroup = settings$pGroup, pSel = pSel)) -} - - -#' Determine the parameters in the block update -#' @param blockSettings settings for block update -#' @return vector containing the parameter to be updated -#' @keywords internal -getBlock <- function(blockSettings){ - groups <- blockSettings$cT - pGroup <- blockSettings$pGroup - pSel <- blockSettings$pSel - - - nGroups = max(groups) - if(nGroups == 1) return(1:length(groups)) - if (is.null(pGroup)) pGroup = rep(1,nGroups) - if(length(pSel) > nGroups) pSel <- pSel[1:nGroups] - pSel = c(pSel, rep(0,nGroups - length(pSel))) - groupsToSample = sample.int(nGroups, 1, prob = pSel) - - selectedGroups = sample.int(nGroups,groupsToSample, prob = pGroup[1:nGroups]) - GroupMember <- which(is.element(groups,selectedGroups)) - return(GroupMember) - -} - - -#' getblockSettings -#' @description Transforms the original settings in settings used in the model runs -#' @param blockUpdate input settings -#' @return list with block settings -#' @keywords internal -getBlockSettings <- function(blockUpdate){ - - h <- k <- pSel <- pGroup <- groups <- NULL - blockUpdateType <- blockUpdate[[1]] - - switch(blockUpdateType, - "correlation" = { - h <- blockUpdate$h - k <- blockUpdate$k - pSel <- blockUpdate$pSel - pGroup <- blockUpdate$pGroup - }, - "random"={ - k <- blockUpdate$k - }, - "user"= { - groups <- blockUpdate$groups - pSel <- blockUpdate$pSel - pGroup <- blockUpdate$pGroup - }) - - return(list(blockUpdateType = blockUpdateType, h = h, k = k, pSel = pSel, - pGroup = pGroup, groups = groups)) - } - +#' Determine the groups of correlated parameters +#' @author Stefan Paul +#' @param chain MCMC chain including only the parameters (not logP,ll, logP) +#' @param blockSettings a list with settings +#' @return groups +#' @keywords internal +updateGroups <- function(chain,blockSettings){ + + settings <- getBlockSettings(blockSettings) + blockUpdateType <- settings$blockUpdateType + + switch(blockUpdateType, + "correlation" = { + ## (Pair wise) Correlation in the parameters + cormat <- abs(cor(chain[,1:(ncol(chain)-3),sample(1:dim(chain)[3],1)])) + diag(cormat) <- 0 + # Correct for NA and Inf values as this could cause error in as.dist() + cormat[c(which(is.na(cormat)),which(cormat == Inf),which(cormat == -Inf)) ] <- 0 + tree <- hclust(as.dist(1-cormat)) # get tree based on distance(dissimilarity = 1-cor). + cT <- cutree(tree, k = settings$k, h = settings$h) # get groups. With h we can manipulate the strength of the interaction. + }, + "user" = { + cT <- settings$groups + }, + "random" = { + pool <- c(1:settings$k, sample(1:settings$k, (ncol(chain)-3-settings$k))) + cT <- sample(pool) + } + ) + + pSel <- settings$pSel + if(is.null(pSel) && is.null(settings$pGroup)) pSel = rep(1,ncol(chain)-3) + return(list(cT = cT, pGroup = settings$pGroup, pSel = pSel)) +} + + +#' Determine the parameters in the block update +#' @param blockSettings settings for block update +#' @return vector containing the parameter to be updated +#' @keywords internal +getBlock <- function(blockSettings){ + groups <- blockSettings$cT + pGroup <- blockSettings$pGroup + pSel <- blockSettings$pSel + + + nGroups = max(groups) + if(nGroups == 1) return(1:length(groups)) + if (is.null(pGroup)) pGroup = rep(1,nGroups) + if(length(pSel) > nGroups) pSel <- pSel[1:nGroups] + pSel = c(pSel, rep(0,nGroups - length(pSel))) + groupsToSample = sample.int(nGroups, 1, prob = pSel) + + selectedGroups = sample.int(nGroups,groupsToSample, prob = pGroup[1:nGroups]) + GroupMember <- which(is.element(groups,selectedGroups)) + return(GroupMember) + +} + + +#' getblockSettings +#' @description Transforms the original settings to settings used in the model runs +#' @param blockUpdate input settings +#' @return list with block settings +#' @keywords internal +getBlockSettings <- function(blockUpdate){ + + h <- k <- pSel <- pGroup <- groups <- NULL + blockUpdateType <- blockUpdate[[1]] + + switch(blockUpdateType, + "correlation" = { + h <- blockUpdate$h + k <- blockUpdate$k + pSel <- blockUpdate$pSel + pGroup <- blockUpdate$pGroup + }, + "random"={ + k <- blockUpdate$k + }, + "user"= { + groups <- blockUpdate$groups + pSel <- blockUpdate$pSel + pGroup <- blockUpdate$pGroup + }) + + return(list(blockUpdateType = blockUpdateType, h = h, k = k, pSel = pSel, + pGroup = pGroup, groups = groups)) + } + diff --git a/BayesianTools/R/codaFunctions.R b/BayesianTools/R/codaFunctions.R index 715d27d..234dcfb 100644 --- a/BayesianTools/R/codaFunctions.R +++ b/BayesianTools/R/codaFunctions.R @@ -1,59 +1,59 @@ -#' Function to combine chains -#' -#' @param x a list of MCMC chains -#' @param merge logical determines whether chains should be merged -#' @return combined chains -#' -#' @note to combine several chains to a single McmcSamplerList, see \code{\link{createMcmcSamplerList}} -#' -#' @keywords internal -combineChains <- function(x, merge = T){ - - if(merge == T){ - temp1 = as.matrix(x[[1]]) - - names = colnames(temp1) - - sel = seq(1, by = length(x), len = nrow(temp1) ) - - out = matrix(NA, nrow = length(x) * nrow(temp1), ncol = ncol(temp1)) - out[sel, ] = temp1 - if (length(x) > 1){ - for (i in 2:length(x)){ - out[sel+i-1, ] = as.matrix(x[[i]]) - } - } - - colnames(out) = names - - } else{ - - out = as.matrix(x[[1]]) - if (length(x) > 1){ - for (i in 2:length(x)){ - out = rbind(out, as.matrix(x[[i]])) - } - } - } - - return(out) -} - - - -#' Helper function to change an object to a coda mcmc class, -#' -#' @param chain mcmc Chain -#' @param start for mcmc samplers start value in the chain. For SMC samplers, start particle -#' @param end for mcmc samplers end value in the chain. For SMC samplers, end particle -#' @param thin thinning parameter -#' @return object of class coda::mcmc -#' @details Very similar to coda::mcmc but with less overhead -#' @keywords internal -makeObjectClassCodaMCMC <- function (chain, start = 1, end = numeric(0), thin = 1){ - attr(chain, "mcpar") <- c(start, end, thin) - attr(chain, "class") <- "mcmc" - chain -} - - +#' Function to combine chains +#' +#' @param x a list of MCMC chains +#' @param merge should chains be merged? (T or F) +#' @return combined chains +#' +#' @note to combine several chains to a single McmcSamplerList, see \code{\link{createMcmcSamplerList}} +#' +#' @keywords internal +combineChains <- function(x, merge = T){ + + if(merge == T){ + temp1 = as.matrix(x[[1]]) + + names = colnames(temp1) + + sel = seq(1, by = length(x), len = nrow(temp1) ) + + out = matrix(NA, nrow = length(x) * nrow(temp1), ncol = ncol(temp1)) + out[sel, ] = temp1 + if (length(x) > 1){ + for (i in 2:length(x)){ + out[sel+i-1, ] = as.matrix(x[[i]]) + } + } + + colnames(out) = names + + } else{ + + out = as.matrix(x[[1]]) + if (length(x) > 1){ + for (i in 2:length(x)){ + out = rbind(out, as.matrix(x[[i]])) + } + } + } + + return(out) +} + + + +#' Helper function to change an object to a coda mcmc class, +#' +#' @param chain mcmc Chain +#' @param start For MCMC samplers, the initial value in the chain. For SMC samplers, initial particle +#' @param end For MCMC samplers, the end value in the chain. For SMC samplers, end particle. +#' @param thin thinning parameter +#' @return object an object of class coda::mcmc +#' @details Very similar to coda::mcmc but with less overhead +#' @keywords internal +makeObjectClassCodaMCMC <- function (chain, start = 1, end = numeric(0), thin = 1){ + attr(chain, "mcpar") <- c(start, end, thin) + attr(chain, "class") <- "mcmc" + chain +} + + diff --git a/BayesianTools/R/convertCoda.R b/BayesianTools/R/convertCoda.R index b00739a..50d4add 100644 --- a/BayesianTools/R/convertCoda.R +++ b/BayesianTools/R/convertCoda.R @@ -1,55 +1,52 @@ - -#' Convert coda::mcmc objects to BayesianTools::mcmcSampler -#' @description Function is used to make the plot and diagnostic functions -#' available for coda::mcmc objects -#' @param sampler An object of class mcmc or mcmc.list -#' @param names vector giving the parameter names (optional) -#' @param info matrix (or list with matrices for mcmc.list objects) with three coloumns containing log posterior, log likelihood and log prior of the sampler for each time step (optional; but see Details) -#' @param likelihood likelihood function used in the sampling (see Details) -#' @details The parameter 'likelihood' is optional for most functions but can be needed e.g for -#' using the \code{\link{DIC}} function. -#' -#' Also the parameter info is optional for most uses. However for some functions (e.g. \code{\link{MAP}}) -#' the matrix or single coloumns (e.g. log posterior) are necessary for the diagnostics. -#' @export - -convertCoda <- function(sampler, names = NULL, info = NULL, likelihood = NULL){ - - likelihood <- list(density = likelihood) - - if(inherits(sampler, "mcmc")){ - - if(is.null(names)){ - names <- paste("Par",1:ncol(sampler)) - } - setup <- list(names = names, numPars = ncol(sampler), likelihood = likelihood) - - if(is.null(info)) info <- matrix(NA, nrow = nrow(sampler), ncol = 3) - out <- list(chain = cbind(sampler,info), setup = setup) - class(out) = c("mcmcSampler", "bayesianOutput") - - - }else{ if(inherits(sampler, "mcmc.list")){ - - if(is.null(names)){ - names <- paste("Par",1:ncol(sampler[[1]])) - } - setup <- list(names = names, numPars = ncol(sampler[[1]]), likelihood = likelihood) - - if(is.null(info)){ - info <- list() - for(i in 1:length(sampler)) info[[i]] <- matrix(NA, nrow = nrow(sampler[[1]]), ncol = 3) - } - - chain <- list() - for(i in 1:length(sampler)){ - chain[[i]] <- cbind(sampler[[i]], info[[i]]) - } - class(chain) = "mcmc.list" - out <- list(chain = chain, setup = setup) - class(out) = c("mcmcSampler", "bayesianOutput") - }else stop("sampler must be of class 'coda::mcmc' or 'coda::mcmc.list'") - } - return(out) - + +#' Convert coda::mcmc objects to BayesianTools::mcmcSampler +#' @description Function to support plotting and diagnostic functions for coda::mcmc objects. +#' @param sampler an object of class mcmc or mcmc.list +#' @param names a vector with parameter names (optional) +#' @param info a matrix (or list with matrices for mcmc.list objects) with three coloumns containing log posterior, log likelihood and log prior of the sampler for each time step (optional; but see Details) +#' @param likelihood likelihood function used for sampling (see Details) +#' @details The parameter 'likelihood' is optional for most functions but can be needed e.g for \code{\link{DIC}} function. +#' +#' Also, the parameter information is typically optional for most uses. However, for certain functions (e.g. \code{\link{MAP}}), the matrix or single columns (e.g. log posterior) are necessary for diagnostics. +#' @export + +convertCoda <- function(sampler, names = NULL, info = NULL, likelihood = NULL){ + + likelihood <- list(density = likelihood) + + if(inherits(sampler, "mcmc")){ + + if(is.null(names)){ + names <- paste("Par",1:ncol(sampler)) + } + setup <- list(names = names, numPars = ncol(sampler), likelihood = likelihood) + + if(is.null(info)) info <- matrix(NA, nrow = nrow(sampler), ncol = 3) + out <- list(chain = cbind(sampler,info), setup = setup) + class(out) = c("mcmcSampler", "bayesianOutput") + + + }else{ if(inherits(sampler, "mcmc.list")){ + + if(is.null(names)){ + names <- paste("Par",1:ncol(sampler[[1]])) + } + setup <- list(names = names, numPars = ncol(sampler[[1]]), likelihood = likelihood) + + if(is.null(info)){ + info <- list() + for(i in 1:length(sampler)) info[[i]] <- matrix(NA, nrow = nrow(sampler[[1]]), ncol = 3) + } + + chain <- list() + for(i in 1:length(sampler)){ + chain[[i]] <- cbind(sampler[[i]], info[[i]]) + } + class(chain) = "mcmc.list" + out <- list(chain = chain, setup = setup) + class(out) = c("mcmcSampler", "bayesianOutput") + }else stop("sampler must be of class 'coda::mcmc' or 'coda::mcmc.list'") + } + return(out) + } \ No newline at end of file From 53c164006139ce7d0845e2f33aa587740d223f8b Mon Sep 17 00:00:00 2001 From: Tahmina Mojumder Date: Fri, 25 Aug 2023 15:31:33 +0200 Subject: [PATCH 02/13] corrected a sepelling mistake. --- BayesianTools/R/convertCoda.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/BayesianTools/R/convertCoda.R b/BayesianTools/R/convertCoda.R index 50d4add..5aa453a 100644 --- a/BayesianTools/R/convertCoda.R +++ b/BayesianTools/R/convertCoda.R @@ -3,7 +3,7 @@ #' @description Function to support plotting and diagnostic functions for coda::mcmc objects. #' @param sampler an object of class mcmc or mcmc.list #' @param names a vector with parameter names (optional) -#' @param info a matrix (or list with matrices for mcmc.list objects) with three coloumns containing log posterior, log likelihood and log prior of the sampler for each time step (optional; but see Details) +#' @param info a matrix (or list with matrices for mcmc.list objects) with three columns containing log posterior, log likelihood and log prior of the sampler for each time step (optional; but see Details) #' @param likelihood likelihood function used for sampling (see Details) #' @details The parameter 'likelihood' is optional for most functions but can be needed e.g for \code{\link{DIC}} function. #' From a0f6d8673ae56953608805a107d96c7f97ac8a2b Mon Sep 17 00:00:00 2001 From: Tahmina Mojumder Date: Thu, 31 Aug 2023 10:21:25 +0200 Subject: [PATCH 03/13] Updated help file for functions whose name start with class. --- BayesianTools/R/classBayesianOutput.R | 504 +++++++++++------------ BayesianTools/R/classBayesianSetup.R | 402 +++++++++---------- BayesianTools/R/classLikelihood.R | 332 +++++++-------- BayesianTools/R/classMcmcSamplerList.R | 302 +++++++------- BayesianTools/R/classPosterior.R | 114 +++--- BayesianTools/R/classPrior.R | 532 ++++++++++++------------- BayesianTools/R/classSMCSamplerList.R | 116 +++--- 7 files changed, 1151 insertions(+), 1151 deletions(-) diff --git a/BayesianTools/R/classBayesianOutput.R b/BayesianTools/R/classBayesianOutput.R index 2bc278c..96c0583 100644 --- a/BayesianTools/R/classBayesianOutput.R +++ b/BayesianTools/R/classBayesianOutput.R @@ -1,252 +1,252 @@ -# NOTE: The functions in this class are just templates that are to be implemented for all subclasses of BayesianOutput. They are not functional. - - -#' Extracts the sample from a bayesianOutput -#' @author Florian Hartig -#' @param sampler an object of class mcmcSampler, mcmcSamplerList, smcSampler, smcSamplerList, mcmc, mcmc.list, double, numeric -#' @param parametersOnly for a BT output, if F, likelihood, posterior and prior values are also provided in the output -#' @param coda works only for mcmc classes - provides output as a coda object. Note: if mcmcSamplerList contains mcmc samplers such as DE that have several chains, the internal chains will be collapsed. This may not be the desired behavior for all applications. -#' @param start for mcmc samplers start value in the chain. For SMC samplers, start particle -#' @param end for mcmc samplers end value in the chain. For SMC samplers, end particle -#' @param thin thinning parameter. Either an integer determining the thinning intervall (default is 1) or "auto" for automatic thinning. -#' @param numSamples sample size (only used if thin = 1). If you want to use numSamples set thin to 1. -#' @param whichParameters possibility to select parameters by index -#' @param reportDiagnostics logical, determines whether settings should be included in the output -#' @param ... further arguments -#' @example /inst/examples/getSampleHelp.R -#' @details If thin is greater than the total number of samples in the sampler object the first and the last element (of each chain if a sampler with multiples chains is used) are sampled. If numSamples is greater than the total number of samples all samples are selected. In both cases a warning is displayed. -#' @details If thin and numSamples is passed, the function will use the thin argument if it is valid and greater than 1, else numSamples will be used. -#' @export -getSample <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = 1, numSamples = NULL, whichParameters = NULL, reportDiagnostics = FALSE, ...) UseMethod("getSample") - - - -#' @rdname getSample -#' @author Florian Hartig -#' @export -getSample.matrix <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ - - if(is.null(end)) end = nrow(sampler) - - out = sampler[start:end,, drop=F] - - ######################## - # THINNING - nTotalSamples <- nrow(out) - thin <- correctThin(nTotalSamples, thin = thin) - - if (thin == 1 && !is.null(numSamples)) { - out <- sampleEquallySpaced(out, numSamples) - } else { - sel = seq(1, nTotalSamples, by = thin) - out = out[sel,, drop=F] - } - - if (!is.null(whichParameters)) out = out[,whichParameters, drop = FALSE] - if(coda == T) out = makeObjectClassCodaMCMC(out, start = start, end = end, thin = thin) - - if(reportDiagnostics == T){ - return(list(chain = out, start = start, end = end, thin = thin)) - } else return(out) -} - - -#' @rdname getSample -#' @author Tankred Ott -#' @export -# TODO: This is right now only a helper function for getSample.mcmc. It is needed to return a vector istead of a matrix, if -# the mcmc object passed to getSample.mcmc contains a vector. -getSample.double <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ - if(is.null(end)) end = length(sampler) - out <- sampler[start:end] - - nTotalSamples <- length(out) - - thin = correctThin(nTotalSamples, thin) - - if (thin == 1 && !is.null(numSamples)) { - out <- sampleEquallySpaced(out, numSamples) - } else { - sel = seq(1, nTotalSamples, by = thin) - out = out[sel] - } - - return(out) -} - - -#' @rdname getSample -#' @author Tankred Ott -#' @export -# TODO: This is right now only a helper function for getSample.mcmc. It is needed to return a vector instead of a matrix, if -# the mcmc object passed to getSample.mcmc contains a vector. -getSample.integer <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ - if(is.null(end)) end = length(sampler) - out <- sampler[start:end] - - nTotalSamples <- length(out) - - thin = correctThin(nTotalSamples, thin) - - if (thin == 1 && !is.null(numSamples)) { - out <- sampleEquallySpaced(out, numSamples) - } else { - sel = seq(1, nTotalSamples, by = thin) - out = out[sel] - } - - return(out) -} - -#' @rdname getSample -#' @author Tankred Ott -#' @export -getSample.data.frame <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ - getSample(as.matrix(sampler), parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, whichParameters = whichParameters, reportDiagnostics = reportDiagnostics) -} - -#' @rdname getSample -#' @author Tankred Ott -#' @export -getSample.list <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ - - if(!is.null(numSamples)) numSamples = ceiling(numSamples/length(sampler)) - - if(coda == F){ - # out = NULL - out <- rep(list(NA), length(sampler)) - for (i in 1:length(sampler)){ - # out = rbind(out, getSample(sampler[[i]], parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics= F)) - out[[i]] <- getSample(sampler[[i]], parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics= F) - } - out <- combineChains(out) - } - - if(coda == T){ - - out = list() - - for (i in 1:length(sampler)){ - - out[[i]] = getSample(sampler[[i]], parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics= F) - } - - if(inherits(out[[1]], "mcmc.list")) out = unlist(out, recursive = F) - class(out) = "mcmc.list" - out = out - } - - return(out) -} - -# The following two S3 implementations make getSample compatible with coda::mcmc and coda::mcmc.list - -#' @rdname getSample -#' @author Tankred Ott -#' @export -getSample.mcmc <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ - - if(coda == T){ - # mcmc objects can contain matrices or vectors - if (is.matrix(sampler)) { - nTotalSamples <- nrow(sampler) - } else { - nTotalSamples <- length(sampler) - } - - if (is.null(end)) end = nTotalSamples - - # check/correct thin - thin <- correctThin(nTotalSamples, thin) - - # see http://svitsrv25.epfl.ch/R-doc/library/coda/html/window.mcmc.html - # for coda's window implementation - return(window(sampler, start = start, end = end, thin = thin)) - - } else if(coda == F){ - # mcmc objects can contain matrices or vectors - # TODO: do vector case as 1-d matrix? - if (is.matrix(sampler)) { - out <- getSample(as.matrix(sampler), parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics = reportDiagnostics) - } else { - out <- getSample(as.vector(sampler), parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics = reportDiagnostics) - } - return(out) - } -} - - -#' @author Tankred Ott -#' @rdname getSample -#' @export -getSample.mcmc.list <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ - - # TODO: implement handling of wrong inputs? - - if(coda == T){ - - if (is.matrix(sampler[[1]])) { - nTotalSamples <- nrow(sampler[[1]]) - } else { - nTotalSamples <- length(sampler[[1]]) - } - - if (is.null(end)) end = nTotalSamples - - # check/correct thin - thin <- correctThin(nTotalSamples, thin) - - # see http://svitsrv25.epfl.ch/R-doc/library/coda/html/window.mcmc.html - # for coda's window implementation - return(window(sampler, start = start, end = end, thin = thin)) - - } else if(coda == F){ - if(is.matrix(sampler[[1]])) { - return(getSample(combineChains(sampler), parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics = reportDiagnostics)) - } else { - return(as.vector(getSample(combineChains(sampler), parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics = reportDiagnostics))) - } - } -} - - -# getSample implementation for nimble objects of class MCMC - -#' @rdname getSample -#' @author Tankred Ott -#' @export -getSample.MCMC <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ - return(getSample(as.matrix(sampler$mvSamples), parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics = reportDiagnostics)) -} - -#' @rdname getSample -#' @author Tankred Ott -#' @export -getSample.MCMC_refClass <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ - return(getSample(as.matrix(sampler$mvSamples), parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics = reportDiagnostics)) -} - - -#' Merge Chains -#' -#' Merge a list of outputs from MCMC / SMC samplers -#' -#' The function merges a list of outputs from MCMC / SMC samplers into a single matrix. Requirement is that the list contains classes for which the \code{\link{getSample}} function works -#' -#' @param l a list with objects that can be accessed with \code{\link{getSample}} -#' @param ... arguments to be passed on to \code{\link{getSample}} -#' -#' @return a matrix -#' -#' @author Florian Hartig -#' -#' @export -mergeChains <- function(l, ...){ - - x = getSample(l[[1]], ...) - - for(i in 2:length(l)){ - x = rbind(x, getSample(l[[i]], ...)) - } - return(x) -} +# NOTE: The functions in this class are just templates that are to be implemented for all subclasses of BayesianOutput. They are not functional. + + +#' Extracts the sample from a bayesianOutput +#' @author Florian Hartig +#' @param sampler an object of class mcmcSampler, mcmcSamplerList, smcSampler, smcSamplerList, mcmc, mcmc.list, double, numeric +#' @param parametersOnly for a BT output, if F, likelihood, posterior and prior values are also provided in the output +#' @param coda works only for mcmc classes - returns output as a coda object. Note: if mcmcSamplerList contains mcmc samplers such as DE that have several chains, the internal chains will be collapsed. This may not be desired for all applications. +#' @param start for mcmc samplers, start value in the chain. For SMC samplers, start particle +#' @param end for mcmc samplers end value in the chain. For SMC samplers, end particle +#' @param thin thinning parameter. Either an integer determining the thinning interval (default is 1) or "auto" for automatic thinning. +#' @param numSamples sample size (only used if thin = 1). If you want to use numSamples, set thin to 1. +#' @param whichParameters possibility to select parameters by index +#' @param reportDiagnostics logical, determines whether settings should be included in the output +#' @param ... further arguments +#' @example /inst/examples/getSampleHelp.R +#' @details If thin is greater than the total number of samples in the sampler object, the first and the last element (of each chain if a sampler with multiples chains is used) are sampled. If numSamples is greater than the total number of samples all samples are selected. A warning will be displayed in both cases. +#' @details If both thin and numSamples are provided, the function will use thin only if it is valid and greater than 1; otherwise, numSamples will be used. +#' @export +getSample <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = 1, numSamples = NULL, whichParameters = NULL, reportDiagnostics = FALSE, ...) UseMethod("getSample") + + + +#' @rdname getSample +#' @author Florian Hartig +#' @export +getSample.matrix <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ + + if(is.null(end)) end = nrow(sampler) + + out = sampler[start:end,, drop=F] + + ######################## + # THINNING + nTotalSamples <- nrow(out) + thin <- correctThin(nTotalSamples, thin = thin) + + if (thin == 1 && !is.null(numSamples)) { + out <- sampleEquallySpaced(out, numSamples) + } else { + sel = seq(1, nTotalSamples, by = thin) + out = out[sel,, drop=F] + } + + if (!is.null(whichParameters)) out = out[,whichParameters, drop = FALSE] + if(coda == T) out = makeObjectClassCodaMCMC(out, start = start, end = end, thin = thin) + + if(reportDiagnostics == T){ + return(list(chain = out, start = start, end = end, thin = thin)) + } else return(out) +} + + +#' @rdname getSample +#' @author Tankred Ott +#' @export +# TODO: This is right now only a helper function for getSample.mcmc. It is needed to return a vector istead of a matrix, if +# the mcmc object passed to getSample.mcmc contains a vector. +getSample.double <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ + if(is.null(end)) end = length(sampler) + out <- sampler[start:end] + + nTotalSamples <- length(out) + + thin = correctThin(nTotalSamples, thin) + + if (thin == 1 && !is.null(numSamples)) { + out <- sampleEquallySpaced(out, numSamples) + } else { + sel = seq(1, nTotalSamples, by = thin) + out = out[sel] + } + + return(out) +} + + +#' @rdname getSample +#' @author Tankred Ott +#' @export +# TODO: This is right now only a helper function for getSample.mcmc. It is needed to return a vector instead of a matrix, if +# the mcmc object passed to getSample.mcmc contains a vector. +getSample.integer <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ + if(is.null(end)) end = length(sampler) + out <- sampler[start:end] + + nTotalSamples <- length(out) + + thin = correctThin(nTotalSamples, thin) + + if (thin == 1 && !is.null(numSamples)) { + out <- sampleEquallySpaced(out, numSamples) + } else { + sel = seq(1, nTotalSamples, by = thin) + out = out[sel] + } + + return(out) +} + +#' @rdname getSample +#' @author Tankred Ott +#' @export +getSample.data.frame <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ + getSample(as.matrix(sampler), parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, whichParameters = whichParameters, reportDiagnostics = reportDiagnostics) +} + +#' @rdname getSample +#' @author Tankred Ott +#' @export +getSample.list <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ + + if(!is.null(numSamples)) numSamples = ceiling(numSamples/length(sampler)) + + if(coda == F){ + # out = NULL + out <- rep(list(NA), length(sampler)) + for (i in 1:length(sampler)){ + # out = rbind(out, getSample(sampler[[i]], parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics= F)) + out[[i]] <- getSample(sampler[[i]], parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics= F) + } + out <- combineChains(out) + } + + if(coda == T){ + + out = list() + + for (i in 1:length(sampler)){ + + out[[i]] = getSample(sampler[[i]], parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics= F) + } + + if(inherits(out[[1]], "mcmc.list")) out = unlist(out, recursive = F) + class(out) = "mcmc.list" + out = out + } + + return(out) +} + +# The following two S3 implementations make getSample compatible with coda::mcmc and coda::mcmc.list + +#' @rdname getSample +#' @author Tankred Ott +#' @export +getSample.mcmc <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ + + if(coda == T){ + # mcmc objects can contain matrices or vectors + if (is.matrix(sampler)) { + nTotalSamples <- nrow(sampler) + } else { + nTotalSamples <- length(sampler) + } + + if (is.null(end)) end = nTotalSamples + + # check/correct thin + thin <- correctThin(nTotalSamples, thin) + + # see http://svitsrv25.epfl.ch/R-doc/library/coda/html/window.mcmc.html + # for coda's window implementation + return(window(sampler, start = start, end = end, thin = thin)) + + } else if(coda == F){ + # mcmc objects can contain matrices or vectors + # TODO: do vector case as 1-d matrix? + if (is.matrix(sampler)) { + out <- getSample(as.matrix(sampler), parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics = reportDiagnostics) + } else { + out <- getSample(as.vector(sampler), parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics = reportDiagnostics) + } + return(out) + } +} + + +#' @author Tankred Ott +#' @rdname getSample +#' @export +getSample.mcmc.list <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ + + # TODO: implement handling of wrong inputs? + + if(coda == T){ + + if (is.matrix(sampler[[1]])) { + nTotalSamples <- nrow(sampler[[1]]) + } else { + nTotalSamples <- length(sampler[[1]]) + } + + if (is.null(end)) end = nTotalSamples + + # check/correct thin + thin <- correctThin(nTotalSamples, thin) + + # see http://svitsrv25.epfl.ch/R-doc/library/coda/html/window.mcmc.html + # for coda's window implementation + return(window(sampler, start = start, end = end, thin = thin)) + + } else if(coda == F){ + if(is.matrix(sampler[[1]])) { + return(getSample(combineChains(sampler), parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics = reportDiagnostics)) + } else { + return(as.vector(getSample(combineChains(sampler), parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics = reportDiagnostics))) + } + } +} + + +# getSample implementation for nimble objects of class MCMC + +#' @rdname getSample +#' @author Tankred Ott +#' @export +getSample.MCMC <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ + return(getSample(as.matrix(sampler$mvSamples), parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics = reportDiagnostics)) +} + +#' @rdname getSample +#' @author Tankred Ott +#' @export +getSample.MCMC_refClass <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ + return(getSample(as.matrix(sampler$mvSamples), parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics = reportDiagnostics)) +} + + +#' Merge Chains +#' +#' Merge a list of outputs from MCMC / SMC samplers +#' +#' The function merges a list of outputs from MCMC / SMC samplers into a single matrix. Requirement is that the list contains classes for which the \code{\link{getSample}} function works +#' +#' @param l a list with objects that can be accessed with \code{\link{getSample}} +#' @param ... arguments to be passed on to \code{\link{getSample}} +#' +#' @return a matrix +#' +#' @author Florian Hartig +#' +#' @export +mergeChains <- function(l, ...){ + + x = getSample(l[[1]], ...) + + for(i in 2:length(l)){ + x = rbind(x, getSample(l[[i]], ...)) + } + return(x) +} diff --git a/BayesianTools/R/classBayesianSetup.R b/BayesianTools/R/classBayesianSetup.R index 6cd6d1a..55de969 100644 --- a/BayesianTools/R/classBayesianSetup.R +++ b/BayesianTools/R/classBayesianSetup.R @@ -1,201 +1,201 @@ -#' Creates a standardized collection of prior, likelihood and posterior functions, including error checks etc. -#' @author Florian Hartig, Tankred Ott -#' @param likelihood log likelihood density function -#' @param prior either a prior class (see \code{\link{createPrior}}) or a log prior density function -#' @param priorSampler if a prior density (and not a prior class) is provided to prior, the optional prior sampling function can be provided here -#' @param lower vector with lower prior limits -#' @param upper vector with upper prior limits -#' @param best vector with best prior values -#' @param names optional vector with parameter names -#' @param parallel parallelization option. Default is F. Other options include T, or "external". See details. -#' @param parallelOptions list containing three lists. First "packages" determines the R packages necessary to run the likelihood function. Second "variables" the objects in the global environment needed to run the likelihood function and third "dlls" the DLLs needed to run the likelihood function (see Details and Examples). -#' @param catchDuplicates Logical, determines whether unique parameter combinations should only be evaluated once. Only used when the likelihood accepts a matrix with parameter as columns. -#' @param plotLower vector with lower limits for plotting -#' @param plotUpper vector with upper limits for plotting -#' @param plotBest vector with best values for plotting -#' @details If prior is of class prior (e.g. create with \code{\link{createPrior}}), priorSampler, lower, upper and best will be ignored.\cr If prior is a function (log prior density), priorSampler (custom sampler), or lower/upper (uniform sampler) is required.\cr If prior is NULL, and lower and upper are passed, a uniform prior (see \code{\link{createUniformPrior}}) will be created with boundaries lower and upper. -#' -#' For parallelization, Bayesiantools requies that the likelihood can evaluate several parameter vectors (supplied as a matrix) in parallel. -#' -#' * parallel = T means that an automatic parallelization of the likelihood via a standard R socket cluster is attempted, using the function \code{\link{generateParallelExecuter}}. By default, of the N cores detected on the computer, N-1 cores are requested. Alternatively, you can provide a integer number to parallel, specifying the cores reserved for the cluster. When the cluster is cluster is created, a copy of your workspace, including DLLs and objects are exported to the cluster workers. Because this can be very inefficient, you can explicitly specify the packages, objects and DLLs that are to be exported via parallelOptions. Using parallel = T requires that the function to be parallelized is well encapsulate, i.e. can run on a shared memory / shared hard disk machine in parallel without interfering with each other. -#' -#' If automatic parallelization cannot be done (e.g. because dlls are not thread-safe or write to shared disk), and only in this case, you should specify parallel = "external". In this case, it is assumed that the likelihood is programmed such that it accepts a matrix with parameters as columns and the different model runs as rows. It is then up to the user if and how to parallelize this function. This option gives most flexibility to the user, in particular for complicated parallel architecture or shared memory problems. -#' -#' For more details on parallelization, make sure to read both vignettes, in particular the section on the likelihood in the main vignette, and the section on parallelization in the vignette on interfacing models. -#' -#' @export -#' @seealso \code{\link{checkBayesianSetup}} \cr -#' \code{\link{createLikelihood}} \cr -#' \code{\link{createPrior}} \cr -#' @example /inst/examples/classBayesianSetup.R -#' -#' -#@param model TODO -createBayesianSetup <- function(likelihood, - prior = NULL, - priorSampler = NULL, - parallel = FALSE, - lower= NULL, - upper = NULL, - best = NULL, - names = NULL, - parallelOptions = list(variables = "all", packages = "all", dlls = NULL), - catchDuplicates = FALSE, - plotLower = NULL, - plotUpper = NULL, - plotBest = NULL -){ - - # TODO implement parameter "model" (function that makes predictions from the model) - model <- NULL - - - # INPUTS CHECKS - if(is.null(upper) && is.null(lower) && is.null(prior)) stop("Either boundaries or prior density and prior sampler must be provided.") - # if(!is.null(lower) || !is.null(upper) || !is.null(best)) print("DEPRECATED: lower/upper/best arguments for createBayesianSetup are deprecated and will be removed in a future update. Pass those arguments in the info parameter instead or use createUnformPrior.") - if(("prior" %in% class(prior)) && (!is.null(lower) || !is.null(upper))) warning("Prior object and boundary values provided to createBayesiansetup, the latter will be ignored") - if(("prior" %in% class(prior)) && (!is.null(priorSampler))) warning("Prior object and priorSampler provided to createBayesiansetup, the latter will be ignored") - - if(is.null(parallelOptions)) parallelOptions <- list(variables = "all", packages = "all", dlls = "all") - - - # PRIOR CHECKS - priorClass = NULL - if ("prior" %in% class(prior)) { - priorClass = prior - - } else if (inherits(prior,"bayesianOutput")) { - priorClass = createPriorDensity(prior) - - } else if ("function" %in% class(prior)) { - if ("function" %in% class(priorSampler)) priorClass = createPrior(prior, priorSampler) - else if (!is.null(lower) && !is.null(upper)) priorClass = createPrior(prior, lower=lower, upper=upper, best=best) - else stop("If prior is a function, priorSampler or lower/upper is required") - - } else if (is.null(prior)) { - # TODO: deprecate this - # checks for NULL for lower/upper are already done at begin of function - priorClass = createUniformPrior(lower = lower, upper = upper, best = best) - - } else stop("wrong input for prior") - - - # LIKELIHOOD CHECKS - if ("likelihood" %in% class(likelihood)) { - likelihoodClass = likelihood - } else if ("function" %in% class(likelihood)) { - likelihoodClass = createLikelihood(likelihood, parallel = parallel, parallelOptions = parallelOptions, catchDuplicates = catchDuplicates) - } else { - stop("likelihood must be an object of class likelihood or a function") - } - pwLikelihood = likelihoodClass$pwLikelihood - - # GET NUMBER OF PARAMETERS - numPars = length(priorClass$sampler()) - - # CREATE POSTERIOR - posteriorClass = createPosterior(priorClass,likelihoodClass) - - # CHECK FOR PLOTTING PARAMETERS - if (is.null(plotLower)) plotLower <- priorClass$lower - if (is.null(plotUpper)) plotUpper <- priorClass$upper - if (is.null(plotBest)) plotBest <- priorClass$best - - if (is.null(plotLower) | is.null(plotUpper) | is.null(plotBest)) - print("Info is missing upper/lower/best. This can cause plotting and sensitivity analysis functions to fail. If you want to use those functions provide (plot)upper/lower/best either in createBayesianSetup or prior") - - # CHECK NAMES - if (is.null(names)) { - if (!is.null(priorClass$parNames)) names = priorClass$parNames - else if (!is.null(likelihoodClass$parNames)) names = likelihoodClass$parNames - else if (numPars > 0) names = paste("par", 1:numPars) - } - - # CONSTRUCT OUTPUT - info <- list(priorLower = priorClass$lower, priorUpper = priorClass$upper, priorBest = priorClass$best, - plotLower = plotLower, plotUpper = plotUpper, plotBest = plotBest, - parNames = names, numPars = numPars) - out <- list(prior = priorClass, likelihood = likelihoodClass, posterior = posteriorClass, - names = names, numPars = numPars, model = model, parallel = parallel, pwLikelihood = pwLikelihood, info = info) - class(out) <- "BayesianSetup" - - return(out) -} -# -# #' Generates initial sample TODO -# #' @param n TODO -# #' @param checkInf TODO -# #' @param overdispersed TODO -# #' @param maxIterations TODO -# #' @export -# generateInitialSamples <- function(n, checkInf = T, overdispersed = F, maxIterations = 5){ -# if(is.null(sampler)) stop("sampling not implemented") -# done = F -# -# stop("to implement") -# -# # check infinity of likelihood / create overdispersion -# -# } - -#TODO: FH I wonder if we should keep this function option alive - seems better to me to explicitly do -# this with the createBayesianSetup - -#' Checks if an object is of class 'BayesianSetup' -#' @author Florian Hartig -#' @description Function used to assure that an object is of class 'BayesianSetup'. If you pass a function, it is coverted to an object of class 'BayesianSetup' (using \code{\link{createBayesianSetup}}) before it is returned. -#' @param bayesianSetup either object of class bayesianSetup or a log posterior function -#' @param parallel if bayesianSetup is a function, this will set the parallelization option for the class BayesianSetup that is created internally. If bayesianSetup is already a BayesianSetup, then this will check if parallel = T is requested but not supported by the BayesianSetup. This option is for internal use in the samplers -#' @note The recommended option to use this function in the samplers is to have parallel with default NULL in the samplers, so that checkBayesianSetup with a function will create a bayesianSetup without parallelization, while it will do nothing with an existing BayesianSetup. If the user sets parallelization, it will set the approriate parallelization for a function, and check in case of an existing BayesianSetup. The checkBayesianSetup call in the samplers should then be followed by a check for parallel = NULL in sampler, in which case paralell can be set from the BayesianSetup -#' @seealso \code{\link{createBayesianSetup}} -#' @export -checkBayesianSetup <- function(bayesianSetup, parallel = F){ - - if(inherits(bayesianSetup, "function")){ - if(is.null(parallel)) parallel = F - bayesianSetup = createBayesianSetup(bayesianSetup, parallel = parallel) - } - else if(inherits(bayesianSetup, "BayesianSetup")){ - if(!is.null(parallel)) if(parallel == T & bayesianSetup$parallel == F) stop("parallel = T requested in sampler but BayesianSetup does not support parallelization. See help of BayesianSetup on how to enable parallelization") - } - else stop("bayesianSetup must be class BayesianSetup or a function") - - return(bayesianSetup) -} - - -#' Function to close cluster in BayesianSetup -#' @author Stefan Paul -#' @description Function closes -#' the parallel executer (if available) -#' @param bayesianSetup object of class BayesianSetup -#' @export -stopParallel <- function(bayesianSetup){ - - ## Stop cluster - try(parallel::stopCluster(bayesianSetup$likelihood$cl), silent = TRUE) - - ## Remove object - # pos <- -1 - # if(is.null(envir)) envir <- as.environment(pos) - - # .Internal(remove(deparse(substitute(bayesianSetup)), envir = envir, inherits = FALSE)) - -} - - -#' @author Maximilian Pichler -#' @export - -print.BayesianSetup <- function(x, ...){ - cat('BayesianSetup: \n\n') - - bayesianSetup = x - info = c( "priorLower", "priorUpper", "plotLower", "plotUpper") - parInfo = data.frame(matrix(NA, ncol = 4, nrow = bayesianSetup$info$numPars)) - colnames(parInfo) = info - rownames(parInfo) = bayesianSetup$info$parNames - for(i in 1:4) if(!is.null(bayesianSetup$info[[info[i]]])) parInfo[,i] <- bayesianSetup$info[[info[i]]] - print(parInfo) - -} +#' Creates a standardized collection of prior, likelihood and posterior functions, including error checks etc. +#' @author Florian Hartig, Tankred Ott +#' @param likelihood log likelihood density function +#' @param prior either a prior class (see \code{\link{createPrior}}) or a log prior density function +#' @param priorSampler if a prior density (and not a prior class) is provided to prior, the optional prior sampling function can be provided here +#' @param lower vector with lower prior limits +#' @param upper vector with upper prior limits +#' @param best vector with best prior values +#' @param names optional vector with parameter names +#' @param parallel parallelization option. Default is F. Other options include T, or "external". See details. +#' @param parallelOptions list containing three lists.\n First, "packages" determines the R packages necessary to run the likelihood function.\n Second, "variables" - the objects in the global environment needed to run the likelihood function and \n third, "dlls" is needed to run the likelihood function (see Details and Examples). +#' @param catchDuplicates logical, determines whether unique parameter combinations should only be evaluated once. Only used when the likelihood accepts a matrix with parameter as columns. +#' @param plotLower vector with lower limits for plotting +#' @param plotUpper vector with upper limits for plotting +#' @param plotBest vector with best values for plotting +#' @details If prior is of class prior (e.g. create with \code{\link{createPrior}}), priorSampler, lower, upper and best will be ignored.\cr If prior is a function (log prior density), priorSampler (custom sampler), or lower/upper (uniform sampler) is required.\cr If prior is NULL, and lower and upper are passed, a uniform prior (see \code{\link{createUniformPrior}}) will be created with boundaries lower and upper. +#' +#' For parallelization, Bayesiantools requires that the likelihood can evaluate multiple parameter vectors (supplied as a matrix) in parallel. +#' +#' * parallel = T attempts to parallelize likelihood via a standard R socket cluster using the \code{\link{generateParallelExecuter}} function. By default, of the N cores detected on the computer, N-1 cores are requested. Alternatively, you can provide a integer number to parallel, specifying the cores reserved for the cluster. When the cluster is created, a copy of your workspace, including DLLs and objects are exported to the cluster workers. As this approach can be highly inefficient, it is recommended to explicitly specify the packages, objects and DLLs to export using parallelOptions. Using parallel = T requires that the function to be parallelized is well encapsulated, i.e. can run in parallel on a shared memory / shared hard disk machine in parallel without interfering with each other. +#' +#' If automatic parallelization is not possible (e.g., because dlls are not thread-safe or write to shared disk), and only in this case, you should specify parallel = "external". In this case, it is assumed that the likelihood is programmed to accept a matrix with parameters as columns and the different model runs as rows. The user can then choose whether and how to parallelize this function. This option provides optimal flexibility for the user, especially regarding complicated parallel architectures or shared memory issues. +#' +#' For more details on parallelization, make sure to read both vignettes, especially the section on likelihood in the main vignette and the section on parallelization in the vignette on interfacing models. +#' +#' @export +#' @seealso \code{\link{checkBayesianSetup}} \cr +#' \code{\link{createLikelihood}} \cr +#' \code{\link{createPrior}} \cr +#' @example /inst/examples/classBayesianSetup.R +#' +#' +#@param model TODO +createBayesianSetup <- function(likelihood, + prior = NULL, + priorSampler = NULL, + parallel = FALSE, + lower= NULL, + upper = NULL, + best = NULL, + names = NULL, + parallelOptions = list(variables = "all", packages = "all", dlls = NULL), + catchDuplicates = FALSE, + plotLower = NULL, + plotUpper = NULL, + plotBest = NULL +){ + + # TODO implement parameter "model" (function that makes predictions from the model) + model <- NULL + + + # INPUTS CHECKS + if(is.null(upper) && is.null(lower) && is.null(prior)) stop("Either boundaries or prior density and prior sampler must be provided.") + # if(!is.null(lower) || !is.null(upper) || !is.null(best)) print("DEPRECATED: lower/upper/best arguments for createBayesianSetup are deprecated and will be removed in a future update. Pass those arguments in the info parameter instead or use createUnformPrior.") + if(("prior" %in% class(prior)) && (!is.null(lower) || !is.null(upper))) warning("Prior object and boundary values provided to createBayesiansetup, the latter will be ignored") + if(("prior" %in% class(prior)) && (!is.null(priorSampler))) warning("Prior object and priorSampler provided to createBayesiansetup, the latter will be ignored") + + if(is.null(parallelOptions)) parallelOptions <- list(variables = "all", packages = "all", dlls = "all") + + + # PRIOR CHECKS + priorClass = NULL + if ("prior" %in% class(prior)) { + priorClass = prior + + } else if (inherits(prior,"bayesianOutput")) { + priorClass = createPriorDensity(prior) + + } else if ("function" %in% class(prior)) { + if ("function" %in% class(priorSampler)) priorClass = createPrior(prior, priorSampler) + else if (!is.null(lower) && !is.null(upper)) priorClass = createPrior(prior, lower=lower, upper=upper, best=best) + else stop("If prior is a function, priorSampler or lower/upper is required") + + } else if (is.null(prior)) { + # TODO: deprecate this + # checks for NULL for lower/upper are already done at begin of function + priorClass = createUniformPrior(lower = lower, upper = upper, best = best) + + } else stop("wrong input for prior") + + + # LIKELIHOOD CHECKS + if ("likelihood" %in% class(likelihood)) { + likelihoodClass = likelihood + } else if ("function" %in% class(likelihood)) { + likelihoodClass = createLikelihood(likelihood, parallel = parallel, parallelOptions = parallelOptions, catchDuplicates = catchDuplicates) + } else { + stop("likelihood must be an object of class likelihood or a function") + } + pwLikelihood = likelihoodClass$pwLikelihood + + # GET NUMBER OF PARAMETERS + numPars = length(priorClass$sampler()) + + # CREATE POSTERIOR + posteriorClass = createPosterior(priorClass,likelihoodClass) + + # CHECK FOR PLOTTING PARAMETERS + if (is.null(plotLower)) plotLower <- priorClass$lower + if (is.null(plotUpper)) plotUpper <- priorClass$upper + if (is.null(plotBest)) plotBest <- priorClass$best + + if (is.null(plotLower) | is.null(plotUpper) | is.null(plotBest)) + print("Info is missing upper/lower/best. This can cause plotting and sensitivity analysis functions to fail. If you want to use those functions provide (plot)upper/lower/best either in createBayesianSetup or prior") + + # CHECK NAMES + if (is.null(names)) { + if (!is.null(priorClass$parNames)) names = priorClass$parNames + else if (!is.null(likelihoodClass$parNames)) names = likelihoodClass$parNames + else if (numPars > 0) names = paste("par", 1:numPars) + } + + # CONSTRUCT OUTPUT + info <- list(priorLower = priorClass$lower, priorUpper = priorClass$upper, priorBest = priorClass$best, + plotLower = plotLower, plotUpper = plotUpper, plotBest = plotBest, + parNames = names, numPars = numPars) + out <- list(prior = priorClass, likelihood = likelihoodClass, posterior = posteriorClass, + names = names, numPars = numPars, model = model, parallel = parallel, pwLikelihood = pwLikelihood, info = info) + class(out) <- "BayesianSetup" + + return(out) +} +# +# #' Generates initial sample TODO +# #' @param n TODO +# #' @param checkInf TODO +# #' @param overdispersed TODO +# #' @param maxIterations TODO +# #' @export +# generateInitialSamples <- function(n, checkInf = T, overdispersed = F, maxIterations = 5){ +# if(is.null(sampler)) stop("sampling not implemented") +# done = F +# +# stop("to implement") +# +# # check infinity of likelihood / create overdispersion +# +# } + +#TODO: FH I wonder if we should keep this function option alive - seems better to me to explicitly do +# this with the createBayesianSetup + +#' Checks if an object is of class 'BayesianSetup' +#' @author Florian Hartig +#' @description Function used to assure that an object is of class 'BayesianSetup'. If you pass a function, it is coverted to an object of class 'BayesianSetup' (using \code{\link{createBayesianSetup}}) before it is returned. +#' @param bayesianSetup either object of class bayesianSetup or a log posterior function +#' @param parallel if bayesianSetup is a function, this will set the parallelization option for the class BayesianSetup that is created internally. If bayesianSetup is already a BayesianSetup, then this will check if parallel = T is requested but not supported by the BayesianSetup. This option is for internal use in the samplers +#' @note The recommended option to use this function in the samplers is to have parallel with default NULL in the samplers, so that checkBayesianSetup with a function will create a bayesianSetup without parallelization, while it will do nothing with an existing BayesianSetup. If the user sets parallelization, it will set the approriate parallelization for a function, and check in case of an existing BayesianSetup. The checkBayesianSetup call in the samplers should then be followed by a check for parallel = NULL in sampler, in which case paralell can be set from the BayesianSetup +#' @seealso \code{\link{createBayesianSetup}} +#' @export +checkBayesianSetup <- function(bayesianSetup, parallel = F){ + + if(inherits(bayesianSetup, "function")){ + if(is.null(parallel)) parallel = F + bayesianSetup = createBayesianSetup(bayesianSetup, parallel = parallel) + } + else if(inherits(bayesianSetup, "BayesianSetup")){ + if(!is.null(parallel)) if(parallel == T & bayesianSetup$parallel == F) stop("parallel = T requested in sampler but BayesianSetup does not support parallelization. See help of BayesianSetup on how to enable parallelization") + } + else stop("bayesianSetup must be class BayesianSetup or a function") + + return(bayesianSetup) +} + + +#' Function to close cluster in BayesianSetup +#' @author Stefan Paul +#' @description Function closes +#' the parallel executer (if available) +#' @param bayesianSetup object of class BayesianSetup +#' @export +stopParallel <- function(bayesianSetup){ + + ## Stop cluster + try(parallel::stopCluster(bayesianSetup$likelihood$cl), silent = TRUE) + + ## Remove object + # pos <- -1 + # if(is.null(envir)) envir <- as.environment(pos) + + # .Internal(remove(deparse(substitute(bayesianSetup)), envir = envir, inherits = FALSE)) + +} + + +#' @author Maximilian Pichler +#' @export + +print.BayesianSetup <- function(x, ...){ + cat('BayesianSetup: \n\n') + + bayesianSetup = x + info = c( "priorLower", "priorUpper", "plotLower", "plotUpper") + parInfo = data.frame(matrix(NA, ncol = 4, nrow = bayesianSetup$info$numPars)) + colnames(parInfo) = info + rownames(parInfo) = bayesianSetup$info$parNames + for(i in 1:4) if(!is.null(bayesianSetup$info[[info[i]]])) parInfo[,i] <- bayesianSetup$info[[info[i]]] + print(parInfo) + +} diff --git a/BayesianTools/R/classLikelihood.R b/BayesianTools/R/classLikelihood.R index 905d9a5..a85ebff 100644 --- a/BayesianTools/R/classLikelihood.R +++ b/BayesianTools/R/classLikelihood.R @@ -1,166 +1,166 @@ -#' Creates a standardized likelihood class#' -#' @author Florian Hartig -#' @param likelihood Log likelihood density -#' @param names Parameter names (optional) -#' @param parallel parallelization , either i) no parallelization --> F, ii) native R parallelization --> T / "auto" will select n-1 of your available cores, or provide a number for how many cores to use, or iii) external parallelization --> "external". External means that the likelihood is already able to execute parallel runs in form of a matrix with -#' @param catchDuplicates Logical, determines whether unique parameter combinations should only be evaluated once. Only used when the likelihood accepts a matrix with parameter as columns. -#' @param parallelOptions list containing two lists. First "packages" determines the R packages necessary to run the likelihood function. Second "objects" the objects in the global envirnment needed to run the likelihood function (for details see \code{\link{createBayesianSetup}}). -#' @param sampler sampler -#' @seealso \code{\link{likelihoodIidNormal}} \cr -#' \code{\link{likelihoodAR1}} \cr -#' @export -createLikelihood <- function(likelihood, names = NULL, parallel = F, catchDuplicates=T, - sampler = NULL, parallelOptions = NULL){ - - # check if point-wise likelihood available - pwLikelihood = if ("sum" %in% names(as.list(args(likelihood)))) TRUE else FALSE - - catchingLikelihood <- function(x, ...){ - out <- tryCatch( - { - y = likelihood(x, ...) - if (any(y == Inf | is.nan(y) | is.na(y) | !is.numeric(y))){ - message(paste("BayesianTools warning: positive Inf or NA / nan values, or non-numeric values occured in the likelihood. Setting likelihood to -Inf.\n Original value was", y, "for parameters", x, "\n\n ")) - y[is.infinite(y) | is.nan(y) | is.na(y) | !is.numeric(y)] = -Inf - } - y - }, - error=function(cond){ - cat(c("Parameter values ", x, "\n")) - message("Problem encountered in the calculation of the likelihood with parameter ", x, "\n Error message was", cond, "\n set result of the parameter evaluation to -Inf ", "ParameterValues ") - return(-Inf) - } - ) - return(out) - } - - # initalize cl - cl <- NULL - - if (parallel == T | parallel == "auto" | is.numeric(parallel)) { - tmp <- generateParallelExecuter(likelihood, parallel, parallelOptions) - parallelLikelihood <- tmp$parallelFun - cl <- tmp$cl - parallel = T - } - - - parallelDensity<- function(x, ...){ - if (is.vector(x)) return(catchingLikelihood(x, ...)) - else if(is.matrix(x)){ - if(catchDuplicates == TRUE){ - # Check for the rows that are not duplicated - wn <- which(!duplicated(x)) - if(length(wn) <2) { - return(parallelLikelihood(x, ...)) } - else { - # Define a output vector - out1 <- rep(0,length=nrow(x)) - - # Run the likelihood function for unique values - if (parallel == "external"){ - out1[wn]<-likelihood(x[wn,], ...) - } - else{ - if (parallel == T){ - out1[wn]<-parallelLikelihood(x[wn,], ...) - } - else{ - out1[wn]<-apply(x[wn,], 1, likelihood, ...) - } - } - # Copy the values for the duplicates - for(i in 1:length(out1)){ - if(out1[i] != 0) next - else{ - same <- numeric() - for(k in 1:length(out1)){ - if(all(x[k,]== x[i,])){ - same <- c(same,k) - } - } - out1[same[-1]] <- out1[same[1]] - } - } - - return(out1) - }} - - else{ - if (parallel == "external") return(likelihood(x, ...)) - else if (parallel == T){ - return(parallelLikelihood(x, ...))} - else return(apply(x, 1, likelihood, ...)) - - } - } - else stop("parameter must be vector or matrix") - } - out<- list(density = parallelDensity, sampler = sampler, cl = cl, pwLikelihood = pwLikelihood, parNames = names) - class(out) <- "likelihood" - return(out) -} - - - -#library(mvtnorm) -#library(sparseMVN) - -#' Normal / Gaussian Likelihood function -#' @author Florian Hartig -#' @param predicted vector of predicted values -#' @param observed vector of observed values -#' @param sd standard deviation of the i.i.d. normal likelihood -#' @export -likelihoodIidNormal <- function(predicted, observed, sd){ - notNAvalues = !is.na(observed) - if (sd <= 0) return (-Inf) - else return(sum(dnorm(predicted[notNAvalues], mean = observed[notNAvalues], sd = sd, log = T))) -} - -# TODO - gibbs sample out the error terms - -#' AR1 type likelihood function -#' @author Florian Hartig -#' @param predicted vector of predicted values -#' @param observed vector of observed values -#' @param sd standard deviation of the iid normal likelihood -#' @param a temporal correlation in the AR1 model -#' @note The AR1 model considers the process: \cr y(t) = a y(t-1) + E \cr e = i.i.d. N(0,sd) \cr |a| < 1 \cr At the moment, no NAs are allowed in the time series. -#' @export -likelihoodAR1 <- function(predicted, observed, sd, a){ - if (any(is.na(observed))) stop("AR1 likelihood cannot work with NAs included, split up the likelihood") - if (sd <= 0) return (-Inf) - if (abs(a) >= 1) return (-Inf) - - n = length(observed) - - res = predicted - observed - - # this calculates the unconditiona LL for this data, see e.g. http://stat.unicas.it/downloadStatUnicas/seminari/2008/Julliard0708_1.pdf - - ll = 0.5 * ( - n * log(2*pi) - - n * log(sd^2) - + log( 1- a^2 ) - - (1- a^2) / sd^2 * res[1]^2 - - 1 / sd^2 * sum( (res[2:n] - a * res[1:(n-1)])^2) - ) - return(ll) -} -# Tests -# library(stats) -# data<-arima.sim(n=1000,model = list(ar=0.9)) -# x <- ar(data, aic = F, order.max = 1) -# opt <- function(par){ -# -likelihoodAR1(data, rep(0,1000), sd = par[1], a = par[2] ) -# } -# optim(c(1.1,0.7), opt ) - - - - - - - - - +#' Creates a standardized likelihood class#' +#' @author Florian Hartig +#' @param likelihood log likelihood density +#' @param names parameter names (optional) +#' @param parallel parallelization , either i) no parallelization --> F, ii) native R parallelization --> T / "auto" will select n-1 of your available cores, or provide a number for how many cores to use, or iii) external parallelization --> "external". External means that the likelihood is already able to execute parallel runs in the form of a matrix. +#' @param catchDuplicates logical, determines whether unique parameter combinations should only be evaluated once. This is only applicable when the likelihood accepts a matrix with parameters as columns. +#' @param parallelOptions a list containing two lists. First, "packages" specifies the R packages necessary to run the likelihood function. Second, "objects" contains the objects in the global environment needed to run the likelihood function (for details see \code{\link{createBayesianSetup}}). +#' @param sampler sampler +#' @seealso \code{\link{likelihoodIidNormal}} \cr +#' \code{\link{likelihoodAR1}} \cr +#' @export +createLikelihood <- function(likelihood, names = NULL, parallel = F, catchDuplicates=T, + sampler = NULL, parallelOptions = NULL){ + + # check if point-wise likelihood available + pwLikelihood = if ("sum" %in% names(as.list(args(likelihood)))) TRUE else FALSE + + catchingLikelihood <- function(x, ...){ + out <- tryCatch( + { + y = likelihood(x, ...) + if (any(y == Inf | is.nan(y) | is.na(y) | !is.numeric(y))){ + message(paste("BayesianTools warning: positive Inf or NA / nan values, or non-numeric values occured in the likelihood. Setting likelihood to -Inf.\n Original value was", y, "for parameters", x, "\n\n ")) + y[is.infinite(y) | is.nan(y) | is.na(y) | !is.numeric(y)] = -Inf + } + y + }, + error=function(cond){ + cat(c("Parameter values ", x, "\n")) + message("Problem encountered in the calculation of the likelihood with parameter ", x, "\n Error message was", cond, "\n set result of the parameter evaluation to -Inf ", "ParameterValues ") + return(-Inf) + } + ) + return(out) + } + + # initalize cl + cl <- NULL + + if (parallel == T | parallel == "auto" | is.numeric(parallel)) { + tmp <- generateParallelExecuter(likelihood, parallel, parallelOptions) + parallelLikelihood <- tmp$parallelFun + cl <- tmp$cl + parallel = T + } + + + parallelDensity<- function(x, ...){ + if (is.vector(x)) return(catchingLikelihood(x, ...)) + else if(is.matrix(x)){ + if(catchDuplicates == TRUE){ + # Check for the rows that are not duplicated + wn <- which(!duplicated(x)) + if(length(wn) <2) { + return(parallelLikelihood(x, ...)) } + else { + # Define a output vector + out1 <- rep(0,length=nrow(x)) + + # Run the likelihood function for unique values + if (parallel == "external"){ + out1[wn]<-likelihood(x[wn,], ...) + } + else{ + if (parallel == T){ + out1[wn]<-parallelLikelihood(x[wn,], ...) + } + else{ + out1[wn]<-apply(x[wn,], 1, likelihood, ...) + } + } + # Copy the values for the duplicates + for(i in 1:length(out1)){ + if(out1[i] != 0) next + else{ + same <- numeric() + for(k in 1:length(out1)){ + if(all(x[k,]== x[i,])){ + same <- c(same,k) + } + } + out1[same[-1]] <- out1[same[1]] + } + } + + return(out1) + }} + + else{ + if (parallel == "external") return(likelihood(x, ...)) + else if (parallel == T){ + return(parallelLikelihood(x, ...))} + else return(apply(x, 1, likelihood, ...)) + + } + } + else stop("parameter must be vector or matrix") + } + out<- list(density = parallelDensity, sampler = sampler, cl = cl, pwLikelihood = pwLikelihood, parNames = names) + class(out) <- "likelihood" + return(out) +} + + + +#library(mvtnorm) +#library(sparseMVN) + +#' Normal / Gaussian Likelihood function +#' @author Florian Hartig +#' @param predicted vector of predicted values +#' @param observed vector of observed values +#' @param sd standard deviation of the i.i.d. normal likelihood +#' @export +likelihoodIidNormal <- function(predicted, observed, sd){ + notNAvalues = !is.na(observed) + if (sd <= 0) return (-Inf) + else return(sum(dnorm(predicted[notNAvalues], mean = observed[notNAvalues], sd = sd, log = T))) +} + +# TODO - gibbs sample out the error terms + +#' AR1 type likelihood function +#' @author Florian Hartig +#' @param predicted vector of predicted values +#' @param observed vector of observed values +#' @param sd standard deviation of the iid normal likelihood +#' @param a temporal correlation in the AR1 model +#' @note The AR1 model considers the process: \cr y(t) = a y(t-1) + E \cr e = i.i.d. N(0,sd) \cr |a| < 1 \cr At the moment, no NAs are allowed in the time series. +#' @export +likelihoodAR1 <- function(predicted, observed, sd, a){ + if (any(is.na(observed))) stop("AR1 likelihood cannot work with NAs included, split up the likelihood") + if (sd <= 0) return (-Inf) + if (abs(a) >= 1) return (-Inf) + + n = length(observed) + + res = predicted - observed + + # this calculates the unconditiona LL for this data, see e.g. http://stat.unicas.it/downloadStatUnicas/seminari/2008/Julliard0708_1.pdf + + ll = 0.5 * ( - n * log(2*pi) + - n * log(sd^2) + + log( 1- a^2 ) + - (1- a^2) / sd^2 * res[1]^2 + - 1 / sd^2 * sum( (res[2:n] - a * res[1:(n-1)])^2) + ) + return(ll) +} +# Tests +# library(stats) +# data<-arima.sim(n=1000,model = list(ar=0.9)) +# x <- ar(data, aic = F, order.max = 1) +# opt <- function(par){ +# -likelihoodAR1(data, rep(0,1000), sd = par[1], a = par[2] ) +# } +# optim(c(1.1,0.7), opt ) + + + + + + + + + diff --git a/BayesianTools/R/classMcmcSamplerList.R b/BayesianTools/R/classMcmcSamplerList.R index 67fad61..ec69547 100644 --- a/BayesianTools/R/classMcmcSamplerList.R +++ b/BayesianTools/R/classMcmcSamplerList.R @@ -1,151 +1,151 @@ -#' Convenience function to create an object of class mcmcSamplerList from a list of mcmc samplers -#' @author Florian Hartig -#' @param mcmcList a list with each object being an mcmcSampler -#' @return Object of class "mcmcSamplerList" -#' @export -createMcmcSamplerList <- function(mcmcList){ - # mcmcList <- list(mcmcList) -> This line didn't make any sense at all. Better would be to allow the user to simply provide several inputs without a list, but I guess the list option should be maintained, as this is convenient when scripting. - for (i in 1:length(mcmcList)){ - if (! ("mcmcSampler" %in% class(mcmcList[[i]])) ) stop("list objects are not of class mcmcSampler") - } - class(mcmcList) = c("mcmcSamplerList", "bayesianOutput") - return(mcmcList) -} - -#' @author Stefan Paul -#' @method summary mcmcSamplerList -#' @export -summary.mcmcSamplerList <- function(object, ...){ - #codaChain = getSample(sampler, parametersOnly = parametersOnly, coda = T, ...) - #summary(codaChain) - #rejectionRate(sampler$codaChain) - #effectiveSize(sampler$codaChain) - #DIC(sampler) - #max() - - sampler <- object - - DInf <- DIC(sampler) - MAPvals <- round(MAP(sampler)$parametersMAP,3) - - gelDiag <- gelmanDiagnostics(sampler) - psf <- round(gelDiag$psrf[,1], 3) - - mcmcsampler <- sampler[[1]]$settings$sampler - - runtime <- 0 - for(i in 1:length(sampler)) runtime <- runtime+sampler[[i]]$settings$runtime[3] - - correlations <- round(cor(getSample(sampler)),3) - - - sampler <- getSample(sampler, parametersOnly = T, coda = T, ...) - if("mcmc.list" %in% class(sampler)){ - nrChain <- length(sampler) - nrIter <- nrow(sampler[[1]]) - conv <- round(gelDiag$mpsrf,3) - npar <- ncol(sampler[[1]]) - lowerq <- upperq <- numeric(npar) - medi <- numeric(npar) - parnames <- colnames(sampler[[1]]) - for(i in 1:npar){ - tmp <- unlist(sampler[,i]) - tmp <- quantile(tmp, probs = c(0.025, 0.5, 0.975)) - lowerq[i] <- round(tmp[1],3) - medi[i] <- round(tmp[2],3) - upperq[i] <- round(tmp[3],3) - } - - }else{ - nrChain <- 1 - nrIter <- nrow(sampler) - npar <- ncol(sampler) - conv <- "Only one chain; convergence cannot be determined!" - medi <- numeric(npar) - lowerq <- upperq <- numeric(npar) - parnames <- colnames(sampler) - for(i in 1:npar){ - tmp <- quantile(sampler[,i], probs = c(0.025, 0.5, 0.975)) - lowerq[i] <- round(tmp[1],3) - medi[i] <- round(tmp[2],3) - upperq[i] <- round(tmp[3],3) - } - - } - - # output for parameter metrics - parOutDF <- cbind(psf, MAPvals, lowerq, medi, upperq) - colnames(parOutDF) <- c("psf", "MAP", "2.5%", "median", "97.5%") - row.names(parOutDF) <- parnames - - - cat(rep("#", 25), "\n") - cat("## MCMC chain summary ##","\n") - cat(rep("#", 25), "\n", "\n") - cat("# MCMC sampler: ",mcmcsampler, "\n") - cat("# Nr. Chains: ", nrChain, "\n") - cat("# Iterations per chain: ", nrIter, "\n") - cat("# Rejection rate: ", ifelse(object[[1]]$setup$numPars == 1, # this is a hack because coda::rejectionRate does not work for 1-d MCMC lists - round(mean(sapply(sampler, coda::rejectionRate)),3), - round(mean(coda::rejectionRate(sampler)),3) ), "\n") - cat("# Effective sample size: ", round(mean(coda::effectiveSize(sampler)),0), "\n") - cat("# Runtime: ", runtime, " sec.","\n", "\n") - cat("# Parameters\n") - print(parOutDF) - cat("\n") - cat("## DIC: ", round(DInf$DIC,3), "\n") - cat("## Convergence" ,"\n", "Gelman Rubin multivariate psrf: ", conv, "\n","\n") - cat("## Correlations", "\n") - print(correlations) - -} - -#' @author Florian Hartig -#' @method print mcmcSamplerList -#' @export -print.mcmcSamplerList <- function(x, ...){ - print("mcmcSamplerList - you can use the following methods to summarize, plot or reduce this class:") - print(methods(class ="mcmcSamplerList")) - #codaChain = getSample(sampler, coda = T, ...) - #rejectionRate(sampler$codaChain) - #effectiveSize(sampler$codaChain) -} - -#' @method plot mcmcSamplerList -#' @export -plot.mcmcSamplerList <- function(x, ...){ - tracePlot(x, ...) -} - -#' @author Florian Hartig -#' @export -getSample.mcmcSamplerList <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = 1, numSamples = NULL, whichParameters = NULL, reportDiagnostics, ...){ - - if(!is.null(numSamples)) numSamples = ceiling(numSamples/length(sampler)) - - if(coda == F){ - # out = NULL - out <- rep(list(NA), length(sampler)) - for (i in 1:length(sampler)){ - # out = rbind(out, getSample(sampler[[i]], parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics= F)) - out[[i]] <- getSample(sampler[[i]], parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics= F) - } - out <- combineChains(out) - } - - if(coda == T){ - - out = list() - - for (i in 1:length(sampler)){ - - out[[i]] = getSample(sampler[[i]], parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics= F) - } - - if(inherits(out[[1]], "mcmc.list")) out = unlist(out, recursive = F) - class(out) = "mcmc.list" - out = out - } - - return(out) -} +#' Convenience function to create an object of class mcmcSamplerList from a list of mcmc samplers +#' @author Florian Hartig +#' @param mcmcList list of objects, each of which is an mcmcSampler +#' @return object of class "mcmcSamplerList" +#' @export +createMcmcSamplerList <- function(mcmcList){ + # mcmcList <- list(mcmcList) -> This line didn't make any sense at all. Better would be to allow the user to simply provide several inputs without a list, but I guess the list option should be maintained, as this is convenient when scripting. + for (i in 1:length(mcmcList)){ + if (! ("mcmcSampler" %in% class(mcmcList[[i]])) ) stop("list objects are not of class mcmcSampler") + } + class(mcmcList) = c("mcmcSamplerList", "bayesianOutput") + return(mcmcList) +} + +#' @author Stefan Paul +#' @method summary mcmcSamplerList +#' @export +summary.mcmcSamplerList <- function(object, ...){ + #codaChain = getSample(sampler, parametersOnly = parametersOnly, coda = T, ...) + #summary(codaChain) + #rejectionRate(sampler$codaChain) + #effectiveSize(sampler$codaChain) + #DIC(sampler) + #max() + + sampler <- object + + DInf <- DIC(sampler) + MAPvals <- round(MAP(sampler)$parametersMAP,3) + + gelDiag <- gelmanDiagnostics(sampler) + psf <- round(gelDiag$psrf[,1], 3) + + mcmcsampler <- sampler[[1]]$settings$sampler + + runtime <- 0 + for(i in 1:length(sampler)) runtime <- runtime+sampler[[i]]$settings$runtime[3] + + correlations <- round(cor(getSample(sampler)),3) + + + sampler <- getSample(sampler, parametersOnly = T, coda = T, ...) + if("mcmc.list" %in% class(sampler)){ + nrChain <- length(sampler) + nrIter <- nrow(sampler[[1]]) + conv <- round(gelDiag$mpsrf,3) + npar <- ncol(sampler[[1]]) + lowerq <- upperq <- numeric(npar) + medi <- numeric(npar) + parnames <- colnames(sampler[[1]]) + for(i in 1:npar){ + tmp <- unlist(sampler[,i]) + tmp <- quantile(tmp, probs = c(0.025, 0.5, 0.975)) + lowerq[i] <- round(tmp[1],3) + medi[i] <- round(tmp[2],3) + upperq[i] <- round(tmp[3],3) + } + + }else{ + nrChain <- 1 + nrIter <- nrow(sampler) + npar <- ncol(sampler) + conv <- "Only one chain; convergence cannot be determined!" + medi <- numeric(npar) + lowerq <- upperq <- numeric(npar) + parnames <- colnames(sampler) + for(i in 1:npar){ + tmp <- quantile(sampler[,i], probs = c(0.025, 0.5, 0.975)) + lowerq[i] <- round(tmp[1],3) + medi[i] <- round(tmp[2],3) + upperq[i] <- round(tmp[3],3) + } + + } + + # output for parameter metrics + parOutDF <- cbind(psf, MAPvals, lowerq, medi, upperq) + colnames(parOutDF) <- c("psf", "MAP", "2.5%", "median", "97.5%") + row.names(parOutDF) <- parnames + + + cat(rep("#", 25), "\n") + cat("## MCMC chain summary ##","\n") + cat(rep("#", 25), "\n", "\n") + cat("# MCMC sampler: ",mcmcsampler, "\n") + cat("# Nr. Chains: ", nrChain, "\n") + cat("# Iterations per chain: ", nrIter, "\n") + cat("# Rejection rate: ", ifelse(object[[1]]$setup$numPars == 1, # this is a hack because coda::rejectionRate does not work for 1-d MCMC lists + round(mean(sapply(sampler, coda::rejectionRate)),3), + round(mean(coda::rejectionRate(sampler)),3) ), "\n") + cat("# Effective sample size: ", round(mean(coda::effectiveSize(sampler)),0), "\n") + cat("# Runtime: ", runtime, " sec.","\n", "\n") + cat("# Parameters\n") + print(parOutDF) + cat("\n") + cat("## DIC: ", round(DInf$DIC,3), "\n") + cat("## Convergence" ,"\n", "Gelman Rubin multivariate psrf: ", conv, "\n","\n") + cat("## Correlations", "\n") + print(correlations) + +} + +#' @author Florian Hartig +#' @method print mcmcSamplerList +#' @export +print.mcmcSamplerList <- function(x, ...){ + print("mcmcSamplerList - you can use the following methods to summarize, plot or reduce this class:") + print(methods(class ="mcmcSamplerList")) + #codaChain = getSample(sampler, coda = T, ...) + #rejectionRate(sampler$codaChain) + #effectiveSize(sampler$codaChain) +} + +#' @method plot mcmcSamplerList +#' @export +plot.mcmcSamplerList <- function(x, ...){ + tracePlot(x, ...) +} + +#' @author Florian Hartig +#' @export +getSample.mcmcSamplerList <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = 1, numSamples = NULL, whichParameters = NULL, reportDiagnostics, ...){ + + if(!is.null(numSamples)) numSamples = ceiling(numSamples/length(sampler)) + + if(coda == F){ + # out = NULL + out <- rep(list(NA), length(sampler)) + for (i in 1:length(sampler)){ + # out = rbind(out, getSample(sampler[[i]], parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics= F)) + out[[i]] <- getSample(sampler[[i]], parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics= F) + } + out <- combineChains(out) + } + + if(coda == T){ + + out = list() + + for (i in 1:length(sampler)){ + + out[[i]] = getSample(sampler[[i]], parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics= F) + } + + if(inherits(out[[1]], "mcmc.list")) out = unlist(out, recursive = F) + class(out) = "mcmc.list" + out = out + } + + return(out) +} diff --git a/BayesianTools/R/classPosterior.R b/BayesianTools/R/classPosterior.R index 9c4b3c5..591b112 100644 --- a/BayesianTools/R/classPosterior.R +++ b/BayesianTools/R/classPosterior.R @@ -1,57 +1,57 @@ -#' Creates a standardized posterior class -#' @author Florian Hartig -#' @param prior prior class -#' @param likelihood Log likelihood density -#' @details Function is internally used in \code{\link{createBayesianSetup}} to create a standarized posterior class. -#' @export -createPosterior <- function(prior, likelihood){ - - posterior <- function(x, returnAll = F){ - - if (is.vector(x)){ - priorResult = prior$density(x) # Checking if outside prior to save calculation time - if (! (priorResult == -Inf)) ll = likelihood$density(x) - else ll = -Inf - if (returnAll == F) return(ll + priorResult) - else return(c(ll + priorResult, ll, priorResult)) - - } else if(is.matrix(x)){ - - priorResult = prior$density(x) # Checking first if outside the prior to save calculation time - feasible <- (! priorResult == -Inf) - if (dim(x)[2] == 1) llResult <- likelihood$density(matrix(x[feasible, ], ncol = 1)) - else{ - if(TRUE %in% feasible) llResult <- likelihood$density(x[feasible, ]) - else llResult <- -Inf - } - post = priorResult - ll = priorResult - ll[!feasible] = NA - ll[feasible] = llResult - post[feasible] = post[feasible] + llResult - post[!feasible] = -Inf - if (returnAll == F) return(post) - else{ - out <- cbind(post, ll, priorResult) - colnames(out) = c("posterior", "likelihood", "prior") - return(out) - } - } - else stop("parameter must be vector or matrix") - } - - out<- list(density = posterior) - class(out) <- "posterior" - return(out) -} - -# likelihood <- function(x)stop("a") -# prior <- createPrior(function(x) sum(dunif(x, log = T))) -# -# x = createPosterior(prior, likelihood) -# -# x$density(c(0.2,0.2)) -# prior$density(c(2,2)) -# -# -# x = c(0.2,0.2) +#' Creates a standardized posterior class +#' @author Florian Hartig +#' @param prior prior class +#' @param likelihood log likelihood density +#' @details Function is internally used in \code{\link{createBayesianSetup}} to create a standardized posterior class. +#' @export +createPosterior <- function(prior, likelihood){ + + posterior <- function(x, returnAll = F){ + + if (is.vector(x)){ + priorResult = prior$density(x) # Checking if outside prior to save calculation time + if (! (priorResult == -Inf)) ll = likelihood$density(x) + else ll = -Inf + if (returnAll == F) return(ll + priorResult) + else return(c(ll + priorResult, ll, priorResult)) + + } else if(is.matrix(x)){ + + priorResult = prior$density(x) # Checking first if outside the prior to save calculation time + feasible <- (! priorResult == -Inf) + if (dim(x)[2] == 1) llResult <- likelihood$density(matrix(x[feasible, ], ncol = 1)) + else{ + if(TRUE %in% feasible) llResult <- likelihood$density(x[feasible, ]) + else llResult <- -Inf + } + post = priorResult + ll = priorResult + ll[!feasible] = NA + ll[feasible] = llResult + post[feasible] = post[feasible] + llResult + post[!feasible] = -Inf + if (returnAll == F) return(post) + else{ + out <- cbind(post, ll, priorResult) + colnames(out) = c("posterior", "likelihood", "prior") + return(out) + } + } + else stop("parameter must be vector or matrix") + } + + out<- list(density = posterior) + class(out) <- "posterior" + return(out) +} + +# likelihood <- function(x)stop("a") +# prior <- createPrior(function(x) sum(dunif(x, log = T))) +# +# x = createPosterior(prior, likelihood) +# +# x$density(c(0.2,0.2)) +# prior$density(c(2,2)) +# +# +# x = c(0.2,0.2) diff --git a/BayesianTools/R/classPrior.R b/BayesianTools/R/classPrior.R index efb0215..3e47a5a 100644 --- a/BayesianTools/R/classPrior.R +++ b/BayesianTools/R/classPrior.R @@ -1,266 +1,266 @@ -#' Creates a standardized prior class -#' @author Florian Hartig -#' @param density Prior density -#' @param sampler Sampling function for density (optional) -#' @param lower vector with lower bounds of parameters -#' @param upper vector with upper bounds of parameter -#' @param best vector with "best" parameter values -#' @details This is the general prior generator. It is highly recommended to not only implement the density, but also the sampler function. If this is not done, the user will have to provide explicit starting values for many of the MCMC samplers. Note the existing, more specialized prior function. If your prior can be created by those, they are preferred. Note also that priors can be created from an existing MCMC output from BT, or another MCMC sample, via \code{\link{createPriorDensity}}. -#' @note min and max truncate, but not re-normalize the prior density (so, if a pdf that integrated to one is truncated, the integral will in general be smaller than one). For MCMC sampling, this doesn't make a difference, but if absolute values of the prior density are a concern, one should provide a truncated density function for the prior. -#' @export -#' @seealso \code{\link{createPriorDensity}} \cr -#' \code{\link{createBetaPrior}} \cr -#' \code{\link{createUniformPrior}} \cr -#' \code{\link{createTruncatedNormalPrior}}\cr -#' \code{\link{createBayesianSetup}}\cr -#' @example /inst/examples/createPrior.R -createPrior <- function(density = NULL, sampler = NULL, lower = NULL, upper = NULL, best = NULL){ - - # case density is a Bayesian Posterior - if(inherits(density,"bayesianOutput")) return(createPriorDensity(density, lower = lower, upper = upper, best = best)) - - if(! is.null(lower) & ! is.null(upper)) if(any(lower > upper)) stop("prior with lower values > upper") - - if(is.null(best) & ! is.null(lower) & ! is.null(upper)) best = (upper + lower) / 2 - - # if no density is provided - if (is.null(density)){ - density <- function(x){ - return(0) - } - } - - catchingPrior <- function(x){ - - # check if bounds are respected - if(!is.null(lower)){ - if (any(x < lower)) return(-Inf) - } - if(!is.null(upper)){ - if (any(x > upper)) return(-Inf) - } - - # calculate prior density within try-catch statement - out <- tryCatch( - { - density(x) - }, - error=function(cond) { - warning("Problem in the prior", cond) - return(-Inf) - } - ) - # extra check - if (out == Inf) stop("Inf encountered in prior") - - return(out) - } - - parallelDensity<- function(x){ - if (is.vector(x)) return(catchingPrior(x)) - else if(is.matrix(x)) return(apply(x, 1, catchingPrior)) - else stop("parameter must be vector or matrix") - } - - # Check and parallelize the sampler - # if no sampler is passed, but lower and upper, generate uniform sampler - if (is.null(sampler) && !is.null(lower) && !is.null(upper)) { - sampler <- function(n = 1) { - runif(n, lower, upper) - } - } - - if(!is.null(sampler)){ - npar <- length(sampler()) - parallelSampler <- function(n=NULL){ - if(is.null(n)) out = sampler() - else{ - if (npar == 1) out = matrix(replicate(n, sampler())) - else if (npar >1) out = t(replicate(n, sampler(), simplify = T)) - else stop("sampler provided doesn't work") - } - return(out) - } - } else parallelSampler = function(n = NULL){ - stop("Attept to call the sampling function of the prior, although this function has not been provided in the Bayesian setup. A likely cause of this error is that you use a function or sampling algorithm that tries to sample from the prior. Either change the settings of your function, or provide a sampling function in your BayesianSetup (see ?createBayesianSetup, and ?createPrior)") - } - - checkPrior <- function(x = NULL, z = FALSE){ - if(is.null(x)) x <- parallelSampler(1000) - if(is.function(x)) x <- x() - if(!is.matrix(x)) x <- parallelSampler(1000) - check <- parallelDensity(x) - if(any(is.infinite(check))) { - if(z) warning("Z matrix values outside prior range", call. = FALSE) - else warning("Start values outside prior range", call. = FALSE) - } - } - - - - out<- list(density = parallelDensity, sampler = parallelSampler, lower = lower, upper = upper, best = best, originalDensity = density, checkStart = checkPrior) - class(out) <- "prior" - return(out) -} - - -#' Convenience function to create a simple uniform prior distribution -#' @author Florian Hartig -#' @param lower vector of lower prior range for all parameters -#' @param upper vector of upper prior range for all parameters -#' @param best vector with "best" values for all parameters -#' @note for details see \code{\link{createPrior}} -#' @seealso \code{\link{createPriorDensity}}, \code{\link{createPrior}}, \code{\link{createBetaPrior}}, \code{\link{createTruncatedNormalPrior}}, \code{\link{createBayesianSetup}} -#' @example /inst/examples/createPrior.R -#' @export -createUniformPrior<- function(lower, upper, best = NULL){ - len = length(lower) - density <- function(x){ - if (length(x) != len) stop("parameter vector does not match prior") - else return(sum(dunif(x, min = lower, max = upper, log = T))) - } - sampler <- function() runif(len, lower, upper) - - out <- createPrior(density = density, sampler = sampler, lower = lower, upper = upper, best = best) - return(out) -} - - -#' Convenience function to create a truncated normal prior -#' @author Florian Hartig -#' @param mean best estimate for each parameter -#' @param sd sdandard deviation -#' @param lower vector of lower prior range for all parameters -#' @param upper vector of upper prior range for all parameters -#' @note for details see \code{\link{createPrior}} -#' @seealso \code{\link{createPriorDensity}} \cr -#' \code{\link{createPrior}} \cr -#' \code{\link{createBetaPrior}} \cr -#' \code{\link{createUniformPrior}} \cr -#' \code{\link{createBayesianSetup}} \cr -#' @export -#' @example /inst/examples/createPrior.R -createTruncatedNormalPrior<- function(mean, sd, lower, upper){ - len = length(mean) - density <- function(x){ - if (length(x) != len) stop("parameter vector does not match prior") - else return(sum(msm::dtnorm(x, mean = mean, sd = sd, lower = lower, upper = upper, log = T))) - } - sampler <- function(){ - msm::rtnorm(n = length(mean), mean = mean, sd = sd, lower = lower, upper = upper) - } - out <- createPrior(density = density, sampler = sampler, lower = lower, upper = upper) - return(out) -} - - -#' Convenience function to create a beta prior -#' @author Florian Hartig -#' @param a shape1 of the beta distribution -#' @param b shape2 of the beta distribution -#' @param upper upper values for the parameters -#' @param lower lower values for the parameters -#' @note for details see \code{\link{createPrior}} -#' @details This creates a beta prior, assuming that lower / upper values for parameters are are fixed. The beta is the calculated relative to this lower / upper space. -#' @seealso \code{\link{createPriorDensity}} \cr -#' \code{\link{createPrior}} \cr -#' \code{\link{createTruncatedNormalPrior}} \cr -#' \code{\link{createUniformPrior}} \cr -#' \code{\link{createBayesianSetup}} \cr -#' @example /inst/examples/createPrior.R -#' @export -createBetaPrior<- function(a, b, lower=0, upper=1){ - len = length(lower) - if (! any(upper > lower)) stop("wrong values in beta prior") - range = upper - lower - density <- function(x){ - x = (x - lower) / range - if (length(x) != len) stop("parameter vector does not match prior") - else return(sum( dbeta(x, shape1 = a, shape2 = b, log=T) )) - } - sampler <- function(){ - out = rbeta(n = len, shape1 = a, shape2 = b) - out = (out * range) + lower - return(out) - } - out <- createPrior(density = density, sampler = sampler, lower = lower, upper = upper) - return(out) -} - - -#' Fits a density function to a multivariate sample -#' -#' @author Florian Hartig -#' @export -#' @param sampler an object of class BayesianOutput or a matrix -#' @param method method to generate prior - default and currently only option is multivariate -#' @param eps numerical precision to avoid singularity -#' @param lower vector with lower bounds of parameter for the new prior, independent of the input sample -#' @param upper vector with upper bounds of parameter for the new prior, independent of the input sample -#' @param best vector with "best" values of parameter for the new prior, independent of the input sample -#' @param scaling optional scaling factor for the covariance. If scaling > 1 will create a prior wider than the posterior, < 1 a prior more narrow than the posterior. Scaling is linear to the posterior width, i.e. scaling = 2 will create a prior that with 2x the sd of the original posterior. -#' @param ... parameters to pass on to the getSample function -#' -#' @details This function fits a density estimator to a multivariate (typically a posterior) sample. The main purpose is to summarize a posterior sample as a pdf, in order to include it as a prior in a new analysis, for example when new data becomes available, or to calculate a fractional Bayes factor (see \code{\link{marginalLikelihood}}). -#' -#' The limitation of this function is that we currently only implement a multivariate normal density estimator, so you will have a loss of information if your posterior is not approximately multivariate normal, which is likely the case if you have weak data. Extending the function to include more flexible density estimators (e.g. gaussian processes) is on our todo list, but it's quite tricky to get this stable, so I'm not sure when we will have this working. In general, creating reliable empirical density estimates in high-dimensional parameter spaces is extremely tricky, regardless of the software you are using. -#' -#' For that reason, it is usually recommended to not update the posterior with this option, but rather: -#' -#' 1. If the full dataset is available, to make a single, or infrequent updates, recompute the entire model with the full / updated data -#' -#' 2. For frequent updates, consider using SMC instead of MCMC sampling. SMC sampling doesn't require an analytical summary of the posterior. -#' -#' @seealso \code{\link{createPrior}} \cr -#' \code{\link{createBetaPrior}} \cr -#' \code{\link{createTruncatedNormalPrior}} \cr -#' \code{\link{createUniformPrior}} \cr -#' \code{\link{createBayesianSetup}} \cr -#' @example /inst/examples/createPrior.R -createPriorDensity <- function(sampler, method = "multivariate", eps = 1e-10, lower = NULL, upper = NULL, best = NULL, scaling = 1, ...){ - - x = getSample(sampler, ...) - - if(method == "multivariate"){ - nPars = ncol(x) - covar = cov(x) * scaling^2 - mean = apply(x, 2, mean) - if(is.null(lower)) lower = rep(-Inf, length = length(mean)) - if(is.null(upper)) upper = rep(Inf, length = length(mean)) - - density = function(par){ - dens = tmvtnorm::dtmvnorm(x = par, mean = mean, sigma = covar + eps, log = T, lower = lower, upper = upper) - return(dens) - } - - sampler = function(n=1){ - par <- tmvtnorm::rtmvnorm(n = n, mean = mean, sigma = covar + eps, lower = lower, upper = upper, algorithm = "rejection") - if (n == 1) par = as.vector(par) - return(par) - } - - out <- createPrior(density = density, sampler = sampler, lower = lower, upper = upper, best = best) - return(out) - } -} - - - -#' @author Maximilian Pichler - -#' @export - -print.prior <- function(x, ...){ - cat('Prior: \n\n') - - prior = x - info = c( "lower", "upper","best") - maxPar = max(length(prior$lower),length(prior$lupper)) - if(maxPar == 0) maxPar = ncol(prior$sampler()) - priorInfo = data.frame(matrix(NA, ncol = 3, nrow = maxPar)) - colnames(priorInfo) = info - for(i in 1:3) if(!is.null(prior[[info[i]]])) priorInfo[,i] <- prior[[info[i]]] - rownames(priorInfo) <- sapply(1:maxPar, FUN = function(x) return(paste("par",x))) - print(priorInfo) - -} +#' Creates a standardized prior class +#' @author Florian Hartig +#' @param density prior density +#' @param sampler Sampling function for density (optional) +#' @param lower vector with lower bounds of parameters +#' @param upper vector with upper bounds of parameter +#' @param best vector with "best" parameter values +#' @details This is the general prior generator. It is highly recommended to implement both the density and sampler function. If not, the user will have to provide explicit starting values for many of the MCMC samplers. Note the existing, more specialized prior functions. It is recommended to use those specialized prior functions, if possible. Also note that priors can be created from an existing MCMC output from BT, or another MCMC sample, via \code{\link{createPriorDensity}}. +#' @note min and max truncate, but not re-normalize the prior density (so, if a pdf that integrated to one is truncated, the integral will in general be smaller than one). For MCMC sampling, this doesn't make a difference, but if absolute values of the prior density are a concern, one should provide a truncated density function for the prior. +#' @export +#' @seealso \code{\link{createPriorDensity}} \cr +#' \code{\link{createBetaPrior}} \cr +#' \code{\link{createUniformPrior}} \cr +#' \code{\link{createTruncatedNormalPrior}}\cr +#' \code{\link{createBayesianSetup}}\cr +#' @example /inst/examples/createPrior.R +createPrior <- function(density = NULL, sampler = NULL, lower = NULL, upper = NULL, best = NULL){ + + # case density is a Bayesian Posterior + if(inherits(density,"bayesianOutput")) return(createPriorDensity(density, lower = lower, upper = upper, best = best)) + + if(! is.null(lower) & ! is.null(upper)) if(any(lower > upper)) stop("prior with lower values > upper") + + if(is.null(best) & ! is.null(lower) & ! is.null(upper)) best = (upper + lower) / 2 + + # if no density is provided + if (is.null(density)){ + density <- function(x){ + return(0) + } + } + + catchingPrior <- function(x){ + + # check if bounds are respected + if(!is.null(lower)){ + if (any(x < lower)) return(-Inf) + } + if(!is.null(upper)){ + if (any(x > upper)) return(-Inf) + } + + # calculate prior density within try-catch statement + out <- tryCatch( + { + density(x) + }, + error=function(cond) { + warning("Problem in the prior", cond) + return(-Inf) + } + ) + # extra check + if (out == Inf) stop("Inf encountered in prior") + + return(out) + } + + parallelDensity<- function(x){ + if (is.vector(x)) return(catchingPrior(x)) + else if(is.matrix(x)) return(apply(x, 1, catchingPrior)) + else stop("parameter must be vector or matrix") + } + + # Check and parallelize the sampler + # if no sampler is passed, but lower and upper, generate uniform sampler + if (is.null(sampler) && !is.null(lower) && !is.null(upper)) { + sampler <- function(n = 1) { + runif(n, lower, upper) + } + } + + if(!is.null(sampler)){ + npar <- length(sampler()) + parallelSampler <- function(n=NULL){ + if(is.null(n)) out = sampler() + else{ + if (npar == 1) out = matrix(replicate(n, sampler())) + else if (npar >1) out = t(replicate(n, sampler(), simplify = T)) + else stop("sampler provided doesn't work") + } + return(out) + } + } else parallelSampler = function(n = NULL){ + stop("Attept to call the sampling function of the prior, although this function has not been provided in the Bayesian setup. A likely cause of this error is that you use a function or sampling algorithm that tries to sample from the prior. Either change the settings of your function, or provide a sampling function in your BayesianSetup (see ?createBayesianSetup, and ?createPrior)") + } + + checkPrior <- function(x = NULL, z = FALSE){ + if(is.null(x)) x <- parallelSampler(1000) + if(is.function(x)) x <- x() + if(!is.matrix(x)) x <- parallelSampler(1000) + check <- parallelDensity(x) + if(any(is.infinite(check))) { + if(z) warning("Z matrix values outside prior range", call. = FALSE) + else warning("Start values outside prior range", call. = FALSE) + } + } + + + + out<- list(density = parallelDensity, sampler = parallelSampler, lower = lower, upper = upper, best = best, originalDensity = density, checkStart = checkPrior) + class(out) <- "prior" + return(out) +} + + +#' Convenience function to create a simple uniform prior distribution +#' @author Florian Hartig +#' @param lower vector of lower prior range for all parameters +#' @param upper vector of upper prior range for all parameters +#' @param best vector with "best" values for all parameters +#' @note for details see \code{\link{createPrior}} +#' @seealso \code{\link{createPriorDensity}}, \code{\link{createPrior}}, \code{\link{createBetaPrior}}, \code{\link{createTruncatedNormalPrior}}, \code{\link{createBayesianSetup}} +#' @example /inst/examples/createPrior.R +#' @export +createUniformPrior<- function(lower, upper, best = NULL){ + len = length(lower) + density <- function(x){ + if (length(x) != len) stop("parameter vector does not match prior") + else return(sum(dunif(x, min = lower, max = upper, log = T))) + } + sampler <- function() runif(len, lower, upper) + + out <- createPrior(density = density, sampler = sampler, lower = lower, upper = upper, best = best) + return(out) +} + + +#' Convenience function to create a truncated normal prior +#' @author Florian Hartig +#' @param mean best estimate for each parameter +#' @param sd sdandard deviation +#' @param lower vector of lower prior range for all parameters +#' @param upper vector of upper prior range for all parameters +#' @note for details see \code{\link{createPrior}} +#' @seealso \code{\link{createPriorDensity}} \cr +#' \code{\link{createPrior}} \cr +#' \code{\link{createBetaPrior}} \cr +#' \code{\link{createUniformPrior}} \cr +#' \code{\link{createBayesianSetup}} \cr +#' @export +#' @example /inst/examples/createPrior.R +createTruncatedNormalPrior<- function(mean, sd, lower, upper){ + len = length(mean) + density <- function(x){ + if (length(x) != len) stop("parameter vector does not match prior") + else return(sum(msm::dtnorm(x, mean = mean, sd = sd, lower = lower, upper = upper, log = T))) + } + sampler <- function(){ + msm::rtnorm(n = length(mean), mean = mean, sd = sd, lower = lower, upper = upper) + } + out <- createPrior(density = density, sampler = sampler, lower = lower, upper = upper) + return(out) +} + + +#' Convenience function to create a beta prior +#' @author Florian Hartig +#' @param a shape1 of the beta distribution +#' @param b shape2 of the beta distribution +#' @param upper upper values for the parameters +#' @param lower lower values for the parameters +#' @note for details see \code{\link{createPrior}} +#' @details This creates a beta prior, assuming that lower / upper values for parameters are are fixed. The beta is the calculated relative to this lower / upper space. +#' @seealso \code{\link{createPriorDensity}} \cr +#' \code{\link{createPrior}} \cr +#' \code{\link{createTruncatedNormalPrior}} \cr +#' \code{\link{createUniformPrior}} \cr +#' \code{\link{createBayesianSetup}} \cr +#' @example /inst/examples/createPrior.R +#' @export +createBetaPrior<- function(a, b, lower=0, upper=1){ + len = length(lower) + if (! any(upper > lower)) stop("wrong values in beta prior") + range = upper - lower + density <- function(x){ + x = (x - lower) / range + if (length(x) != len) stop("parameter vector does not match prior") + else return(sum( dbeta(x, shape1 = a, shape2 = b, log=T) )) + } + sampler <- function(){ + out = rbeta(n = len, shape1 = a, shape2 = b) + out = (out * range) + lower + return(out) + } + out <- createPrior(density = density, sampler = sampler, lower = lower, upper = upper) + return(out) +} + + +#' Fits a density function to a multivariate sample +#' +#' @author Florian Hartig +#' @export +#' @param sampler an object of class BayesianOutput or a matrix +#' @param method method to generate prior - default and currently only option is multivariate +#' @param eps numerical precision to avoid singularity +#' @param lower vector with lower bounds of parameter for the new prior, independent of the input sample +#' @param upper vector with upper bounds of parameter for the new prior, independent of the input sample +#' @param best vector with "best" values of parameter for the new prior, independent of the input sample +#' @param scaling optional scaling factor for the covariance. If scaling > 1 will create a prior wider than the posterior, < 1 a prior more narrow than the posterior. Scaling is linear to the posterior width, i.e. scaling = 2 will create a prior that with 2x the sd of the original posterior. +#' @param ... parameters to pass on to the getSample function +#' +#' @details This function fits a density estimator to a multivariate (typically a posterior) sample. The main purpose is to summarize a posterior sample as a pdf, in order to include it as a prior in a new analysis, for example when new data becomes available, or to calculate a fractional Bayes factor (see \code{\link{marginalLikelihood}}). +#' +#' The limitation of this function is that we currently only implement a multivariate normal density estimator, so you will have a loss of information if your posterior is not approximately multivariate normal, which is likely the case if you have weak data. Extending the function to include more flexible density estimators (e.g. gaussian processes) is on our todo list, but it's quite tricky to get this stable, so I'm not sure when we will have this working. In general, creating reliable empirical density estimates in high-dimensional parameter spaces is extremely tricky, regardless of the software you are using. +#' +#' For that reason, it is usually recommended to not update the posterior with this option, but rather: +#' +#' 1. If the full dataset is available, to make a single, or infrequent updates, recompute the entire model with the full / updated data +#' +#' 2. For frequent updates, consider using SMC instead of MCMC sampling. SMC sampling doesn't require an analytical summary of the posterior. +#' +#' @seealso \code{\link{createPrior}} \cr +#' \code{\link{createBetaPrior}} \cr +#' \code{\link{createTruncatedNormalPrior}} \cr +#' \code{\link{createUniformPrior}} \cr +#' \code{\link{createBayesianSetup}} \cr +#' @example /inst/examples/createPrior.R +createPriorDensity <- function(sampler, method = "multivariate", eps = 1e-10, lower = NULL, upper = NULL, best = NULL, scaling = 1, ...){ + + x = getSample(sampler, ...) + + if(method == "multivariate"){ + nPars = ncol(x) + covar = cov(x) * scaling^2 + mean = apply(x, 2, mean) + if(is.null(lower)) lower = rep(-Inf, length = length(mean)) + if(is.null(upper)) upper = rep(Inf, length = length(mean)) + + density = function(par){ + dens = tmvtnorm::dtmvnorm(x = par, mean = mean, sigma = covar + eps, log = T, lower = lower, upper = upper) + return(dens) + } + + sampler = function(n=1){ + par <- tmvtnorm::rtmvnorm(n = n, mean = mean, sigma = covar + eps, lower = lower, upper = upper, algorithm = "rejection") + if (n == 1) par = as.vector(par) + return(par) + } + + out <- createPrior(density = density, sampler = sampler, lower = lower, upper = upper, best = best) + return(out) + } +} + + + +#' @author Maximilian Pichler + +#' @export + +print.prior <- function(x, ...){ + cat('Prior: \n\n') + + prior = x + info = c( "lower", "upper","best") + maxPar = max(length(prior$lower),length(prior$lupper)) + if(maxPar == 0) maxPar = ncol(prior$sampler()) + priorInfo = data.frame(matrix(NA, ncol = 3, nrow = maxPar)) + colnames(priorInfo) = info + for(i in 1:3) if(!is.null(prior[[info[i]]])) priorInfo[,i] <- prior[[info[i]]] + rownames(priorInfo) <- sapply(1:maxPar, FUN = function(x) return(paste("par",x))) + print(priorInfo) + +} diff --git a/BayesianTools/R/classSMCSamplerList.R b/BayesianTools/R/classSMCSamplerList.R index 529e0e0..fa55d09 100644 --- a/BayesianTools/R/classSMCSamplerList.R +++ b/BayesianTools/R/classSMCSamplerList.R @@ -1,58 +1,58 @@ -#' Convenience function to create an object of class SMCSamplerList from a list of mcmc samplers -#' @author Florian Hartig -#' @param ... a list of MCMC samplers -#' @return a list of class smcSamplerList with each object being an smcSampler -#' @export -createSmcSamplerList <- function(...){ - smcList <- list(...) - for (i in 1:length(smcList)){ - if (! ("mcmcSampler" %in% class(smcList[[i]])) ) stop("list objects are not of class mcmcSampler") - } - class(smcList) = c("smcSamplerList", "bayesianOutput") - return(smcList) -} - - -#' @method summary smcSamplerList -#' @author Florian Hartig -#' @export -summary.smcSamplerList <- function(object, ...){ - sample = getSample(object, parametersOnly = T, ...) - summary(sample) -} - -#' @method print smcSamplerList -#' @author Florian Hartig -#' @export -print.smcSamplerList <- function(x, ...){ - print("smcSamplerList - you can use the following methods to summarize, plot or reduce this class:") - print(methods(class ="smcSamplerList")) -} - -#' @method plot smcSamplerList -#' @export -plot.smcSamplerList <- function(x, ...){ - marginalPlot(x, ...) -} - -#' @export -getSample.smcSamplerList <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = 1, - numSamples = NULL, whichParameters = NULL, reportDiagnostics = FALSE, ...){ - - out = list() - - for (i in 1:length(sampler)){ - - out[[i]] = getSample(sampler[[i]], parametersOnly = parametersOnly, whichParameters = whichParameters, start = start, end = end, thin = thin, - numSamples = numSamples, coda = F, reportDiagnostics = F) - - } - out = combineChains(out, merge =F) - - return(out) -} - - - - - +#' Convenience function to create an object of class SMCSamplerList from a list of mcmc samplers +#' @author Florian Hartig +#' @param ... a list of MCMC samplers +#' @return a list of class smcSamplerList with objects of smcSampler +#' @export +createSmcSamplerList <- function(...){ + smcList <- list(...) + for (i in 1:length(smcList)){ + if (! ("mcmcSampler" %in% class(smcList[[i]])) ) stop("list objects are not of class mcmcSampler") + } + class(smcList) = c("smcSamplerList", "bayesianOutput") + return(smcList) +} + + +#' @method summary smcSamplerList +#' @author Florian Hartig +#' @export +summary.smcSamplerList <- function(object, ...){ + sample = getSample(object, parametersOnly = T, ...) + summary(sample) +} + +#' @method print smcSamplerList +#' @author Florian Hartig +#' @export +print.smcSamplerList <- function(x, ...){ + print("smcSamplerList - you can use the following methods to summarize, plot or reduce this class:") + print(methods(class ="smcSamplerList")) +} + +#' @method plot smcSamplerList +#' @export +plot.smcSamplerList <- function(x, ...){ + marginalPlot(x, ...) +} + +#' @export +getSample.smcSamplerList <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = 1, + numSamples = NULL, whichParameters = NULL, reportDiagnostics = FALSE, ...){ + + out = list() + + for (i in 1:length(sampler)){ + + out[[i]] = getSample(sampler[[i]], parametersOnly = parametersOnly, whichParameters = whichParameters, start = start, end = end, thin = thin, + numSamples = numSamples, coda = F, reportDiagnostics = F) + + } + out = combineChains(out, merge =F) + + return(out) +} + + + + + From 0df6ff5f0438061bd2e2538532ddde415d32a778 Mon Sep 17 00:00:00 2001 From: Tahmina Mojumder Date: Thu, 31 Aug 2023 11:42:43 +0200 Subject: [PATCH 04/13] Updated help files for functions with names starting from g to m. --- BayesianTools/R/MAP.R | 38 +-- BayesianTools/R/getVolume.R | 70 ++--- BayesianTools/R/marginalLikelihood.R | 378 +++++++++++++-------------- 3 files changed, 243 insertions(+), 243 deletions(-) diff --git a/BayesianTools/R/MAP.R b/BayesianTools/R/MAP.R index 6877e8c..c07efc4 100644 --- a/BayesianTools/R/MAP.R +++ b/BayesianTools/R/MAP.R @@ -1,20 +1,20 @@ -#' calculates the Maxiumum APosteriori value (MAP) -#' @author Florian Hartig -#' @param bayesianOutput an object of class BayesianOutput (mcmcSampler, smcSampler, or mcmcList) -#' @param ... optional values to be passed on the the getSample function -#' @details Currently, this function simply returns the parameter combination with the highest posterior in the chain. A more refined option would be to take the MCMC sample and do additional calculations, e.g. use an optimizer, a kerne delnsity estimator, or some other tool to search / interpolate around the best value in the chain -#' @seealso \code{\link{WAIC}}, \code{\link{DIC}}, \code{\link{marginalLikelihood}} -#' @export -MAP <- function(bayesianOutput, ...){ - - samples = getSample(bayesianOutput, parametersOnly = F, ...) - - if("mcmcSamplerList" %in% class(bayesianOutput)) nPars <- bayesianOutput[[1]]$setup$numPars - else nPars = bayesianOutput$setup$numPars - - best = which.max(samples[,nPars + 1]) - - return(list(parametersMAP = samples[best, 1:nPars], valuesMAP = samples[best, (nPars + 1):(nPars + 3)] )) - -} +#' calculates the Maxiumum APosteriori value (MAP) +#' @author Florian Hartig +#' @param bayesianOutput an object of class BayesianOutput (mcmcSampler, smcSampler, or mcmcList) +#' @param ... optional values to be passed on the the getSample function +#' @details Currently, this function simply returns the parameter combination with the highest posterior in the chain. A more refined option would be to take the MCMC sample and do additional calculations, e.g. use an optimizer, a kernel density estimator, or some other tool to search / interpolate around the best value in the chain. +#' @seealso \code{\link{WAIC}}, \code{\link{DIC}}, \code{\link{marginalLikelihood}} +#' @export +MAP <- function(bayesianOutput, ...){ + + samples = getSample(bayesianOutput, parametersOnly = F, ...) + + if("mcmcSamplerList" %in% class(bayesianOutput)) nPars <- bayesianOutput[[1]]$setup$numPars + else nPars = bayesianOutput$setup$numPars + + best = which.max(samples[,nPars + 1]) + + return(list(parametersMAP = samples[best, 1:nPars], valuesMAP = samples[best, (nPars + 1):(nPars + 3)] )) + +} \ No newline at end of file diff --git a/BayesianTools/R/getVolume.R b/BayesianTools/R/getVolume.R index 3eef157..a37f4c5 100644 --- a/BayesianTools/R/getVolume.R +++ b/BayesianTools/R/getVolume.R @@ -1,35 +1,35 @@ -#' Calculate posterior volume -#' @author Florian Hartig -#' @param sampler an object of superclass bayesianOutput or any other class that has the getSample function implemented (e.g. Matrix) -#' @param prior schould also prior volume be calculated -#' @param method method for volume estimation. Currently, the only option is "MVN" -#' @param ... additional parameters to pass on to the \code{\link{getSample}} -#' @details The idea of this function is to provide an estimate of the "posterior volume", i.e. how "broad" the posterior is. One potential application is to the overall reduction of parametric uncertainty between different data types, or between prior and posterior. -#' -#' Implemented methods for volume estimation: -#' -#' Option "MVN" - in this option, the volume is calculated as the determinant of the covariance matrix of the prior / posterior sample. -#' -#' @example /inst/examples/getVolume.R -#' @export -getVolume <- function(sampler, prior = F, method = "MVN", ...){ - - x = getSample(sampler, ...) - - if(method == "MVN"){ - nPars = ncol(x) - postVol = det(cov(x)) - }else stop("BayesianTools: unknown method argument in getVolume") - - if(prior == T){ - x = sampler$setup$prior$sampler(5000) - - if(method == "MVN"){ - nPars = ncol(x) - priorVol = det(cov(x)) - }else stop("BayesianTools: unknown method argument in getVolume") - return(list(priorVol = priorVol, postVol = postVol)) - }else return(postVol) -} - - +#' Calculate posterior volume +#' @author Florian Hartig +#' @param sampler an object of superclass bayesianOutput or any other class that has implemented the getSample function (e.g. Matrix) +#' @param prior logical, should prior volume be calculated? +#' @param method method for volume estimation. Currently, the only option is "MVN" +#' @param ... additional parameters to pass on to the \code{\link{getSample}} +#' @details The idea of this function is to provide an estimate of the "posterior volume", i.e. how "broad" the posterior is. One potential application is the overall reduction of parametric uncertainty between different data types, or between prior and posterior. +#' +#' Implemented methods for volume estimation: +#' +#' Option "MVN" - in this option, the volume is calculated as the determinant of the covariance matrix of the prior / posterior sample. +#' +#' @example /inst/examples/getVolume.R +#' @export +getVolume <- function(sampler, prior = F, method = "MVN", ...){ + + x = getSample(sampler, ...) + + if(method == "MVN"){ + nPars = ncol(x) + postVol = det(cov(x)) + }else stop("BayesianTools: unknown method argument in getVolume") + + if(prior == T){ + x = sampler$setup$prior$sampler(5000) + + if(method == "MVN"){ + nPars = ncol(x) + priorVol = det(cov(x)) + }else stop("BayesianTools: unknown method argument in getVolume") + return(list(priorVol = priorVol, postVol = postVol)) + }else return(postVol) +} + + diff --git a/BayesianTools/R/marginalLikelihood.R b/BayesianTools/R/marginalLikelihood.R index 764c4e3..940c55d 100644 --- a/BayesianTools/R/marginalLikelihood.R +++ b/BayesianTools/R/marginalLikelihood.R @@ -1,189 +1,189 @@ - -# Motivation for this functions from -# https://radfordneal.wordpress.com/2008/08/17/the-harmonic-mean-of-the-likelihood-worst-monte-carlo-method-ever/ -# https://gist.github.com/gaberoo/4619102 - - -# ' @export -#marginalLikelihood <- function(x,lik,V,sampler$setup$likelihood$density,sampler$setup$prior$density,..., num.samples=1000,log=TRUE) UseMethod("marginalLikelihood") - -#' Calcluated the marginal likelihood from a set of MCMC samples -#' @export -#' @author Florian Hartig -#' @param sampler an MCMC or SMC sampler or list, or for method "Prior" also a BayesianSetup -#' @param numSamples number of samples to use. How this works, and if it requires recalculating the likelihood, depends on the method -#' @param method method to choose. Currently available are "Chib" (default), the harmonic mean "HM", sampling from the prior "Prior", and bridge sampling "Bridge". See details -#' @param ... further arguments passed to \code{\link{getSample}} -#' @details The marginal likelihood is the average likelihood across the prior space. It is used, for example, for Bayesian model selection and model averaging. -#' -#' It is defined as \deqn{ML = \int L(\Theta) p(\Theta) d\Theta} -#' -#' Given that MLs are calculated for each model, you can get posterior weights (for model selection and/or model averaging) on the model by -#' -#' \deqn{P(M_i|D) = ML_i * p(M_i) / (\sum_i ML_i * p(M_i) )} -#' -#' In BT, we return the log ML, so you will have to exp all values for this formula. -#' -#' It is well-known that the ML is VERY dependent on the prior, and in particular the choice of the width of uninformative priors may have major impacts on the relative weights of the models. It has therefore been suggested to not use the ML for model averaging / selection on uninformative priors. If you have no informative priors, and option is to split the data into two parts, use one part to generate informative priors for the model, and the second part for the model selection. See help for an example. -#' -#' The marginalLikelihood function currently implements four ways to calculate the marginal likelihood. Be aware that marginal likelihood calculations are notoriously prone to numerical stability issues. Especially in high-dimensional parameter spaces, there is no guarantee that any of the implemented algorithms will converge reasonably fast. The recommended (and default) method is the method "Chib" (Chib and Jeliazkov, 2001), which is based on MCMC samples, with a limited number of additional calculations. Despite being the current recommendation, note there are some numeric issues with this algorithm that may limit reliability for larger dimensions. -#' -#' The harmonic mean approximation, is implemented only for comparison. Note that the method is numerically unrealiable and usually should not be used. -#' -#' The third method is simply sampling from the prior. While in principle unbiased, it will only converge for a large number of samples, and is therefore numerically inefficient. -#' -#' The Bridge method uses bridge sampling as implemented in the R package "bridgesampling". It is potentially more exact than the Chib method, but might require more computation time. However, this may be very dependent on the sampler. -#' -#' @return A list with log of the marginal likelihood, as well as other diagnostics depending on the chose method -#' -#' @example /inst/examples/marginalLikelihoodHelp.R -#' @references -#' -#' Chib, Siddhartha, and Ivan Jeliazkov. "Marginal likelihood from the Metropolis-Hastings output." Journal of the American Statistical Association 96.453 (2001): 270-281. -#' -#' Dormann et al. 2018. Model averaging in ecology: a review of Bayesian, information-theoretic, and tactical approaches for predictive inference. Ecological Monographs -#' -#' @seealso \code{\link{WAIC}}, \code{\link{DIC}}, \code{\link{MAP}} -marginalLikelihood <- function(sampler, numSamples = 1000, method = "Chib", ...){ - - - if ((class(sampler)[1] %in% c("mcmcSamplerList", "smcSamplerList"))) { - setup <- sampler[[1]]$setup - posterior = sampler[[1]]$setup$posterior$density - } else if ((class(sampler)[1] %in% c("mcmcSampler", "smcSampler"))) { - setup <- sampler$setup - posterior = sampler$setup$posterior$density - } else if ((class(sampler)[1] %in% c("BayesianSetup"))) { - setup <- sampler - posterior = sampler$posterior$density - } else stop("sampler must be a sampler or a BayesianSetup") - - - if (method == "Chib"){ - - chain <- getSample(sampler = sampler, parametersOnly = F, ...) - - if(class(sampler)[1] %in% c("mcmcSamplerList", "smcSamplerList")) sampler <- sampler[[1]] - - x <- chain[,1:sampler$setup$numPars,drop=F] - - lik <- chain[,sampler$setup$numPars + 2] - MAPindex <- which.max(chain[,sampler$setup$numPars + 1]) - - #propGen = createProposalGenerator(covariance = cov(x)) - - V <- cov(x) - - # calculate reference parameter - - theta.star <- x[MAPindex,,drop=F] - lik.star <- lik[MAPindex] - - # get samples from posterior - - g <- sample.int(nrow(x), numSamples, replace=TRUE) # should replace really be true? - q.g <- mvtnorm::dmvnorm(x[g,,drop=F], mean = theta.star, sigma = V, log = FALSE) - lik.g <- lik[g] - alpha.g <- sapply(lik.g, function(l) min(1, exp(lik.star - l))) # Metropolis Ratio - - #lik.g <- apply(theta.g,1,sampler$setup$likelihood$density,...) - - - # get samples from proposal - theta.j <- mvtnorm::rmvnorm(numSamples, mean = theta.star, sigma = V) - lik.j <- apply(theta.j, 1, sampler$setup$likelihood$density) - alpha.j <- sapply(lik.j, function(l) min(1, exp(l - lik.star))) # Metropolis Ratio - - # Prior - pi.hat <- mean(alpha.g * q.g) / mean(alpha.j) - pi.star <- 0 - - if (!is.null(sampler$setup$prior$density)) pi.star <- sampler$setup$prior$density(theta.star) - ln.m <- lik.star + pi.star - log(pi.hat) - - out <- list(ln.ML = ln.m, ln.lik.star = lik.star, ln.pi.star = pi.star, ln.pi.hat = log(pi.hat), method = "Chib") - - } else if (method == "HM"){ - - warning("The Harmonic Mean estimator is notoriously unstable. It's only implemented for comparison. We strongly advice against using it for research!") - - chain <- getSample(sampler = sampler, parametersOnly = F, ...) - lik <- chain[, setup$numPars + 2] - ml <- log(1 / mean(1 / exp(lik))) - # ml = 1 / logSumExp(-lik, mean = T) function needs to be adjusted - out <- list(ln.ML=ml, method ="HM") - - } else if (method == "Prior"){ - - samples <- setup$prior$sampler(numSamples) - likelihoods <- setup$likelihood$density(samples) - - ml <- logSumExp(likelihoods, mean = T) - out <- list(ln.ML=ml, method ="Prior") - - } else if (method == "Bridge") { - - chain <- getSample(sampler = sampler, parametersOnly = F, numSamples = numSamples, ...) - - nParams <- setup$numPars - lower <- setup$prior$lower - upper <- setup$prior$upper - - - out <- list(ln.ML = bridgesample(chain ,nParams, lower, upper, posterior)$logml, method ="Bridge") - - } else if ("NN") { - - # TODO: implement nearest neighbour method: - # https://arxiv.org/abs/1704.03472 - stop("Not yet implemented") - - } else { - stop(paste(c("\"", method, "\" is not a valid method parameter!"), sep = " ", collapse = "")) - } - - return(out) -} - - -#' Calculates the marginal likelihood of a chain via bridge sampling -#' @export -#' @author Tankred Ott -#' @param chain a single mcmc chain with samples as rows and parameters and posterior density as columns. -#' @param nParams number of parameters -#' @param lower optional - lower bounds of the prior -#' @param upper optional - upper bounds of the prior -#' @param posterior posterior density function -#' @param ... arguments passed to bridge_sampler -#' @details This function uses "bridge_sampler" from the package "bridgesampling". -#' @example /inst/examples/bridgesampleHelp.R -#' @seealso \code{\link{marginalLikelihood}} -#' @keywords internal -bridgesample <- function (chain, nParams, lower = NULL, upper = NULL, posterior, ...) { - # TODO: implement this without bridgesampling package - # https://github.com/quentingronau/bridgesampling - if (is.null(lower)) lower <- rep(-Inf, nParams) - if (is.null(upper)) upper <- rep(Inf, nParams) - - names(lower) <- names(upper) <- colnames(chain[, 1:nParams]) - - log_posterior = function(x, data){ - return(posterior(x)) - } - - out <- bridgesampling::bridge_sampler( - samples = chain[, 1:nParams], - log_posterior = log_posterior, - data = chain, - lb = lower, - ub = upper, - ... - ) - - return(out) -} - - - - - + +# Motivation for this functions from +# https://radfordneal.wordpress.com/2008/08/17/the-harmonic-mean-of-the-likelihood-worst-monte-carlo-method-ever/ +# https://gist.github.com/gaberoo/4619102 + + +# ' @export +#marginalLikelihood <- function(x,lik,V,sampler$setup$likelihood$density,sampler$setup$prior$density,..., num.samples=1000,log=TRUE) UseMethod("marginalLikelihood") + +#' Calcluated the marginal likelihood from a set of MCMC samples +#' @export +#' @author Florian Hartig +#' @param sampler an MCMC or SMC sampler or list, or for method "Prior" also a BayesianSetup +#' @param numSamples number of samples to use. How this works, and if it requires recalculating the likelihood, depends on the method +#' @param method method to choose. Currently available are "Chib" (default), the harmonic mean "HM", sampling from the prior "Prior", and bridge sampling "Bridge". See details +#' @param ... further arguments passed to \code{\link{getSample}} +#' @details The marginal likelihood is the average likelihood across the prior space. It is used, for example, for Bayesian model selection and model averaging. +#' +#' It is defined as \deqn{ML = \int L(\Theta) p(\Theta) d\Theta} +#' +#' Given that MLs are calculated for each model, you can get posterior weights (for model selection and/or model averaging) on the model by +#' +#' \deqn{P(M_i|D) = ML_i * p(M_i) / (\sum_i ML_i * p(M_i) )} +#' +#' In BT, we return the log ML, so you will have to exp all values for this formula. +#' +#' It is well-known that the ML is strongly dependent on the prior, and in particular the choice of the width of uninformative priors may have major impacts on the relative weights of the models. It has therefore been suggested to not use the ML for model averaging / selection on uninformative priors. If you have no informative priors, and option is to split the data into two parts, use one part to generate informative priors for the model, and the second part for the model selection. See help for an example. +#' +#' The marginalLikelihood function currently implements four ways to calculate the marginal likelihood. Be aware that marginal likelihood calculations are notoriously prone to numerical stability issues. Especially in high-dimensional parameter spaces, there is no guarantee that any of the implemented algorithms will converge reasonably fast. The recommended (and default) method is the method "Chib" (Chib and Jeliazkov, 2001), which is based on MCMC samples, with a limited number of additional calculations. Despite being the current recommendation, note there are some numeric issues with this algorithm that may limit reliability for larger dimensions. +#' +#' The harmonic mean approximation, is implemented only for comparison. Note that the method is numerically unreliable and usually should not be used. +#' +#' The third method is simply sampling from the prior. While in principle unbiased, it will only converge for a large number of samples, and is therefore numerically inefficient. +#' +#' The Bridge method uses bridge sampling as implemented in the R package "bridgesampling". It is potentially more exact than the Chib method, but might require more computation time. However, this may be very dependent on the sampler. +#' +#' @return A list with log of the marginal likelihood, as well as other diagnostics depending on the chosen method +#' +#' @example /inst/examples/marginalLikelihoodHelp.R +#' @references +#' +#' Chib, Siddhartha, and Ivan Jeliazkov. "Marginal likelihood from the Metropolis-Hastings output." Journal of the American Statistical Association 96.453 (2001): 270-281. +#' +#' Dormann et al. 2018. Model averaging in ecology: a review of Bayesian, information-theoretic, and tactical approaches for predictive inference. Ecological Monographs +#' +#' @seealso \code{\link{WAIC}}, \code{\link{DIC}}, \code{\link{MAP}} +marginalLikelihood <- function(sampler, numSamples = 1000, method = "Chib", ...){ + + + if ((class(sampler)[1] %in% c("mcmcSamplerList", "smcSamplerList"))) { + setup <- sampler[[1]]$setup + posterior = sampler[[1]]$setup$posterior$density + } else if ((class(sampler)[1] %in% c("mcmcSampler", "smcSampler"))) { + setup <- sampler$setup + posterior = sampler$setup$posterior$density + } else if ((class(sampler)[1] %in% c("BayesianSetup"))) { + setup <- sampler + posterior = sampler$posterior$density + } else stop("sampler must be a sampler or a BayesianSetup") + + + if (method == "Chib"){ + + chain <- getSample(sampler = sampler, parametersOnly = F, ...) + + if(class(sampler)[1] %in% c("mcmcSamplerList", "smcSamplerList")) sampler <- sampler[[1]] + + x <- chain[,1:sampler$setup$numPars,drop=F] + + lik <- chain[,sampler$setup$numPars + 2] + MAPindex <- which.max(chain[,sampler$setup$numPars + 1]) + + #propGen = createProposalGenerator(covariance = cov(x)) + + V <- cov(x) + + # calculate reference parameter + + theta.star <- x[MAPindex,,drop=F] + lik.star <- lik[MAPindex] + + # get samples from posterior + + g <- sample.int(nrow(x), numSamples, replace=TRUE) # should replace really be true? + q.g <- mvtnorm::dmvnorm(x[g,,drop=F], mean = theta.star, sigma = V, log = FALSE) + lik.g <- lik[g] + alpha.g <- sapply(lik.g, function(l) min(1, exp(lik.star - l))) # Metropolis Ratio + + #lik.g <- apply(theta.g,1,sampler$setup$likelihood$density,...) + + + # get samples from proposal + theta.j <- mvtnorm::rmvnorm(numSamples, mean = theta.star, sigma = V) + lik.j <- apply(theta.j, 1, sampler$setup$likelihood$density) + alpha.j <- sapply(lik.j, function(l) min(1, exp(l - lik.star))) # Metropolis Ratio + + # Prior + pi.hat <- mean(alpha.g * q.g) / mean(alpha.j) + pi.star <- 0 + + if (!is.null(sampler$setup$prior$density)) pi.star <- sampler$setup$prior$density(theta.star) + ln.m <- lik.star + pi.star - log(pi.hat) + + out <- list(ln.ML = ln.m, ln.lik.star = lik.star, ln.pi.star = pi.star, ln.pi.hat = log(pi.hat), method = "Chib") + + } else if (method == "HM"){ + + warning("The Harmonic Mean estimator is notoriously unstable. It's only implemented for comparison. We strongly advice against using it for research!") + + chain <- getSample(sampler = sampler, parametersOnly = F, ...) + lik <- chain[, setup$numPars + 2] + ml <- log(1 / mean(1 / exp(lik))) + # ml = 1 / logSumExp(-lik, mean = T) function needs to be adjusted + out <- list(ln.ML=ml, method ="HM") + + } else if (method == "Prior"){ + + samples <- setup$prior$sampler(numSamples) + likelihoods <- setup$likelihood$density(samples) + + ml <- logSumExp(likelihoods, mean = T) + out <- list(ln.ML=ml, method ="Prior") + + } else if (method == "Bridge") { + + chain <- getSample(sampler = sampler, parametersOnly = F, numSamples = numSamples, ...) + + nParams <- setup$numPars + lower <- setup$prior$lower + upper <- setup$prior$upper + + + out <- list(ln.ML = bridgesample(chain ,nParams, lower, upper, posterior)$logml, method ="Bridge") + + } else if ("NN") { + + # TODO: implement nearest neighbour method: + # https://arxiv.org/abs/1704.03472 + stop("Not yet implemented") + + } else { + stop(paste(c("\"", method, "\" is not a valid method parameter!"), sep = " ", collapse = "")) + } + + return(out) +} + + +#' Calculates the marginal likelihood of a chain via bridge sampling +#' @export +#' @author Tankred Ott +#' @param chain a single mcmc chain with samples as rows and parameters and posterior density as columns. +#' @param nParams number of parameters +#' @param lower optional - lower bounds of the prior +#' @param upper optional - upper bounds of the prior +#' @param posterior posterior density function +#' @param ... arguments passed to bridge_sampler +#' @details This function uses "bridge_sampler" from the package "bridgesampling". +#' @example /inst/examples/bridgesampleHelp.R +#' @seealso \code{\link{marginalLikelihood}} +#' @keywords internal +bridgesample <- function (chain, nParams, lower = NULL, upper = NULL, posterior, ...) { + # TODO: implement this without bridgesampling package + # https://github.com/quentingronau/bridgesampling + if (is.null(lower)) lower <- rep(-Inf, nParams) + if (is.null(upper)) upper <- rep(Inf, nParams) + + names(lower) <- names(upper) <- colnames(chain[, 1:nParams]) + + log_posterior = function(x, data){ + return(posterior(x)) + } + + out <- bridgesampling::bridge_sampler( + samples = chain[, 1:nParams], + log_posterior = log_posterior, + data = chain, + lb = lower, + ub = upper, + ... + ) + + return(out) +} + + + + + From 9b0190fa3993e594e6deda226ae9351baa2abd62 Mon Sep 17 00:00:00 2001 From: Tahmina Mojumder Date: Thu, 31 Aug 2023 18:34:29 +0200 Subject: [PATCH 05/13] Updated helper function for the functions whose name starts with mcmc. --- BayesianTools/R/mcmcDE.R | 472 +++++---- BayesianTools/R/mcmcDEzs.R | 795 +++++++------- BayesianTools/R/mcmcDREAM.R | 706 ++++++------- BayesianTools/R/mcmcDREAM_helperFunctions.R | 148 ++- BayesianTools/R/mcmcDREAMzs.R | 976 ++++++++--------- BayesianTools/R/mcmcFrancesco.R | 698 ++++++------- BayesianTools/R/mcmcMetropolis.R | 390 +++---- BayesianTools/R/mcmcMultipleChains.R | 78 +- BayesianTools/R/mcmcRun.R | 1044 +++++++++---------- BayesianTools/R/mcmcTwalk.R | 308 +++--- BayesianTools/R/mcmcTwalk_helperFunctions.R | 598 +++++------ 11 files changed, 3105 insertions(+), 3108 deletions(-) diff --git a/BayesianTools/R/mcmcDE.R b/BayesianTools/R/mcmcDE.R index 734f080..1589079 100644 --- a/BayesianTools/R/mcmcDE.R +++ b/BayesianTools/R/mcmcDE.R @@ -1,237 +1,235 @@ - - -#' Differential-Evolution MCMC -#' @author Francesco Minunno and Stefan Paul -#' @param bayesianSetup a BayesianSetup with the posterior density function to be sampled from -#' @param settings list with parameter settings -#' @param startValue (optional) eiter a matrix with start population, a number to define the number of chains that are run or a function that samples a starting population. -#' @param iterations number of function evaluations. -#' @param burnin number of iterations treated as burn-in. These iterations are not recorded in the chain. -#' @param thin thinning parameter. Determines the interval in which values are recorded. -#' @param f scaling factor gamma -#' @param eps small number to avoid singularity -#' @param blockUpdate list determining whether parameters should be updated in blocks. For possible settings see Details. -#' @param message logical determines whether the sampler's progress should be printed -#' @references Braak, Cajo JF Ter. "A Markov Chain Monte Carlo version of the genetic algorithm Differential Evolution: easy Bayesian computing for real parameter spaces." Statistics and Computing 16.3 (2006): 239-249. -#' @export -#' @example /inst/examples/DEfamilyHelp.R -#' @seealso \code{\link{DEzs}} -#' @details For blockUpdate the first element in the list determines the type of blocking. -#' Possible choices are -#' \itemize{ -#' \item{"none"}{ (default), no blocking of parameters} -#' \item{"correlation"} { blocking based on correlation of parameters. Using h or k (see below)} -#' \item{"random"} { random blocking. Using k (see below)} -#' \item{"user"} { user defined groups. Using groups (see below)} -#' } -#' Further seven parameters can be specified. "k" determnined the number of groups, "h" the strength -#' of the correlation used to group parameter and "groups" is used for user defined groups. -#' "groups" is a vector containing the group number for each parameter. E.g. for three parameters -#' with the first two in one group, "groups" would be c(1,1,2). -#' Further pSel and pGroup can be used to influence the choice of groups. In the sampling process -#' a number of groups is randomly drawn and updated. pSel is a vector containing relative probabilities -#' for an update of the respective number of groups. E.g. for always updating only one group pSel = 1. -#' For updating one or two groups with the same probability pSel = c(1,1). By default all numbers -#' have the same probability. -#' The same principle is used in pGroup. Here the user can influence the probability of each group -#' to be updated. By default all groups have the same probability. -#' Finally "groupStart" defines the starting point of the groupUpdate and "groupIntervall" the intervall -#' in which the groups are evaluated. - -DE <- function(bayesianSetup, - settings = list( - startValue = NULL, - iterations = 10000, - f = -2.38, - burnin = 0, - thin = 1, - eps = 0, - consoleUpdates = 100, - blockUpdate = list("none", k = NULL, h = NULL, pSel = NULL, pGroup = NULL, - groupStart = 1000, groupIntervall = 1000), - currentChain = 1, - message = TRUE - ) - ){ - - if("bayesianOutput" %in% class(bayesianSetup)){ - restart <- TRUE - } else restart <- FALSE - - - if(restart){ - if(is.null(settings)) settings <- bayesianSetup$settings - else settings <- applySettingsDefault(settings = settings, sampler = "DE") - - }else{ - # If nothing provided use default settings - settings <- applySettingsDefault(settings = settings, sampler = "DE") - } - - if(!restart){ - setup <- bayesianSetup - }else{ - setup <- bayesianSetup$setup - } - - - setup <- checkBayesianSetup(setup, parallel = settings$parallel) # calling parallel will check if requested parallelization in settings is provided by the BayesianSetup - if(is.null(settings$parallel)) settings$parallel = setup$parallel # checking back - if no parallelization is provided, we use the parallelization in the BayesianSetup. We could also set parallel = F, but I feel it makes more sense to use the Bayesiansetup as default - - if(!restart){ - if(is.null(settings$startValue)){ - parLen = length(bayesianSetup$prior$sampler(1)) - X = bayesianSetup$prior$sampler(3 * parLen) - } - if(is.function(settings$startValue)){ - X = settings$startValue() - } - if(class(settings$startValue)[1] == "numeric"){ - X = bayesianSetup$prior$sampler(settings$startValue) - } - if(is.matrix(settings$startValue)) X <- settings$startValue - }else{ - X <- bayesianSetup$X - } - - # X = startValue - if (!is.matrix(X)) stop("wrong starting values") - - FUN = setup$posterior$density - - ## Initialize blockUpdate parameters and settings - blockdefault <- list("none", k = NULL, h = NULL, pSel = NULL, pGroup = NULL, - groupStart = 1000, groupIntervall = 1000) - - if(!is.null(settings$blockUpdate)){ - blockUpdate <- modifyList(blockdefault, settings$blockUpdate) - blockUpdate[[1]] <- settings$blockUpdate[[1]] # to catch first argument - if(blockUpdate[[1]] == "none"){ - blockUpdateType <- "none" - blocks = FALSE - BlockStart = FALSE - }else{ - groupStart <- blockUpdate$groupStart - groupIntervall <- blockUpdate$groupIntervall - blockUpdateType = blockUpdate[[1]] - blocks = TRUE - ## Initialize BlockStart - BlockStart = FALSE - Bcount = 0 - } - }else{ - blockUpdateType <- "none" - blocks = FALSE - BlockStart = FALSE - } - - - - Npar <- ncol(X) - Npop <- nrow(X) - burnin <- settings$burnin/Npop - n.iter <- ceiling(settings$iterations/Npop) - - if (n.iter < 2) stop ("The total number of iterations must be greater than the number of parameters to fit times 3.") - - lChain <- ceiling((n.iter - burnin)/settings$thin)+1 - #pChain <- array(NA, dim=c(n.iter*Npop, Npar+3)) - - pChain <- array(NA, dim=c(lChain, Npar+3, Npop)) - - - colnames(pChain) <- c(setup$names, "LP", "LL", "LPr") - - counter <- 1 - iseq <- 1:Npop - - - F2 = abs(settings$f)/sqrt(2*Npar) - if (settings$f>0) F1 = F2 else F1 = 0.98 - - logfitness_X <- FUN(X, returnAll = T) - - # Write first values in chain - pChain[1,,] <- t(cbind(X,logfitness_X)) - - # Print adjusted iterations - # cat("Iterations adjusted to", n.iter*Npop,"to fit settings", "\n") - - #### - eps <- settings$eps - currentChain <- settings$currentChain - iterations <- settings$iterations - - for (iter in 2:n.iter) { - - if (iter%%10) F_cur = F2 else F_cur = F1 - - - if(blocks){ - ### Update the groups. - if(iter == groupStart+ Bcount*groupIntervall){ - blockSettings <- updateGroups(chain = pChain[1:counter,, ], blockUpdate) - BlockStart <- TRUE - Bcount <- Bcount + 1 - } - } - #### - - for (i in iseq){ - # select to random different individuals (and different from i) in rr, a 2-vector - - rr <- sample(iseq[-i], 2, replace = FALSE) - x_prop <- X[i,] + F_cur * (X[rr[1],]-X[rr[2],]) + eps * rnorm(Npar,0,1) - - if(BlockStart){ - # Get the current group and update the proposal accordingly - Member <- getBlock(blockSettings) - x_prop[-Member] <- X[i,-Member] - #### - } - - logfitness_x_prop <- FUN(x_prop, returnAll = T) - if(!is.na(logfitness_x_prop[1] - logfitness_X[i,1])){ # To catch possible error - if ((logfitness_x_prop[1] - logfitness_X[i,1] ) > log(runif(1))){ - X[i,] <- x_prop - logfitness_X[i,] <- logfitness_x_prop - } - } - } #iseq - if ((iter > burnin) && (iter %% settings$thin == 0) ) { # retain sample - counter <- counter+1 - pChain[counter,,] <- t(cbind(X,logfitness_X)) - - } - - if(settings$message){ - if( (iter %% settings$consoleUpdates == 0) | (iter == n.iter)) cat("\r","Running DE-MCMC, chain ", currentChain, - "iteration" ,iter*Npop,"of",n.iter*Npop,". Current logp ", - logfitness_X[,1], - "Please wait!","\r") - flush.console() - } - - } # n.iter - iterationsOld <- 0 - - pChain <- pChain[1:counter,,] - - if(restart){ # Combine chains - newchains <- array(NA, dim = c((counter+nrow(bayesianSetup$chain[[1]])), (Npar+3), Npop)) - - for(i in 1:Npop){ - for(k in 1:(Npar+3)){ - newchains[,k,i] <- c(bayesianSetup$chain[[i]][,k],pChain[,k,i]) - } - } - pChain <- newchains - } - - - - pChain<- coda::as.mcmc.list(lapply(1:Npop,function(i) coda::as.mcmc(pChain[,1:(Npar+3),i]))) - - - list(Draws = pChain, X = as.matrix(X[,1:Npar])) - } +#' Differential-Evolution MCMC +#' @author Francesco Minunno and Stefan Paul +#' @param bayesianSetup a BayesianSetup with the posterior density function to be sampled from +#' @param settings list with parameter settings +#' @param startValue (optional) either a matrix with start population, a number defining the number of chains to be run or a function that samples a starting population. +#' @param iterations number of function evaluations. +#' @param burnin number of iterations treated as burn-in. These iterations are not recorded in the chain. +#' @param thin thinning parameter. Determines the interval in which values are recorded. +#' @param f scaling factor gamma +#' @param eps small number to avoid singularity +#' @param blockUpdate list determining whether parameters should be updated in blocks. For possible settings see Details. +#' @param message logical, Specifies whether to print the progress of the sampler. +#' @references Braak, Cajo JF Ter. "A Markov Chain Monte Carlo version of the genetic algorithm Differential Evolution: easy Bayesian computing for real parameter spaces." Statistics and Computing 16.3 (2006): 239-249. +#' @export +#' @example /inst/examples/DEfamilyHelp.R +#' @seealso \code{\link{DEzs}} +#' @details For blockUpdate the first element in the list determines the type of blocking. +#' Possible choices are +#' \itemize{ +#' \item{"none"}{ (default), no blocking of parameters} +#' \item{"correlation"} { blocking based on correlation of parameters. Using h or k (see below)} +#' \item{"random"} { random blocking. Using k (see below)} +#' \item{"user"} { user defined groups. Using groups (see below)} +#' } +#' Further, seven parameters can be specified. "k" defines the number of groups, "h" the strength +#' of the correlation used to group the parameters and "groups" is used for user defined groups. +#' "groups" is a vector containing the group number for each parameter. E.g. for three parameters +#' with the first two in one group, "groups" would be c(1,1,2). +#' Moreover, pSel and pGroup can be used to influence the choice of groups. In the sampling process +#' a number of groups are drawn at random and updated. pSel is a vector containing relative probabilities +#' for updating the respective number of groups. E.g. To update one group at a time pSel = 1. +#' For updating one or two groups with the same probability pSel = c(1,1). By default all numbers +#' have the same probability. +#' The same principle is used for pGroup. Here the user can influence the probability of each group +#' to be updated. By default all groups have the same probability. +#' Finally, "groupStart" defines the starting point of the groupUpdate and "groupIntervall" - the interval +#' in which the groups are evaluated. + +DE <- function(bayesianSetup, + settings = list( + startValue = NULL, + iterations = 10000, + f = -2.38, + burnin = 0, + thin = 1, + eps = 0, + consoleUpdates = 100, + blockUpdate = list("none", k = NULL, h = NULL, pSel = NULL, pGroup = NULL, + groupStart = 1000, groupIntervall = 1000), + currentChain = 1, + message = TRUE + ) + ){ + + if("bayesianOutput" %in% class(bayesianSetup)){ + restart <- TRUE + } else restart <- FALSE + + + if(restart){ + if(is.null(settings)) settings <- bayesianSetup$settings + else settings <- applySettingsDefault(settings = settings, sampler = "DE") + + }else{ + # If nothing provided use default settings + settings <- applySettingsDefault(settings = settings, sampler = "DE") + } + + if(!restart){ + setup <- bayesianSetup + }else{ + setup <- bayesianSetup$setup + } + + + setup <- checkBayesianSetup(setup, parallel = settings$parallel) # calling parallel will check if requested parallelization in settings is provided by the BayesianSetup + if(is.null(settings$parallel)) settings$parallel = setup$parallel # checking back - if no parallelization is provided, we use the parallelization in the BayesianSetup. We could also set parallel = F, but I feel it makes more sense to use the Bayesiansetup as default + + if(!restart){ + if(is.null(settings$startValue)){ + parLen = length(bayesianSetup$prior$sampler(1)) + X = bayesianSetup$prior$sampler(3 * parLen) + } + if(is.function(settings$startValue)){ + X = settings$startValue() + } + if(class(settings$startValue)[1] == "numeric"){ + X = bayesianSetup$prior$sampler(settings$startValue) + } + if(is.matrix(settings$startValue)) X <- settings$startValue + }else{ + X <- bayesianSetup$X + } + + # X = startValue + if (!is.matrix(X)) stop("wrong starting values") + + FUN = setup$posterior$density + + ## Initialize blockUpdate parameters and settings + blockdefault <- list("none", k = NULL, h = NULL, pSel = NULL, pGroup = NULL, + groupStart = 1000, groupIntervall = 1000) + + if(!is.null(settings$blockUpdate)){ + blockUpdate <- modifyList(blockdefault, settings$blockUpdate) + blockUpdate[[1]] <- settings$blockUpdate[[1]] # to catch first argument + if(blockUpdate[[1]] == "none"){ + blockUpdateType <- "none" + blocks = FALSE + BlockStart = FALSE + }else{ + groupStart <- blockUpdate$groupStart + groupIntervall <- blockUpdate$groupIntervall + blockUpdateType = blockUpdate[[1]] + blocks = TRUE + ## Initialize BlockStart + BlockStart = FALSE + Bcount = 0 + } + }else{ + blockUpdateType <- "none" + blocks = FALSE + BlockStart = FALSE + } + + + + Npar <- ncol(X) + Npop <- nrow(X) + burnin <- settings$burnin/Npop + n.iter <- ceiling(settings$iterations/Npop) + + if (n.iter < 2) stop ("The total number of iterations must be greater than the number of parameters to fit times 3.") + + lChain <- ceiling((n.iter - burnin)/settings$thin)+1 + #pChain <- array(NA, dim=c(n.iter*Npop, Npar+3)) + + pChain <- array(NA, dim=c(lChain, Npar+3, Npop)) + + + colnames(pChain) <- c(setup$names, "LP", "LL", "LPr") + + counter <- 1 + iseq <- 1:Npop + + + F2 = abs(settings$f)/sqrt(2*Npar) + if (settings$f>0) F1 = F2 else F1 = 0.98 + + logfitness_X <- FUN(X, returnAll = T) + + # Write first values in chain + pChain[1,,] <- t(cbind(X,logfitness_X)) + + # Print adjusted iterations + # cat("Iterations adjusted to", n.iter*Npop,"to fit settings", "\n") + + #### + eps <- settings$eps + currentChain <- settings$currentChain + iterations <- settings$iterations + + for (iter in 2:n.iter) { + + if (iter%%10) F_cur = F2 else F_cur = F1 + + + if(blocks){ + ### Update the groups. + if(iter == groupStart+ Bcount*groupIntervall){ + blockSettings <- updateGroups(chain = pChain[1:counter,, ], blockUpdate) + BlockStart <- TRUE + Bcount <- Bcount + 1 + } + } + #### + + for (i in iseq){ + # select to random different individuals (and different from i) in rr, a 2-vector + + rr <- sample(iseq[-i], 2, replace = FALSE) + x_prop <- X[i,] + F_cur * (X[rr[1],]-X[rr[2],]) + eps * rnorm(Npar,0,1) + + if(BlockStart){ + # Get the current group and update the proposal accordingly + Member <- getBlock(blockSettings) + x_prop[-Member] <- X[i,-Member] + #### + } + + logfitness_x_prop <- FUN(x_prop, returnAll = T) + if(!is.na(logfitness_x_prop[1] - logfitness_X[i,1])){ # To catch possible error + if ((logfitness_x_prop[1] - logfitness_X[i,1] ) > log(runif(1))){ + X[i,] <- x_prop + logfitness_X[i,] <- logfitness_x_prop + } + } + } #iseq + if ((iter > burnin) && (iter %% settings$thin == 0) ) { # retain sample + counter <- counter+1 + pChain[counter,,] <- t(cbind(X,logfitness_X)) + + } + + if(settings$message){ + if( (iter %% settings$consoleUpdates == 0) | (iter == n.iter)) cat("\r","Running DE-MCMC, chain ", currentChain, + "iteration" ,iter*Npop,"of",n.iter*Npop,". Current logp ", + logfitness_X[,1], + "Please wait!","\r") + flush.console() + } + + } # n.iter + iterationsOld <- 0 + + pChain <- pChain[1:counter,,] + + if(restart){ # Combine chains + newchains <- array(NA, dim = c((counter+nrow(bayesianSetup$chain[[1]])), (Npar+3), Npop)) + + for(i in 1:Npop){ + for(k in 1:(Npar+3)){ + newchains[,k,i] <- c(bayesianSetup$chain[[i]][,k],pChain[,k,i]) + } + } + pChain <- newchains + } + + + + pChain<- coda::as.mcmc.list(lapply(1:Npop,function(i) coda::as.mcmc(pChain[,1:(Npar+3),i]))) + + + list(Draws = pChain, X = as.matrix(X[,1:Npar])) + } diff --git a/BayesianTools/R/mcmcDEzs.R b/BayesianTools/R/mcmcDEzs.R index ed99255..570ac4d 100644 --- a/BayesianTools/R/mcmcDEzs.R +++ b/BayesianTools/R/mcmcDEzs.R @@ -1,397 +1,398 @@ -#TODO: long-term - consider combinining DE and DE.ZS - -#' Differential-Evolution MCMC zs -#' @author Francesco Minunno and Stefan Paul -#' @param bayesianSetup a BayesianSetup with the posterior density function to be sampled from -#' @param settings list with parameter settings -#' @param startValue (optional) eiter a matrix with start population, a number to define the number of chains that are run or a function that samples a starting population. -#' @param Z starting Z population -#' @param iterations iterations to run -#' @param pSnooker probability of Snooker update -#' @param burnin number of iterations treated as burn-in. These iterations are not recorded in the chain. -#' @param thin thinning parameter. Determines the interval in which values are recorded. -#' @param eps small number to avoid singularity -#' @param f scaling factor for gamma -#' @param parallel logical, determines weather parallel computing should be attempted (see details) -#' @param pGamma1 probability determining the frequency with which the scaling is set to 1 (allows jumps between modes) -#' @param eps.mult random term (multiplicative error) -#' @param eps.add random term -#' @param blockUpdate list determining whether parameters should be updated in blocks. For possible settings see Details. -#' @param message logical determines whether the sampler's progress should be printed -#' @references ter Braak C. J. F., and Vrugt J. A. (2008). Differential Evolution Markov Chain with snooker updater and fewer chains. Statistics and Computing http://dx.doi.org/10.1007/s11222-008-9104-9 -#' @export -#' @example /inst/examples/DEfamilyHelp.R -#' @seealso \code{\link{DE}} -#' @details For parallel computing, the likelihood density in the bayesianSetup needs to be parallelized, i.e. needs to be able to operate on a matrix of proposals -#' -#' For blockUpdate the first element in the list determines the type of blocking. -#' Possible choices are -#' \itemize{ -#' \item{"none"}{ (default), no blocking of parameters} -#' \item{"correlation"} { blocking based on correlation of parameters. Using h or k (see below)} -#' \item{"random"} { random blocking. Using k (see below)} -#' \item{"user"} { user defined groups. Using groups (see below)} -#' } -#' Further seven parameters can be specified. "k" determnined the number of groups, "h" the strength -#' of the correlation used to group parameter and "groups" is used for user defined groups. -#' "groups" is a vector containing the group number for each parameter. E.g. for three parameters -#' with the first two in one group, "groups" would be c(1,1,2). -#' Further pSel and pGroup can be used to influence the choice of groups. In the sampling process -#' a number of groups is randomly drawn and updated. pSel is a vector containing relative probabilities -#' for an update of the respective number of groups. E.g. for always updating only one group pSel = 1. -#' For updating one or two groups with the same probability pSel = c(1,1). By default all numbers -#' have the same probability. -#' The same principle is used in pGroup. Here the user can influence the probability of each group -#' to be updated. By default all groups have the same probability. -#' Finally "groupStart" defines the starting point of the groupUpdate and "groupIntervall" the intervall -#' in which the groups are evaluated. -DEzs <- function(bayesianSetup, - settings = list(iterations=10000, - Z = NULL, - startValue = NULL, - pSnooker = 0.1, - burnin = 0, - thin = 1, - f = 2.38, - eps = 0, - parallel = NULL, - pGamma1 = 0.1, - eps.mult =0.2, - eps.add = 0, - consoleUpdates = 100, - zUpdateFrequency = 1, - currentChain = 1, - blockUpdate = list("none", k = NULL, h = NULL, pSel = NULL, pGroup = NULL, - groupStart = 1000, groupIntervall = 1000) - ,message = TRUE)) - { - - -# X = startValue - - - if("bayesianOutput" %in% class(bayesianSetup)){ - restart <- TRUE - } else restart <- FALSE - - - if(restart){ - if(is.null(settings)) settings <- bayesianSetup$settings - else settings <- applySettingsDefault(settings = settings, sampler = "DEzs") - }else{ - # If nothing provided use default settings - settings <- applySettingsDefault(settings = settings, sampler = "DEzs") - } - - if(!restart){ - setup <- bayesianSetup - } else setup <- bayesianSetup$setup - - setup <- checkBayesianSetup(setup, parallel = settings$parallel) # calling parallel will check if requested parallelization in settings is provided by the BayesianSetup - if(is.null(settings$parallel)) settings$parallel = setup$parallel # checking back - if no parallelization is provided, we use the parallelization in the BayesianSetup. We could also set parallel = F, but I feel it makes more sense to use the Bayesiansetup as default - - if(!restart){ - if(is.null(settings$startValue)){ - parLen = length(bayesianSetup$prior$sampler(1)) - X = bayesianSetup$prior$sampler(3) - } - if(is.function(settings$startValue)){ - X = settings$startValue() - } - if(class(settings$startValue)[1] == "numeric"){ - X = bayesianSetup$prior$sampler(settings$startValue) - } - - if(is.matrix(settings$startValue)) X <- settings$startValue - - if(is.null(settings$Z)){ - parLen = length(bayesianSetup$prior$sampler(1)) - Z = bayesianSetup$prior$sampler(parLen * 10) - } - if(is.function(settings$Z)){ - Z = settings$Z() - } - - if(class(settings$Z)[1] == "numeric"){ - Z = bayesianSetup$prior$sampler(settings$Z) - } - if(is.matrix(settings$Z)) Z <- settings$Z - - }else{ - X <- bayesianSetup$X - Z <- bayesianSetup$Z - if(is.vector(Z)) Z = as.matrix(Z) - } - - - if (! is.matrix(X)) stop("wrong starting values") - if (! is.matrix(Z)) stop("wrong Z values") - - - FUN = setup$posterior$density - - if(is.null(settings$parallel)) parallel = setup$parallel else parallel <- settings$parallel - if(parallel == T & setup$parallel == F) stop("parallel = T requested in DEzs but BayesianSetup does not support parallelization. See help of BayesianSetup on how to enable parallelization") - - ## Initialize blockUpdate parameters and settings - blockdefault <- list("none", k = NULL, h = NULL, pSel = NULL, pGroup = NULL, - groupStart = 1000, groupIntervall = 1000) - - if(!is.null(settings$blockUpdate)){ - blockUpdate <- modifyList(blockdefault, settings$blockUpdate) - blockUpdate[[1]] <- settings$blockUpdate[[1]] # to catch first argument - if(blockUpdate[[1]] == "none"){ - blockUpdateType <- "none" - blocks = FALSE - BlockStart = FALSE - }else{ - groupStart <- blockUpdate$groupStart - groupIntervall <- blockUpdate$groupIntervall - blockUpdateType = blockUpdate[[1]] - blocks = TRUE - ## Initialize BlockStart - BlockStart = FALSE - Bcount = 0 - } - }else{ - blockUpdateType <- "none" - blocks = FALSE - BlockStart = FALSE - } - - - # Initialize parameter values. Because they are called in - # the loop this saves time in comparison to referencing them - # every iteration using settings$... - iterations <- settings$iterations - consoleUpdates <- settings$currentChain - currentChain <- settings$currentChain - pSnooker <- settings$pSnooker - zUpdateFrequency <- settings$zUpdateFrequency - pGamma1 <- settings$pGamma1 - eps.mult <- settings$eps.mult - eps.add <- settings$eps.add - - # Initialization of previous chain length (= 0 if restart = F) - lChainOld <- 0 - - Npar <- ncol(X) - Npar12 <- (Npar - 1)/2 # factor for Metropolis ratio DE Snooker update - - # M0 is initial population size of Z is the size of Z, it's the same number, only kept 2 to stay consistent with the ter Brakk & Vrugt 2008 - M = M0 = nrow(Z) - Npop <- nrow(X) - - F2 = settings$f/sqrt(2*Npar) - F1 = 1.0 - rr = NULL - r_extra = 0 - - #if(burnin != 0) stop("burnin option is currently not implemented") - - burnin <- settings$burnin/Npop - n.iter <- ceiling(settings$iterations/Npop) - if (n.iter < 2) stop ("The total number of iterations must be greater than 3") - - lChain <- ceiling((n.iter - burnin)/settings$thin)+1 - - pChain <- array(NA, dim=c(lChain, Npar+3, Npop)) - - colnames(pChain) <- c(setup$names, "LP", "LL", "LPr") - - - # Print adjusted iterations -# cat("Iterations adjusted to", n.iter*Npop,"to fit settings", "\n") - - - # assign memory for Z - Zold <- Z - Z <- matrix(NA, nrow= M0 + floor((n.iter-1) /zUpdateFrequency) * Npop, ncol=Npar) - - Z[1:M,] <- Zold - - - counter <- 1 - counterZ <- 0 - - # accept.prob <- 0 - logfitness_X <- FUN(X, returnAll = T) - - - # Write first values in chain - pChain[1,,] <- t(cbind(X,logfitness_X)) - - - - for (iter in 2:n.iter) { - f <- ifelse(iter%%10 == 0, 0.98, F1) - #accept <- 0 - - - if(blocks){ - ### Update the groups. - if(iter == groupStart+ Bcount*groupIntervall){ - blockSettings <- updateGroups(chain = pChain[1:counter,, ], blockUpdate) - BlockStart <- TRUE - Bcount <- Bcount + 1 - } - } - - - if(parallel == TRUE | parallel == "external"){ - x_prop <- matrix(NA, nrow= Npop, ncol=Npar) - r_extra <- numeric(Npop) - - - for(i in 1:Npop){ - # select to random different individuals (and different from i) in rr, a 2-vector - rr <- sample.int(M, 3, replace = FALSE) - if(runif(1) < pSnooker) { - z <- Z[rr[3],] - x_z <- X[i,] - z - D2 <- max(sum(x_z*x_z), 1.0e-300) - projdiff <- sum((Z[rr[1],] -Z[rr[2],]) * x_z)/D2 # inner_product of difference with x_z / squared norm x_z - gamma_snooker <- runif(1, min=1.2,max=2.2) - - x_prop[i,] <- X[i,] + gamma_snooker * projdiff * x_z - x_z <- x_prop[i,] - z - D2prop <- max(sum(x_z*x_z), 1.0e-300) - r_extra[i] <- Npar12 * (log(D2prop) - log(D2)) - - } else { - if ( runif(1)< pGamma1 ) { gamma_par = F1 # to be able to jump between modes - } else { - gamma_par = F2 * runif(Npar, min=1-eps.mult, max=1+eps.mult) # multiplicative error to be applied to the difference - # gamma_par = F2 - } - rr = sample.int(M, 2, replace = FALSE) - if (eps.add ==0) { # avoid generating normal random variates if possible - x_prop[i,] = X[i,] + gamma_par * (Z[rr[1],]-Z[rr[2],]) - } else { - x_prop[i,] = X[i,] + gamma_par * (Z[rr[1],]-Z[rr[2],]) + eps.add*rnorm(Npar,0,1) - } - r_extra = rep(0, Npop) - } - } - # end proposal creation - - if(BlockStart){ - # Get the current group and update the proposal accordingly - Member <- getBlock(blockSettings) - x_prop[,-Member] <- X[,-Member] - #### - } - - - # run proposals - logfitness_x_prop <- FUN(x_prop, returnAll = T) - - # evaluate acceptance - for(i in 1:Npop){ - if(!is.na(logfitness_x_prop[i,1] - logfitness_X[i,1])){ - if ((logfitness_x_prop[i,1] - logfitness_X[i,1] + r_extra[i]) > log(runif(1))){ - # accept <- accept + 1 - X[i,] <- x_prop[i,] - logfitness_X[i,] <- logfitness_x_prop[i,] - } - } - } - - } else{ - # if not parallel - - for (i in 1:Npop){ - # select to random different individuals (and different from i) in rr, a 2-vector - rr <- sample.int(M, 3, replace = FALSE) - if(runif(1) < pSnooker) { - z <- Z[rr[3],] - x_z <- X[i,] - z - D2 <- max(sum(x_z*x_z), 1.0e-300) - projdiff <- sum((Z[rr[1],] -Z[rr[2],]) * x_z)/D2 # inner_product of difference with x_z / squared norm x_z - gamma_snooker <- runif(1, min=1.2,max=2.2) - x_prop <- X[i,] + gamma_snooker * projdiff * x_z - x_z <- x_prop - z - D2prop <- max(sum(x_z*x_z), 1.0e-300) - r_extra <- Npar12 * (log(D2prop) - log(D2)) - } else { - - if ( runif(1)< pGamma1 ) { gamma_par = F1 # to be able to jump between modes - } else { - gamma_par = F2 * runif(Npar, min=1-eps.mult, max=1+eps.mult) # multiplicative error to be applied to the difference - # gamma_par = F2 - } - rr = sample.int(M, 2, replace = FALSE) - if (eps.add ==0) { # avoid generating normal random variates if possible - x_prop = X[i,] + gamma_par * (Z[rr[1],]-Z[rr[2],]) } else { - x_prop = X[i,] + gamma_par * (Z[rr[1],]-Z[rr[2],]) + eps.add*rnorm(Npar,0,1) - } - r_extra = 0 - - } - if(BlockStart){ - # Get the current group and update the proposal accordingly - Member <- getBlock(blockSettings) - x_prop[-Member] <- X[i,-Member] - #### - } - - - # evaluate proposal - can this be mixed with the parallel above? - logfitness_x_prop <- FUN(x_prop, returnAll = T) - - # evaluate acceptance - if(!is.na(logfitness_x_prop[1] - logfitness_X[i,1])){ - if ((logfitness_x_prop[1] - logfitness_X[i,1] + r_extra) > log(runif(1))){ - # accept <- accept + 1 - X[i,] <- x_prop - logfitness_X[i,] <- logfitness_x_prop - } - } - } # for Npop - - - } - - if ((iter > burnin) && (iter %% settings$thin == 0) ) { # retain sample - counter <- counter+1 - pChain[counter,,] <- t(cbind(X,logfitness_X)) - - } - - if (iter%%zUpdateFrequency == 0) { # update history - - Z[( M0 + (counterZ*Npop) + 1 ):( M0 + (counterZ+1)*Npop),] <- X - counterZ <- counterZ +1 - M <- M + Npop - } - # Console update - - if(settings$message){ - if( (iter %% settings$consoleUpdates == 0) | (iter == n.iter)) cat("\r","Running DEzs-MCMC, chain ", currentChain, - "iteration" ,iter*Npop,"of",n.iter*Npop,". Current logp ", - logfitness_X[,1],". Please wait!","\r") - flush.console() - } - } # n.iter - - - pChain <- pChain[1:counter,,] - - if(restart){ # Combine chains - newchains <- array(NA, dim = c((counter+nrow(bayesianSetup$chain[[1]])), (Npar+3), Npop)) - - for(i in 1:Npop){ - for(k in 1:(Npar+3)){ - newchains[,k,i] <- c(bayesianSetup$chain[[i]][,k],pChain[,k,i]) - } - } - pChain <- newchains - } - - - pChain<- coda::as.mcmc.list(lapply(1:Npop,function(i) coda::as.mcmc(pChain[,1:(Npar+3),i]))) - - - - list(Draws = pChain, X = as.matrix(X[,1:Npar]), Z = Z) -} +#TODO: long-term - consider combinining DE and DE.ZS + +#' Differential-Evolution MCMC zs +#' @author Francesco Minunno and Stefan Paul +#' @param bayesianSetup a BayesianSetup with the posterior density function to be sampled from +#' @param settings list with parameter settings +#' @param startValue (optional) either a matrix with start population, a number to define the number of chains that are run or a function that samples a starting population. +#' @param Z starting Z population +#' @param iterations number of iterations to run +#' @param pSnooker probability of Snooker update +#' @param burnin number of iterations treated as burn-in. These iterations are not recorded in the chain. +#' @param thin thinning parameter. Determines the interval in which values are recorded. +#' @param eps small number to avoid singularity +#' @param f scaling factor for gamma +#' @param parallel logical, determines weather parallel computing should be attempted (see details) +#' @param pGamma1 probability determining the frequency with which the scaling is set to 1 (allows jumps between modes) +#' @param eps.mult random term (multiplicative error) +#' @param eps.add random term +#' @param blockUpdate list determining whether parameters should be updated in blocks. For possible settings see Details. +#' @param message logical, specifies whether to print the progress of the sampler. +#' @references ter Braak C. J. F., and Vrugt J. A. (2008). Differential Evolution Markov Chain with snooker updater and fewer chains. Statistics and Computing http://dx.doi.org/10.1007/s11222-008-9104-9 +#' @export +#' @example /inst/examples/DEfamilyHelp.R +#' @seealso \code{\link{DE}} +#' @details For parallel computing, the likelihood density in the bayesianSetup needs to be parallelized, i.e., it needs to be able to operate on a matrix of proposals +#' +#' For blockUpdate the first element in the list determines the type of blocking. +#' Possible choices are +#' \itemize{ +#' \item{"none"}{ (default), no blocking of parameters} +#' \item{"correlation"} { blocking based on correlation of parameters. Using h or k (see below)} +#' \item{"random"} { random blocking. Using k (see below)} +#' \item{"user"} { user defined groups. Using groups (see below)} +#' } +#' Further, seven parameters can be specified. "k" defines the number of groups, "h" the strength +#' of the correlation used to group parameter and "groups" is used for user defined groups. +#' "groups" is a vector containing the group number for each parameter. E.g. for three parameters +#' with the first two in one group, "groups" would be c(1,1,2). +#' Moreover, pSel and pGroup can be used to influence the choice of groups. In the sampling process +#' a number of groups is drawn at random and updated. pSel is a vector containing relative probabilities +#' for updating the respective number of groups. E.g. To update one group at a time pSel = 1. +#' For updating one or two groups with the same probability pSel = c(1,1). By default all numbers +#' have the same probability. +#' The same principle is used in pGroup. Here, the user can influence the probability of each group +#' to be updated. By default all groups have the same probability. +#' Finally, "groupStart" defines the starting point of the groupUpdate and "groupIntervall" - the interval +#' in which the groups are evaluated. +#' +DEzs <- function(bayesianSetup, + settings = list(iterations=10000, + Z = NULL, + startValue = NULL, + pSnooker = 0.1, + burnin = 0, + thin = 1, + f = 2.38, + eps = 0, + parallel = NULL, + pGamma1 = 0.1, + eps.mult =0.2, + eps.add = 0, + consoleUpdates = 100, + zUpdateFrequency = 1, + currentChain = 1, + blockUpdate = list("none", k = NULL, h = NULL, pSel = NULL, pGroup = NULL, + groupStart = 1000, groupIntervall = 1000) + ,message = TRUE)) + { + + +# X = startValue + + + if("bayesianOutput" %in% class(bayesianSetup)){ + restart <- TRUE + } else restart <- FALSE + + + if(restart){ + if(is.null(settings)) settings <- bayesianSetup$settings + else settings <- applySettingsDefault(settings = settings, sampler = "DEzs") + }else{ + # If nothing provided use default settings + settings <- applySettingsDefault(settings = settings, sampler = "DEzs") + } + + if(!restart){ + setup <- bayesianSetup + } else setup <- bayesianSetup$setup + + setup <- checkBayesianSetup(setup, parallel = settings$parallel) # calling parallel will check if requested parallelization in settings is provided by the BayesianSetup + if(is.null(settings$parallel)) settings$parallel = setup$parallel # checking back - if no parallelization is provided, we use the parallelization in the BayesianSetup. We could also set parallel = F, but I feel it makes more sense to use the Bayesiansetup as default + + if(!restart){ + if(is.null(settings$startValue)){ + parLen = length(bayesianSetup$prior$sampler(1)) + X = bayesianSetup$prior$sampler(3) + } + if(is.function(settings$startValue)){ + X = settings$startValue() + } + if(class(settings$startValue)[1] == "numeric"){ + X = bayesianSetup$prior$sampler(settings$startValue) + } + + if(is.matrix(settings$startValue)) X <- settings$startValue + + if(is.null(settings$Z)){ + parLen = length(bayesianSetup$prior$sampler(1)) + Z = bayesianSetup$prior$sampler(parLen * 10) + } + if(is.function(settings$Z)){ + Z = settings$Z() + } + + if(class(settings$Z)[1] == "numeric"){ + Z = bayesianSetup$prior$sampler(settings$Z) + } + if(is.matrix(settings$Z)) Z <- settings$Z + + }else{ + X <- bayesianSetup$X + Z <- bayesianSetup$Z + if(is.vector(Z)) Z = as.matrix(Z) + } + + + if (! is.matrix(X)) stop("wrong starting values") + if (! is.matrix(Z)) stop("wrong Z values") + + + FUN = setup$posterior$density + + if(is.null(settings$parallel)) parallel = setup$parallel else parallel <- settings$parallel + if(parallel == T & setup$parallel == F) stop("parallel = T requested in DEzs but BayesianSetup does not support parallelization. See help of BayesianSetup on how to enable parallelization") + + ## Initialize blockUpdate parameters and settings + blockdefault <- list("none", k = NULL, h = NULL, pSel = NULL, pGroup = NULL, + groupStart = 1000, groupIntervall = 1000) + + if(!is.null(settings$blockUpdate)){ + blockUpdate <- modifyList(blockdefault, settings$blockUpdate) + blockUpdate[[1]] <- settings$blockUpdate[[1]] # to catch first argument + if(blockUpdate[[1]] == "none"){ + blockUpdateType <- "none" + blocks = FALSE + BlockStart = FALSE + }else{ + groupStart <- blockUpdate$groupStart + groupIntervall <- blockUpdate$groupIntervall + blockUpdateType = blockUpdate[[1]] + blocks = TRUE + ## Initialize BlockStart + BlockStart = FALSE + Bcount = 0 + } + }else{ + blockUpdateType <- "none" + blocks = FALSE + BlockStart = FALSE + } + + + # Initialize parameter values. Because they are called in + # the loop this saves time in comparison to referencing them + # every iteration using settings$... + iterations <- settings$iterations + consoleUpdates <- settings$currentChain + currentChain <- settings$currentChain + pSnooker <- settings$pSnooker + zUpdateFrequency <- settings$zUpdateFrequency + pGamma1 <- settings$pGamma1 + eps.mult <- settings$eps.mult + eps.add <- settings$eps.add + + # Initialization of previous chain length (= 0 if restart = F) + lChainOld <- 0 + + Npar <- ncol(X) + Npar12 <- (Npar - 1)/2 # factor for Metropolis ratio DE Snooker update + + # M0 is initial population size of Z is the size of Z, it's the same number, only kept 2 to stay consistent with the ter Brakk & Vrugt 2008 + M = M0 = nrow(Z) + Npop <- nrow(X) + + F2 = settings$f/sqrt(2*Npar) + F1 = 1.0 + rr = NULL + r_extra = 0 + + #if(burnin != 0) stop("burnin option is currently not implemented") + + burnin <- settings$burnin/Npop + n.iter <- ceiling(settings$iterations/Npop) + if (n.iter < 2) stop ("The total number of iterations must be greater than 3") + + lChain <- ceiling((n.iter - burnin)/settings$thin)+1 + + pChain <- array(NA, dim=c(lChain, Npar+3, Npop)) + + colnames(pChain) <- c(setup$names, "LP", "LL", "LPr") + + + # Print adjusted iterations +# cat("Iterations adjusted to", n.iter*Npop,"to fit settings", "\n") + + + # assign memory for Z + Zold <- Z + Z <- matrix(NA, nrow= M0 + floor((n.iter-1) /zUpdateFrequency) * Npop, ncol=Npar) + + Z[1:M,] <- Zold + + + counter <- 1 + counterZ <- 0 + + # accept.prob <- 0 + logfitness_X <- FUN(X, returnAll = T) + + + # Write first values in chain + pChain[1,,] <- t(cbind(X,logfitness_X)) + + + + for (iter in 2:n.iter) { + f <- ifelse(iter%%10 == 0, 0.98, F1) + #accept <- 0 + + + if(blocks){ + ### Update the groups. + if(iter == groupStart+ Bcount*groupIntervall){ + blockSettings <- updateGroups(chain = pChain[1:counter,, ], blockUpdate) + BlockStart <- TRUE + Bcount <- Bcount + 1 + } + } + + + if(parallel == TRUE | parallel == "external"){ + x_prop <- matrix(NA, nrow= Npop, ncol=Npar) + r_extra <- numeric(Npop) + + + for(i in 1:Npop){ + # select to random different individuals (and different from i) in rr, a 2-vector + rr <- sample.int(M, 3, replace = FALSE) + if(runif(1) < pSnooker) { + z <- Z[rr[3],] + x_z <- X[i,] - z + D2 <- max(sum(x_z*x_z), 1.0e-300) + projdiff <- sum((Z[rr[1],] -Z[rr[2],]) * x_z)/D2 # inner_product of difference with x_z / squared norm x_z + gamma_snooker <- runif(1, min=1.2,max=2.2) + + x_prop[i,] <- X[i,] + gamma_snooker * projdiff * x_z + x_z <- x_prop[i,] - z + D2prop <- max(sum(x_z*x_z), 1.0e-300) + r_extra[i] <- Npar12 * (log(D2prop) - log(D2)) + + } else { + if ( runif(1)< pGamma1 ) { gamma_par = F1 # to be able to jump between modes + } else { + gamma_par = F2 * runif(Npar, min=1-eps.mult, max=1+eps.mult) # multiplicative error to be applied to the difference + # gamma_par = F2 + } + rr = sample.int(M, 2, replace = FALSE) + if (eps.add ==0) { # avoid generating normal random variates if possible + x_prop[i,] = X[i,] + gamma_par * (Z[rr[1],]-Z[rr[2],]) + } else { + x_prop[i,] = X[i,] + gamma_par * (Z[rr[1],]-Z[rr[2],]) + eps.add*rnorm(Npar,0,1) + } + r_extra = rep(0, Npop) + } + } + # end proposal creation + + if(BlockStart){ + # Get the current group and update the proposal accordingly + Member <- getBlock(blockSettings) + x_prop[,-Member] <- X[,-Member] + #### + } + + + # run proposals + logfitness_x_prop <- FUN(x_prop, returnAll = T) + + # evaluate acceptance + for(i in 1:Npop){ + if(!is.na(logfitness_x_prop[i,1] - logfitness_X[i,1])){ + if ((logfitness_x_prop[i,1] - logfitness_X[i,1] + r_extra[i]) > log(runif(1))){ + # accept <- accept + 1 + X[i,] <- x_prop[i,] + logfitness_X[i,] <- logfitness_x_prop[i,] + } + } + } + + } else{ + # if not parallel + + for (i in 1:Npop){ + # select to random different individuals (and different from i) in rr, a 2-vector + rr <- sample.int(M, 3, replace = FALSE) + if(runif(1) < pSnooker) { + z <- Z[rr[3],] + x_z <- X[i,] - z + D2 <- max(sum(x_z*x_z), 1.0e-300) + projdiff <- sum((Z[rr[1],] -Z[rr[2],]) * x_z)/D2 # inner_product of difference with x_z / squared norm x_z + gamma_snooker <- runif(1, min=1.2,max=2.2) + x_prop <- X[i,] + gamma_snooker * projdiff * x_z + x_z <- x_prop - z + D2prop <- max(sum(x_z*x_z), 1.0e-300) + r_extra <- Npar12 * (log(D2prop) - log(D2)) + } else { + + if ( runif(1)< pGamma1 ) { gamma_par = F1 # to be able to jump between modes + } else { + gamma_par = F2 * runif(Npar, min=1-eps.mult, max=1+eps.mult) # multiplicative error to be applied to the difference + # gamma_par = F2 + } + rr = sample.int(M, 2, replace = FALSE) + if (eps.add ==0) { # avoid generating normal random variates if possible + x_prop = X[i,] + gamma_par * (Z[rr[1],]-Z[rr[2],]) } else { + x_prop = X[i,] + gamma_par * (Z[rr[1],]-Z[rr[2],]) + eps.add*rnorm(Npar,0,1) + } + r_extra = 0 + + } + if(BlockStart){ + # Get the current group and update the proposal accordingly + Member <- getBlock(blockSettings) + x_prop[-Member] <- X[i,-Member] + #### + } + + + # evaluate proposal - can this be mixed with the parallel above? + logfitness_x_prop <- FUN(x_prop, returnAll = T) + + # evaluate acceptance + if(!is.na(logfitness_x_prop[1] - logfitness_X[i,1])){ + if ((logfitness_x_prop[1] - logfitness_X[i,1] + r_extra) > log(runif(1))){ + # accept <- accept + 1 + X[i,] <- x_prop + logfitness_X[i,] <- logfitness_x_prop + } + } + } # for Npop + + + } + + if ((iter > burnin) && (iter %% settings$thin == 0) ) { # retain sample + counter <- counter+1 + pChain[counter,,] <- t(cbind(X,logfitness_X)) + + } + + if (iter%%zUpdateFrequency == 0) { # update history + + Z[( M0 + (counterZ*Npop) + 1 ):( M0 + (counterZ+1)*Npop),] <- X + counterZ <- counterZ +1 + M <- M + Npop + } + # Console update + + if(settings$message){ + if( (iter %% settings$consoleUpdates == 0) | (iter == n.iter)) cat("\r","Running DEzs-MCMC, chain ", currentChain, + "iteration" ,iter*Npop,"of",n.iter*Npop,". Current logp ", + logfitness_X[,1],". Please wait!","\r") + flush.console() + } + } # n.iter + + + pChain <- pChain[1:counter,,] + + if(restart){ # Combine chains + newchains <- array(NA, dim = c((counter+nrow(bayesianSetup$chain[[1]])), (Npar+3), Npop)) + + for(i in 1:Npop){ + for(k in 1:(Npar+3)){ + newchains[,k,i] <- c(bayesianSetup$chain[[i]][,k],pChain[,k,i]) + } + } + pChain <- newchains + } + + + pChain<- coda::as.mcmc.list(lapply(1:Npop,function(i) coda::as.mcmc(pChain[,1:(Npar+3),i]))) + + + + list(Draws = pChain, X = as.matrix(X[,1:Npar]), Z = Z) +} diff --git a/BayesianTools/R/mcmcDREAM.R b/BayesianTools/R/mcmcDREAM.R index ead86c5..b2504f2 100644 --- a/BayesianTools/R/mcmcDREAM.R +++ b/BayesianTools/R/mcmcDREAM.R @@ -1,353 +1,353 @@ -### DREAM algorithm - -#' DREAM -#' @author Stefan Paul -#' @param bayesianSetup Object of class 'bayesianSetup' or 'bayesianOuput'. -#' @param settings list with parameter values -#' @param iterations Number of model evaluations -#' @param nCR parameter determining the number of cross-over proposals. If nCR = 1 all parameters are updated jointly. -#' @param updateInterval determining the intervall for the pCR update -#' @param gamma Kurtosis parameter Bayesian Inference Scheme -#' @param eps Ergodicity term -#' @param e Ergodicity term -#' @param pCRupdate If T, crossover probabilities will be updated -#' @param burnin number of iterations treated as burn-in. These iterations are not recorded in the chain. -#' @param thin thin thinning parameter. Determines the interval in which values are recorded. -#' @param adaptation Number or percentage of samples that are used for the adaptation in DREAM (see Details). -#' @param DEpairs Number of pairs used to generate proposal -#' @param startValue eiter a matrix containing the start values (see details), an integer to define the number of chains that are run, a function to sample the start values or NUll, in which case the values are sampled from the prior. -#' @param consoleUpdates Intervall in which the sampling progress is printed to the console -#' @param message logical determines whether the sampler's progress should be printed -#' @return mcmc.object containing the following elements: chains, X, pCR -#' @references Vrugt, Jasper A., et al. "Accelerating Markov chain Monte Carlo simulation by differential evolution with self-adaptive randomized subspace sampling." International Journal of Nonlinear Sciences and Numerical Simulation 10.3 (2009): 273-290. -#' @details Insted of a bayesianSetup, the function can take the output of a previous run to restart the sampler -#' from the last iteration. Due to the sampler's internal structure you can only use the output -#' of DREAM. -#' If you provide a matrix with start values the number of rows determines the number of chains that are run. -#' The number of coloumns must be equivalent to the number of parameters in your bayesianSetup. \cr\cr -#' There are several small differences in the algorithm presented here compared to the original paper by Vrugt et al. (2009). Mainly -#' the algorithm implemented here does not have an automatic stopping criterion. Hence, it will -#' always run the number of iterations specified by the user. Also, convergence is not -#' monitored and left to the user. This can easily be done with coda::gelman.diag(chain). -#' Further the proposed delayed rejectio step in Vrugt et al. (2009) is not implemented here.\cr\cr -#' -#' During the adaptation phase DREAM is running two mechanisms to enhance the sampler's efficiency. -#' First the disribution of crossover values is tuned to favor large jumps in the parameter space. -#' The crossover probabilities determine how many parameters are updated simultaneously. -#' Second outlier chains are replanced as they can largely deteriorate the sampler's performance. -#' However, these steps destroy the detailed balance of the chain. Consequently these parts of the chain -#' should be discarded when summarizing posterior moments. This can be done automatically during the -#' sampling process (i.e. burnin > adaptation) or subsequently by the user. We chose to distinguish between -#' the burnin and adaptation phase to allow the user more flexibility in the sampler's settings. -#' -#' -#' @example /inst/examples/DEfamilyHelp.R -#' @seealso \code{\link{DREAMzs}} -#' @export -DREAM <- function(bayesianSetup, settings = list( - iterations = 10000, - nCR = 3, - gamma = NULL, - eps = 0, - e = 5e-2, - pCRupdate = TRUE, - updateInterval = 10, - burnin = 0, - thin = 1, - adaptation = 0.2, - parallel = NULL, - DEpairs = 2, - consoleUpdates = 10, - startValue = NULL, - currentChain = 1, - message = TRUE)) -{ - - if("bayesianOutput" %in% class(bayesianSetup)){ - restart <- TRUE - } else restart <- FALSE - - - if(restart){ - if(is.null(settings)) settings <- bayesianSetup$settings - else settings <- applySettingsDefault(settings = settings, sampler = "DREAM") - - settings$adaptation <- 0 # set adaptation to 0 if restart because it has already been - # applied in chain that is restarted and destroys detailed balance. - - }else{ - # If nothing provided use default settings - settings <- applySettingsDefault(settings = settings, sampler = "DREAM") - } - - if(!restart){ - setup <- bayesianSetup - }else{ - setup <- bayesianSetup$setup - } - - - setup <- checkBayesianSetup(setup, parallel = settings$parallel) # calling parallel will check if requested parallelization in settings is provided by the BayesianSetup - if(is.null(settings$parallel)) settings$parallel = setup$parallel # checking back - if no parallelization is provided, we use the parallelization in the BayesianSetup. We could also set parallel = F, but I feel it makes more sense to use the Bayesiansetup as default - - if(!restart){ - if(is.null(settings$startValue)){ - parLen = length(bayesianSetup$prior$sampler(1)) - X = bayesianSetup$prior$sampler(max(4,2 * parLen)) - } - if(is.function(settings$startValue)){ - X = settings$startValue() - } - if(class(settings$startValue)[1] == "numeric"){ - X = bayesianSetup$prior$sampler(settings$startValue) - } - if(is.matrix(settings$startValue)) X <- settings$startValue - }else{ - X <- bayesianSetup$X - } - - # X = startValue - if (!is.matrix(X)) stop("wrong starting values") - - currentChain = settings$currentChain - - FUN = setup$posterior$density - - pCRupdate <- settings$pCRupdate - nCR <- settings$nCR - Npar <- ncol(X) - Npop <- nrow(X) - - # Check for consistency of DEpairs - if(settings$DEpairs > (Npop-2)) stop("DEpairs to large for number of chains") - - # Set adaptation if percentage is supplied - if(settings$adaptation <1) settings$adaptation <- settings$adaptation*settings$iterations - - # Set number of iterations and initialize chain - n.iter <- ceiling(settings$iterations/Npop) - if (n.iter < 2) stop ("The total number of iterations must be greater than the number of parameters to fit times 2.") - - settings$burnin <- settings$burnin/Npop - lChain <- ceiling((n.iter - settings$burnin)/settings$thin)+1 - pChain <- array(NA, dim=c(lChain, Npar+3, Npop)) - colnames(pChain) <- c(setup$names, "LP", "LL", "LPr") - - # Evaluate start values and write them in the chain - logfitness_X <- FUN(X, returnAll = T) - pChain[1,,] <- t(cbind(X,logfitness_X)) - - # Set counter - counter <- 1 - iseq <- 1:Npop - - # gamma initialization. However gamma is calculated every iteration (see below). - gamma <- 2.38/sqrt(settings$DEpairs*Npar) - - - # delta initialization - delta <- rep(0, settings$nCR) - - funevals <- 0 - - #### pCR update - if(!restart){ - pCR = rep(1/nCR, nCR) - lCR <- rep(0,nCR) - - CR <- matrix(1/nCR, nrow = Npop, ncol = settings$updateInterval) - }else{ - pCR <- bayesianSetup$pCR - CR <- generateCRvalues(pCR, settings, Npop) - - } - - # helper counter for CR value index - counter_update <- 0 - - ## omega initialization - omega <- numeric() - - ## eps and e - eps <- settings$eps - e <- settings$e - - - ##################### Start iterations ############################## - for(iter in 2:n.iter){ - - xOld <- X - counter_update <- counter_update +1 - - for(i in 1:Npop){ - - selectedChains1 <- sample((1:Npop)[-i], settings$DEpairs, replace = FALSE) - selectedChains2 <- numeric(settings$DEpairs) - - # Avoid that selected chains are identical - for(k in 1:settings$DEpairs){ - selectedChains2[k] <- sample((1:Npop)[-c(i,selectedChains1[k],selectedChains2[1:k]) ],1) - } - - - # Get indices of parameters that are updated = indX - rn <- runif(Npar) - indX <- which(rn>(1-CR[i, counter_update])) - - # Make sure at least one dimension is updated - if(length(indX) == 0) indX <- sample(1:Npar, 1) - - # First update proposal - x_prop <- X[i,] - - - # Calculate gamma based on DEpairs and number of dimensions - # that are updated simulateously. - # To jump between modes gamma is set to 1 every fifth iteration. - if(runif(1)>4/5){ - gamma <- 1 - }else{ - gamma <-2.38/sqrt(settings$DEpairs* length(indX)) - } - - - # Replace with new proposal for indX - x_prop[indX] <- X[i,indX] + (1+e)*gamma*(apply(as.matrix(X[selectedChains1,indX]),2,sum)- - apply(as.matrix(X[selectedChains2,indX]),2,sum)) + eps*rnorm(length(indX),0,1) - - - - - logfitness_x_prop <- FUN(x_prop, returnAll = T) - if(!is.na(logfitness_x_prop[1] - logfitness_X[i,1])){ # To catch possible error - if ((logfitness_x_prop[1] - logfitness_X[i,1] ) > log(runif(1))){ - X[i,] <- x_prop - logfitness_X[i,] <- logfitness_x_prop - } - - } - - } #Npop - - - - ## Write values in chain - - if((iter > settings$burnin) && (iter %% settings$thin == 0)){ - counter <- counter+1 - pChain[counter,,] <- t(cbind(X,logfitness_X)) - } - - if(iter < settings$adaptation){ - - if(pCRupdate){ ## Calculate delta, this is (unlike the update) done every iteration - ## Calculate delta - - ## Calculate standard deviation of each dimension of X - sdX <- apply(X[,1:Npar,drop=FALSE],2,sd) - - ## Compute Euclidean distance between old and new X values - delta_Norm <- rowSums(((xOld-X[,1:Npar,drop=FALSE])/sdX)^2) - - ## Now delta can be calculated - for (k in 1:settings$nCR){ # Loop over CR values - - # Find updated chains - ind <- which(abs(CR[,k]-(k/nCR)) < 1e-5) - - ## Add normalized squared distance to the current delta - delta[k] <- delta[k]+sum(delta_Norm[ind]) - #delta[k] <- delta[k]+sum(delta_Norm) - - } - - } - - - if(iter%%settings$updateInterval == 0){ - - - if(pCRupdate){ - # Update CR values - tmp <- AdaptpCR(CR, delta, lCR, settings, Npop) - pCR <- tmp$pCR - lCR <- tmp$lCR - - ## CR values are generated outside loop because they are calculated - # even after adaptation phase. See below! - } - - ## remove outliers - ## TODO include if(remOutliers = TRUE) ?? - for(out in 1:Npop){ - omega[out] <- mean(pChain[((counter/2):counter),Npar+1, out]) - } - - if(NaN %in% omega){ - outlierChain <- NULL # Prevent possible error - }else{ - # Inter quantile range - IQR <- quantile(omega, probs = c(0.25, 0.75)) - - # Determine outlier chains - outlierChain <- which(omega< IQR[1] - 2*(IQR[2]-IQR[1])) - } - - - # Replace with best chain - if(length(outlierChain) > 0){ - best <- which.max(pChain[counter,Npar+1,]) - pChain[counter,,outlierChain] <- pChain[counter,,best] - - } # Remove outliers - - } - } - - - if(iter%%settings$updateInterval == 0){ - counter_update <- 0 # set counter back to zero - CR <- generateCRvalues(pCR, settings, Npop) - - } - - if(settings$message){ - if( (iter %% settings$consoleUpdates == 0) | (iter == n.iter)) cat("\r","Running DREAM-MCMC, chain ", currentChain, - "iteration" ,iter*Npop,"of",n.iter*Npop,". Current logp ", - logfitness_X[,1], - "Please wait!","\r") - flush.console() - } - - - } # niter - - ################ End of iterations ################ - - - iterationsOld <- 0 - - pChain <- pChain[1:counter,,] - - if(restart){ # Combine chains - newchains <- array(NA, dim = c((counter+nrow(bayesianSetup$chain[[1]])), (Npar+3), Npop)) - - for(i in 1:Npop){ - for(k in 1:(Npar+3)){ - newchains[,k,i] <- c(bayesianSetup$chain[[i]][,k],pChain[,k,i]) - } - } - pChain <- newchains - } - - pChain<- coda::as.mcmc.list(lapply(1:Npop,function(i) coda::as.mcmc(pChain[,1:(Npar+3),i]))) - - - return(list(chains = pChain, X = as.matrix(X[,1:Npar]), pCR = pCR)) - -} - - - - - +### DREAM algorithm + +#' DREAM +#' @author Stefan Paul +#' @param bayesianSetup object of class 'bayesianSetup' or 'bayesianOuput'. +#' @param settings list with parameter values +#' @param iterations number of model evaluations +#' @param nCR parameter determining the number of cross-over proposals. If nCR = 1 all parameters are updated jointly. +#' @param updateInterval determines the interval for the pCR update +#' @param gamma Kurtosis parameter Bayesian Inference Scheme +#' @param eps Ergodicity term +#' @param e Ergodicity term +#' @param pCRupdate logical, if T, crossover probabilities will be updated +#' @param burnin number of iterations treated as burn-in. These iterations are not recorded in the chain. +#' @param thin thinning parameter. Determines the interval in which values are recorded. +#' @param adaptation number or percentage of samples that are used for the adaptation in DREAM (see Details). +#' @param DEpairs number of pairs used to generate proposal +#' @param startValue either a matrix containing the start values (see details), an integer to define the number of chains to be run, a function to sample the start values or NUll - in which case the values are sampled from the prior. +#' @param consoleUpdates interval at which the sampling progress is printed to the console +#' @param message logical, determines whether the sampler's progress should be printed +#' @return mcmc.object containing the following elements: chains, X, pCR +#' @references Vrugt, Jasper A., et al. "Accelerating Markov chain Monte Carlo simulation by differential evolution with self-adaptive randomized subspace sampling." International Journal of Nonlinear Sciences and Numerical Simulation 10.3 (2009): 273-290. +#' @details Instead of a bayesianSetup, the function can take the output of a previous run to restart the sampler +#' from the last iteration. Due to the sampler's internal structure you can only use the output +#' of DREAM. +#' If you provide a matrix with start values, the number of rows determines the number of chains that will be run. +#' The number of coloumns must be equivalent to the number of parameters in your bayesianSetup. \cr\cr +#' There are several small differences in the algorithm presented here compared to the original paper by Vrugt et al. (2009). Mainly +#' The algorithm implemented here does not have an automatic stopping criterion. Hence, it will +#' always run the number of iterations specified by the user. Also, convergence is not +#' monitored and left to the user. This can easily be done with coda::gelman.diag(chain). +#' Furthermore, the delayed rejection step proposed in Vrugt et al. (2009) is not implemented here.\cr\cr +#' +#' During the adaptation phase DREAM is running two mechanisms to enhance the sampler's efficiency. +#' First, the disribution of crossover values is tuned to favor large jumps in the parameter space. +#' The crossover probabilities determine how many parameters are updated simultaneously. +#' Second, outlier chains are replaced as they can largely deteriorate the sampler's performance. +#' However, these steps destroy the detailed balance of the chain. Consequently these parts of the chain +#' should be discarded when summarizing posterior moments. This can be done automatically during the +#' sampling process (i.e. burn-in > adaptation) or subsequently by the user. We chose to distinguish between +#' the burn-in and adaptation phase to allow the user more flexibility in the sampler's settings. +#' +#' +#' @example /inst/examples/DEfamilyHelp.R +#' @seealso \code{\link{DREAMzs}} +#' @export +DREAM <- function(bayesianSetup, settings = list( + iterations = 10000, + nCR = 3, + gamma = NULL, + eps = 0, + e = 5e-2, + pCRupdate = TRUE, + updateInterval = 10, + burnin = 0, + thin = 1, + adaptation = 0.2, + parallel = NULL, + DEpairs = 2, + consoleUpdates = 10, + startValue = NULL, + currentChain = 1, + message = TRUE)) +{ + + if("bayesianOutput" %in% class(bayesianSetup)){ + restart <- TRUE + } else restart <- FALSE + + + if(restart){ + if(is.null(settings)) settings <- bayesianSetup$settings + else settings <- applySettingsDefault(settings = settings, sampler = "DREAM") + + settings$adaptation <- 0 # set adaptation to 0 if restart because it has already been + # applied in chain that is restarted and destroys detailed balance. + + }else{ + # If nothing provided use default settings + settings <- applySettingsDefault(settings = settings, sampler = "DREAM") + } + + if(!restart){ + setup <- bayesianSetup + }else{ + setup <- bayesianSetup$setup + } + + + setup <- checkBayesianSetup(setup, parallel = settings$parallel) # calling parallel will check if requested parallelization in settings is provided by the BayesianSetup + if(is.null(settings$parallel)) settings$parallel = setup$parallel # checking back - if no parallelization is provided, we use the parallelization in the BayesianSetup. We could also set parallel = F, but I feel it makes more sense to use the Bayesiansetup as default + + if(!restart){ + if(is.null(settings$startValue)){ + parLen = length(bayesianSetup$prior$sampler(1)) + X = bayesianSetup$prior$sampler(max(4,2 * parLen)) + } + if(is.function(settings$startValue)){ + X = settings$startValue() + } + if(class(settings$startValue)[1] == "numeric"){ + X = bayesianSetup$prior$sampler(settings$startValue) + } + if(is.matrix(settings$startValue)) X <- settings$startValue + }else{ + X <- bayesianSetup$X + } + + # X = startValue + if (!is.matrix(X)) stop("wrong starting values") + + currentChain = settings$currentChain + + FUN = setup$posterior$density + + pCRupdate <- settings$pCRupdate + nCR <- settings$nCR + Npar <- ncol(X) + Npop <- nrow(X) + + # Check for consistency of DEpairs + if(settings$DEpairs > (Npop-2)) stop("DEpairs to large for number of chains") + + # Set adaptation if percentage is supplied + if(settings$adaptation <1) settings$adaptation <- settings$adaptation*settings$iterations + + # Set number of iterations and initialize chain + n.iter <- ceiling(settings$iterations/Npop) + if (n.iter < 2) stop ("The total number of iterations must be greater than the number of parameters to fit times 2.") + + settings$burnin <- settings$burnin/Npop + lChain <- ceiling((n.iter - settings$burnin)/settings$thin)+1 + pChain <- array(NA, dim=c(lChain, Npar+3, Npop)) + colnames(pChain) <- c(setup$names, "LP", "LL", "LPr") + + # Evaluate start values and write them in the chain + logfitness_X <- FUN(X, returnAll = T) + pChain[1,,] <- t(cbind(X,logfitness_X)) + + # Set counter + counter <- 1 + iseq <- 1:Npop + + # gamma initialization. However gamma is calculated every iteration (see below). + gamma <- 2.38/sqrt(settings$DEpairs*Npar) + + + # delta initialization + delta <- rep(0, settings$nCR) + + funevals <- 0 + + #### pCR update + if(!restart){ + pCR = rep(1/nCR, nCR) + lCR <- rep(0,nCR) + + CR <- matrix(1/nCR, nrow = Npop, ncol = settings$updateInterval) + }else{ + pCR <- bayesianSetup$pCR + CR <- generateCRvalues(pCR, settings, Npop) + + } + + # helper counter for CR value index + counter_update <- 0 + + ## omega initialization + omega <- numeric() + + ## eps and e + eps <- settings$eps + e <- settings$e + + + ##################### Start iterations ############################## + for(iter in 2:n.iter){ + + xOld <- X + counter_update <- counter_update +1 + + for(i in 1:Npop){ + + selectedChains1 <- sample((1:Npop)[-i], settings$DEpairs, replace = FALSE) + selectedChains2 <- numeric(settings$DEpairs) + + # Avoid that selected chains are identical + for(k in 1:settings$DEpairs){ + selectedChains2[k] <- sample((1:Npop)[-c(i,selectedChains1[k],selectedChains2[1:k]) ],1) + } + + + # Get indices of parameters that are updated = indX + rn <- runif(Npar) + indX <- which(rn>(1-CR[i, counter_update])) + + # Make sure at least one dimension is updated + if(length(indX) == 0) indX <- sample(1:Npar, 1) + + # First update proposal + x_prop <- X[i,] + + + # Calculate gamma based on DEpairs and number of dimensions + # that are updated simulateously. + # To jump between modes gamma is set to 1 every fifth iteration. + if(runif(1)>4/5){ + gamma <- 1 + }else{ + gamma <-2.38/sqrt(settings$DEpairs* length(indX)) + } + + + # Replace with new proposal for indX + x_prop[indX] <- X[i,indX] + (1+e)*gamma*(apply(as.matrix(X[selectedChains1,indX]),2,sum)- + apply(as.matrix(X[selectedChains2,indX]),2,sum)) + eps*rnorm(length(indX),0,1) + + + + + logfitness_x_prop <- FUN(x_prop, returnAll = T) + if(!is.na(logfitness_x_prop[1] - logfitness_X[i,1])){ # To catch possible error + if ((logfitness_x_prop[1] - logfitness_X[i,1] ) > log(runif(1))){ + X[i,] <- x_prop + logfitness_X[i,] <- logfitness_x_prop + } + + } + + } #Npop + + + + ## Write values in chain + + if((iter > settings$burnin) && (iter %% settings$thin == 0)){ + counter <- counter+1 + pChain[counter,,] <- t(cbind(X,logfitness_X)) + } + + if(iter < settings$adaptation){ + + if(pCRupdate){ ## Calculate delta, this is (unlike the update) done every iteration + ## Calculate delta + + ## Calculate standard deviation of each dimension of X + sdX <- apply(X[,1:Npar,drop=FALSE],2,sd) + + ## Compute Euclidean distance between old and new X values + delta_Norm <- rowSums(((xOld-X[,1:Npar,drop=FALSE])/sdX)^2) + + ## Now delta can be calculated + for (k in 1:settings$nCR){ # Loop over CR values + + # Find updated chains + ind <- which(abs(CR[,k]-(k/nCR)) < 1e-5) + + ## Add normalized squared distance to the current delta + delta[k] <- delta[k]+sum(delta_Norm[ind]) + #delta[k] <- delta[k]+sum(delta_Norm) + + } + + } + + + if(iter%%settings$updateInterval == 0){ + + + if(pCRupdate){ + # Update CR values + tmp <- AdaptpCR(CR, delta, lCR, settings, Npop) + pCR <- tmp$pCR + lCR <- tmp$lCR + + ## CR values are generated outside loop because they are calculated + # even after adaptation phase. See below! + } + + ## remove outliers + ## TODO include if(remOutliers = TRUE) ?? + for(out in 1:Npop){ + omega[out] <- mean(pChain[((counter/2):counter),Npar+1, out]) + } + + if(NaN %in% omega){ + outlierChain <- NULL # Prevent possible error + }else{ + # Inter quantile range + IQR <- quantile(omega, probs = c(0.25, 0.75)) + + # Determine outlier chains + outlierChain <- which(omega< IQR[1] - 2*(IQR[2]-IQR[1])) + } + + + # Replace with best chain + if(length(outlierChain) > 0){ + best <- which.max(pChain[counter,Npar+1,]) + pChain[counter,,outlierChain] <- pChain[counter,,best] + + } # Remove outliers + + } + } + + + if(iter%%settings$updateInterval == 0){ + counter_update <- 0 # set counter back to zero + CR <- generateCRvalues(pCR, settings, Npop) + + } + + if(settings$message){ + if( (iter %% settings$consoleUpdates == 0) | (iter == n.iter)) cat("\r","Running DREAM-MCMC, chain ", currentChain, + "iteration" ,iter*Npop,"of",n.iter*Npop,". Current logp ", + logfitness_X[,1], + "Please wait!","\r") + flush.console() + } + + + } # niter + + ################ End of iterations ################ + + + iterationsOld <- 0 + + pChain <- pChain[1:counter,,] + + if(restart){ # Combine chains + newchains <- array(NA, dim = c((counter+nrow(bayesianSetup$chain[[1]])), (Npar+3), Npop)) + + for(i in 1:Npop){ + for(k in 1:(Npar+3)){ + newchains[,k,i] <- c(bayesianSetup$chain[[i]][,k],pChain[,k,i]) + } + } + pChain <- newchains + } + + pChain<- coda::as.mcmc.list(lapply(1:Npop,function(i) coda::as.mcmc(pChain[,1:(Npar+3),i]))) + + + return(list(chains = pChain, X = as.matrix(X[,1:Npar]), pCR = pCR)) + +} + + + + + diff --git a/BayesianTools/R/mcmcDREAM_helperFunctions.R b/BayesianTools/R/mcmcDREAM_helperFunctions.R index a798bef..f7e6f80 100644 --- a/BayesianTools/R/mcmcDREAM_helperFunctions.R +++ b/BayesianTools/R/mcmcDREAM_helperFunctions.R @@ -1,75 +1,73 @@ - - -##' Generates matrix of CR values based on pCR -##' @param pCR Vector of crossover probabilities. Needs to be of length nCR. -##' @param settings settings list -##' @param Npop number of chains -##' @return Matrix with CR values -#' @keywords internal -generateCRvalues <- function(pCR,settings, Npop){ - - # Random vector, add zero to get first position - RandomVec <- c(0,cumsum(as.numeric(rmultinom(1, size = Npop*settings$updateInterval, prob = pCR)))) - - # get candidate points - cand <- sample(Npop*settings$updateInterval) - CR <- rep(NA, Npop*settings$updateInterval) - - ## Now loop over chains to generate CR values - for(i in 1:settings$nCR){ - #Start and End - Start <- RandomVec[i]+1 - End <- RandomVec[i+1] - - # get candidates - candx <- cand[Start:End] - - # Assign these indices settings$CR - CR[candx] <- i/settings$nCR - } - ## Reshape CR - CR <- matrix(CR,Npop,settings$updateInterval) - - return(CR) -} - - - - -#' Adapts pCR values -#' @param CR Vector of crossover probabilities. Needs to be of length nCR. -#' @param settings settings list -#' @param delta vector with differences -#' @param lCR values to weight delta -#' @param Npop number of chains. -#' @return Matrix with CR values -#' @keywords internal -AdaptpCR <- function(CR, delta ,lCR, settings, Npop){ - if(any(delta >0)){ ## Adaptions can only be made if there are changes in X - - # Change CR to vector - CR <- c(CR) - - # Store old lCR values - lCROld <- lCR - ## Determine lCR - lCR <- rep(NA,settings$nCR) - - for (k in 1:settings$nCR){ - - ## how many times a CR value is used. This is used to weight delta - CR_counter <- length(which(CR==k/settings$nCR)) - lCR[k] <- lCROld[k]+ CR_counter - } - - ## Adapt pCR - pCR <- Npop * (delta / lCR) / sum(delta) - - pCR[which(is.nan(pCR))] <- 1/settings$nCR # catch possible error if delta and lCR = 0 - - ## Normalize values - pCR <- pCR/sum(pCR) - - } - return(list(pCR=pCR,lCR=lCR)) -} ##AdaptpCR +##' Generates matrix of CR values based on pCR +##' @param pCR vector of crossover probabilities. Needs to be of length nCR. +##' @param settings list of settings +##' @param Npop number of chains +##' @return Matrix with CR values +#' @keywords internal +generateCRvalues <- function(pCR,settings, Npop){ + + # Random vector, add zero to get first position + RandomVec <- c(0,cumsum(as.numeric(rmultinom(1, size = Npop*settings$updateInterval, prob = pCR)))) + + # get candidate points + cand <- sample(Npop*settings$updateInterval) + CR <- rep(NA, Npop*settings$updateInterval) + + ## Now loop over chains to generate CR values + for(i in 1:settings$nCR){ + #Start and End + Start <- RandomVec[i]+1 + End <- RandomVec[i+1] + + # get candidates + candx <- cand[Start:End] + + # Assign these indices settings$CR + CR[candx] <- i/settings$nCR + } + ## Reshape CR + CR <- matrix(CR,Npop,settings$updateInterval) + + return(CR) +} + + + + +#' Adapts pCR values +#' @param CR vector of crossover probabilities. Needs to be of length nCR. +#' @param settings list of settings +#' @param delta vector with differences +#' @param lCR values to weight delta +#' @param Npop number of chains. +#' @return Matrix with CR values +#' @keywords internal +AdaptpCR <- function(CR, delta ,lCR, settings, Npop){ + if(any(delta >0)){ ## Adaptions can only be made if there are changes in X + + # Change CR to vector + CR <- c(CR) + + # Store old lCR values + lCROld <- lCR + ## Determine lCR + lCR <- rep(NA,settings$nCR) + + for (k in 1:settings$nCR){ + + ## how many times a CR value is used. This is used to weight delta + CR_counter <- length(which(CR==k/settings$nCR)) + lCR[k] <- lCROld[k]+ CR_counter + } + + ## Adapt pCR + pCR <- Npop * (delta / lCR) / sum(delta) + + pCR[which(is.nan(pCR))] <- 1/settings$nCR # catch possible error if delta and lCR = 0 + + ## Normalize values + pCR <- pCR/sum(pCR) + + } + return(list(pCR=pCR,lCR=lCR)) +} ##AdaptpCR diff --git a/BayesianTools/R/mcmcDREAMzs.R b/BayesianTools/R/mcmcDREAMzs.R index 0467da3..6f1fd01 100644 --- a/BayesianTools/R/mcmcDREAMzs.R +++ b/BayesianTools/R/mcmcDREAMzs.R @@ -1,488 +1,488 @@ -### DREAMzs algorithm - -#' DREAMzs -#' @author Stefan Paul -#' @param bayesianSetup Object of class 'bayesianSetup' or 'bayesianOuput'. -#' @param settings list with parameter values -#' @param iterations Number of model evaluations -#' @param nCR parameter determining the number of cross-over proposals. If nCR = 1 all parameters are updated jointly. -#' @param updateInterval determining the intervall for the pCR (crossover probabilities) update -#' @param gamma Kurtosis parameter Bayesian Inference Scheme. -#' @param eps Ergodicity term -#' @param e Ergodicity term -#' @param pCRupdate Update of crossover probabilities -#' @param burnin number of iterations treated as burn-in. These iterations are not recorded in the chain. -#' @param thin thin thinning parameter. Determines the interval in which values are recorded. -#' @param adaptation Number or percentage of samples that are used for the adaptation in DREAM (see Details) -#' @param DEpairs Number of pairs used to generate proposal -#' @param ZupdateFrequency frequency to update Z matrix -#' @param pSnooker probability of snooker update -#' @param Z starting matrix for Z -#' @param startValue eiter a matrix containing the start values (see details), an integer to define the number of chains that are run, a function to sample the start values or NUll, in which case the values are sampled from the prior. -#' @param consoleUpdates Intervall in which the sampling progress is printed to the console -#' @param message logical determines whether the sampler's progress should be printed -#' @return mcmc.object containing the following elements: chains, X, pCR, Z -#' @references Vrugt, Jasper A., et al. "Accelerating Markov chain Monte Carlo simulation by differential evolution with self-adaptive randomized subspace sampling." International Journal of Nonlinear Sciences and Numerical Simulation 10.3 (2009): 273-290. -#' @references ter Braak C. J. F., and Vrugt J. A. (2008). Differential Evolution Markov Chain with snooker updater and fewer chains. Statistics and Computing http://dx.doi.org/10.1007/s11222-008-9104-9 -#' @details Insted of a bayesianSetup, the function can take the output of a previous run to restart the sampler -#' from the last iteration. Due to the sampler's internal structure you can only use the output -#' of DREAMzs. -#' If you provide a matrix with start values the number of rows detemines the number of chains that are run. -#' The number of coloumns must be equivalent to the number of parameters in your bayesianSetup. \cr\cr -#' There are several small differences in the algorithm presented here compared to the original paper by Vrugt et al. (2009). Mainly -#' the algorithm implemented here does not have an automatic stopping criterion. Hence, it will -#' always run the number of iterations specified by the user. Also, convergence is not -#' monitored and left to the user. This can easily be done with coda::gelman.diag(chain). -#' Further the proposed delayed rejectio step in Vrugt et al. (2009) is not implemented here.\cr\cr -#' During the adaptation phase DREAM is running two mechanisms to enhance the sampler's efficiency. -#' First the disribution of crossover values is tuned to favor large jumps in the parameter space. -#' The crossover probabilities determine how many parameters are updated simultaneously. -#' Second outlier chains are replanced as they can largely deteriorate the sampler's performance. -#' However, these steps destroy the detailed balance of the chain. Consequently these parts of the chain -#' should be discarded when summarizing posterior moments. This can be done automatically during the -#' sampling process (i.e. burnin > adaptation) or subsequently by the user. We chose to distinguish between -#' the burnin and adaptation phase to allow the user more flexibility in the sampler's settings. -#' @example /inst/examples/DEfamilyHelp.R -#' @seealso \code{\link{DREAM}} -#' @export -DREAMzs <- function(bayesianSetup, - settings = list(iterations = 10000, - nCR = 3, - gamma = NULL, - eps = 0, - e = 5e-2, - pCRupdate = FALSE, - updateInterval = 10, - burnin = 0, - thin = 1, - adaptation = 0.2, - parallel = NULL, - - Z = NULL, - ZupdateFrequency = 10, - pSnooker = 0.1, - - - DEpairs = 2, - consoleUpdates = 10, - startValue = NULL, - currentChain = 1, - message = FALSE)) { - - - - if("bayesianOutput" %in% class(bayesianSetup)){ - restart <- TRUE - } else restart <- FALSE - - - if(restart){ - if(is.null(settings)) settings <- bayesianSetup$settings - else settings <- applySettingsDefault(settings = settings, sampler = "DREAMzs") - - settings$adaptation <- 0 # set burnIn to 0 if restart because it has already been - # applied in chain that is restarted and destroys detailed balance. - - }else{ - # If nothing provided use default settings - settings <- applySettingsDefault(settings = settings, sampler = "DREAMzs") - } - - if(!restart){ - setup <- bayesianSetup - } else setup <- bayesianSetup$setup - - setup <- checkBayesianSetup(setup, parallel = settings$parallel) # calling parallel will check if requested parallelization in settings is provided by the BayesianSetup - if(is.null(settings$parallel)) settings$parallel = setup$parallel # checking back - if no parallelization is provided, we use the parallelization in the BayesianSetup. We could also set parallel = F, but I feel it makes more sense to use the Bayesiansetup as default - - if(!restart){ - if(is.null(settings$startValue)){ - parLen = length(bayesianSetup$prior$sampler(1)) - X = bayesianSetup$prior$sampler(3) - } - if(is.function(settings$startValue)){ - X = settings$startValue() - } - if(class(settings$startValue)[1] == "numeric"){ - X = bayesianSetup$prior$sampler(settings$startValue) - } - - if(is.matrix(settings$startValue)) X <- settings$startValue - - if(is.null(settings$Z)){ - parLen = length(bayesianSetup$prior$sampler(1)) - Z = bayesianSetup$prior$sampler(parLen * 10) - } - if(is.function(settings$Z)){ - Z = settings$Z() - } - - if(class(settings$Z)[1] == "numeric"){ - Z = bayesianSetup$prior$sampler(settings$Z) - } - if(is.matrix(settings$Z)) Z <- settings$Z - - }else{ - X <- bayesianSetup$X - Z <- bayesianSetup$Z - if(is.vector(Z)) Z = as.matrix(Z) - } - - - if (! is.matrix(X)) stop("wrong starting values") - if (! is.matrix(Z)) stop("wrong Z values") - - - FUN = setup$posterior$density - - pCRupdate <- settings$pCRupdate - nCR <- settings$nCR - Npar <- ncol(X) - - Npar12 <- (Npar - 1)/2 # factor for Metropolis ratio DE Snooker update - - parallel <- settings$parallel - if(!is.null(parallel)){ - if(is.numeric(parallel) | parallel == "external") parallel <- TRUE - }else parallel <- FALSE - - pCRupdate <- settings$pCRupdate - nCR <- settings$nCR - Npar <- ncol(X) - Npop <- nrow(X) - - - # Set adaptation if percentage is supplied - if(settings$adaptation <1) settings$adaptation <- settings$adaptation*settings$iterations - - # Determine number of iterations and initialize chain - n.iter <- ceiling(settings$iterations/Npop) - if (n.iter < 2) stop ("The total number of iterations must be greater than 3") - settings$burnin <- settings$burnin/Npop - lChain <- ceiling((n.iter - settings$burnin)/settings$thin)+1 - pChain <- array(NA, dim=c(lChain, Npar+3, Npop)) - - - # assign memory for Z and write first values in Z - M <- nrow(Z[complete.cases(Z),,drop = FALSE]) - Zold <- Z[complete.cases(Z),,drop = FALSE] - Z <- matrix(NA, nrow= M + floor((n.iter) /settings$ZupdateFrequency) * Npop, ncol=Npar) - Z[1:M,] <- Zold - - - colnames(pChain) <- c(setup$names, "LP", "LL", "LPr") - - - # Evaluate start values and write them in the chain - logfitness_X <- FUN(X, returnAll = T) - pChain[1,,] <- t(cbind(X,logfitness_X)) - - - # Set counter - counter <- 1 - iseq <- 1:Npop - - - #### gamma, initialization. However gamma is calculated every iteration (see below). - gamma <- 2.38/sqrt(settings$DEpairs*Npar) - - - ## delta initialization - delta <- rep(0, settings$nCR) - - funevals <- 0 - #### pCR update - # Initialization - if(!restart){ - pCR = rep(1/nCR, nCR) - lCR <- rep(0,nCR) - - CR <- matrix(1/nCR, nrow = Npop, ncol = settings$updateInterval) - }else{ - pCR <- bayesianSetup$pCR - CR <- generateCRvalues(pCR, settings, Npop) - - } - - - # helper counter for CR value index - counter_update <- 0 - - ## Omega initialization - omega <- numeric() - - ## eps and e - eps <- settings$eps - e <- settings$e - - - ##################### Start iterations ############################## - for(iter in 2:n.iter){ - - xOld <- X - - - if(parallel == TRUE){ - x_prop <- matrix(NA, nrow= Npop, ncol=Npar) - r_extra <- numeric(Npop) - - for(i in 1:Npop){ - - if(runif(1)>settings$pSnooker){ - selectedChains1 <- sample((1:M), settings$DEpairs, replace = FALSE) - selectedChains2 <- numeric(settings$DEpairs) - - # Avoid that selected chains are identical - for(k in 1:settings$DEpairs){ - selectedChains2[k] <- sample((1:M)[-c(selectedChains1[k],selectedChains2[1:k]) ],1) - } - - # Get indices of parameters that are updated = indX - rn <- runif(Npar) - indX <- which(rn>(1-CR[i])) - - # Make sure at least one dimension is updated - if(length(indX) == 0) indX <- sample(1:Npar, 1) - - # First update proposal - x_prop[i,] <- X[i,] - - # Calculate gamma based on DEpairs and number of dimensions - # that are updated simulateously. - # To jump between modes gamma is set to 1 every fifth iteration. - if(runif(1)>4/5){ - gamma <- 1 - }else{ - gamma <-2.38/sqrt(settings$DEpairs* length(indX)) - } - - # No snooker update - # Replace with new proposal for indX - x_prop[i,indX] <- X[i,indX] + (1+e)*gamma*(apply(as.matrix(Z[selectedChains1,indX]),2,sum)- - apply(as.matrix(Z[selectedChains2,indX]),2,sum)) + eps*rnorm(length(indX),0,1) - r_extra[i] <- 0 - - }else{ # Make proposal using snooker update - selectSnooker <- sample((1:M),replace = FALSE, 3) - - z <- Z[selectSnooker[1],] - x_z <- X[i,] - z - D2 <- max(sum(x_z*x_z), 1.0e-300) - projdiff <- sum((Z[selectSnooker[1],] -Z[selectSnooker[2],]) * x_z)/D2 # inner_product of difference with x_z / squared norm x_z - gamma_snooker <- runif(1, min=1.2,max=2.2) - - x_prop[i,] <- X[i,] + gamma_snooker * projdiff * x_z - x_z <- x_prop[i,] - z - D2prop <- max(sum(x_z*x_z), 1.0e-300) - r_extra[i] <- Npar12 * (log(D2prop) - log(D2)) - - } - } # Npop - - - # run proposals - logfitness_x_prop <- FUN(x_prop, returnAll = T) - - # evaluate acceptance - for(i in 1:Npop){ - if(!is.na(logfitness_x_prop[i,1] - logfitness_X[i,1])){ - if ((logfitness_x_prop[i,1] - logfitness_X[i,1] + r_extra[i]) > log(runif(1))){ - # accept <- accept + 1 - X[i,] <- x_prop[i,] - logfitness_X[i,] <- logfitness_x_prop[i,] - } - } - } - - - }else{ ## If not parallel - for(i in 1:Npop){ - - if(runif(1)>settings$pSnooker){ - selectedChains1 <- sample((1:M), settings$DEpairs, replace = FALSE) - selectedChains2 <- numeric(settings$DEpairs) - - # Avoid that selected chains are identical - for(k in 1:settings$DEpairs){ - selectedChains2[k] <- sample((1:M)[-c(selectedChains1[k],selectedChains2[1:k]) ],1) - } - - # Get indices of parameters that are updated = indX - rn <- runif(Npar) - indX <- which(rn>(1-CR[i])) - - # Make sure at least one dimension is updated - if(length(indX) == 0) indX <- sample(1:Npar, 1) - - # First update proposal - x_prop <- X[i,] - - # Calculate gamma based on DEpairs and number of dimensions - # that are updated simulateously. - # To jump between modes gamma is set to 1 every fifth iteration. - if(runif(1)>4/5){ - gamma <- 1 - }else{ - gamma <-2.38/sqrt(settings$DEpairs* length(indX)) - } - - # No snooker update - # Replace with new proposal for indX - x_prop[indX] <- X[i,indX] + (1+e)*gamma*(apply(as.matrix(Z[selectedChains1,indX]),2,sum)- - apply(as.matrix(Z[selectedChains2,indX]),2,sum)) + eps*rnorm(length(indX),0,1) - r_extra <- 0 - - }else{ # Make proposal using snooker update - selectSnooker <- sample((1:M),replace = FALSE, 3) - - z <- Z[selectSnooker[1],] - x_z <- X[i,] - z - D2 <- max(sum(x_z*x_z), 1.0e-300) - projdiff <- sum((Z[selectSnooker[1],] -Z[selectSnooker[2],]) * x_z)/D2 # inner_product of difference with x_z / squared norm x_z - gamma_snooker <- runif(1, min=1.2,max=2.2) - - x_prop <- X[i,] + gamma_snooker * projdiff * x_z - x_z <- x_prop - z - D2prop <- max(sum(x_z*x_z), 1.0e-300) - r_extra <- Npar12 * (log(D2prop) - log(D2)) - - } - - - logfitness_x_prop <- FUN(x_prop, returnAll = T) - - if(!is.na(logfitness_x_prop[1] - logfitness_X[i,1])){ # To catch possible error - if ((logfitness_x_prop[1] - logfitness_X[i,1] + r_extra) > log(runif(1))){ - X[i,] <- x_prop - logfitness_X[i,] <- logfitness_x_prop - } - - } - - } #Npop - - } # not parallel - - - ## Write values in chain - - if((iter > settings$burnin) && (iter %% settings$thin == 0)){ - counter <- counter+1 - pChain[counter,,] <- t(cbind(X,logfitness_X)) - } - - # Update Z - if(counter%%settings$ZupdateFrequency == 0){ - Z[(M+1):(M+Npop),] <- X - M <- M+Npop - - } - - ################################### - - if(iter < settings$adaptation){ - - if(pCRupdate){ ## Calculate delta, this is (unlike the update) done every iteration - ## Calculate delta - - ## Calculate standard deviation of each dimension of X - sdX <- apply(X[,1:Npar,drop=FALSE],2,sd) - - ## Compute Euclidean distance between old and new X values - delta_Norm <- rowSums(((xOld-X[,1:Npar,drop=FALSE])/sdX)^2) - - ## Now delta can be calculated - for (k in 1:settings$nCR){ # Loop over CR values - - # Find updated chains - ind <- which(abs(CR[,k]-(k/nCR)) < 1e-5) - - ## Add normalized squared distance to the current delta - delta[k] <- delta[k]+sum(delta_Norm[ind]) - #delta[k] <- delta[k]+sum(delta_Norm) - - } - - } - - - if(iter%%settings$updateInterval == 0){ - - - if(pCRupdate){ - # Update CR values - tmp <- AdaptpCR(CR, delta, lCR, settings, Npop) - pCR <- tmp$pCR - lCR <- tmp$lCR - } - - ## remove outliers - ## TODO include if(remOutliers = TRUE) ?? - for(out in 1:Npop){ - omega[out] <- mean(pChain[((counter/2):counter),Npar+1, out]) - } - - if(NaN %in% omega){ - outlierChain <- NULL # Prevent possible error - }else{ - # Inter quantile range - IQR <- quantile(omega, probs = c(0.25, 0.75)) - - # Determine outlier chains - outlierChain <- which(omega< IQR[1] - 2*(IQR[2]-IQR[1])) - } - - - # Replace with best chain - if(length(outlierChain) > 0){ - best <- which.max(pChain[counter,Npar+1,]) - pChain[counter,,outlierChain] <- pChain[counter,,best] - - } # Remove outliers - - } - } - - if(iter%%settings$updateInterval == 0){ - counter_update <- 0 # set counter back to zero - CR <- generateCRvalues(pCR, settings, Npop) - - } - ############################### - - - - if(settings$message){ - if( (iter %% settings$consoleUpdates == 0) | (iter == n.iter)) cat("\r","Running DREAM-MCMC, chain ", settings$currentChain, - "iteration" ,iter*Npop,"of",n.iter*Npop,". Current logp ", - logfitness_X[,1], - "Please wait!","\r") - flush.console() - } - - - } # niter - - iterationsOld <- 0 - - pChain <- pChain[1:counter,,] - - if(restart){ # Combine chains - newchains <- array(NA, dim = c((counter+nrow(bayesianSetup$chain[[1]])), (Npar+3), Npop)) - - for(i in 1:Npop){ - for(k in 1:(Npar+3)){ - newchains[,k,i] <- c(bayesianSetup$chain[[i]][,k],pChain[,k,i]) - } - } - pChain <- newchains - } - - - - pChain<- coda::as.mcmc.list(lapply(1:Npop,function(i) coda::as.mcmc(pChain[,1:(Npar+3),i]))) - - - list(chains = pChain, X = as.matrix(X[,1:Npar]), Z = Z, pCR = pCR) - -} +### DREAMzs algorithm + +#' DREAMzs +#' @author Stefan Paul +#' @param bayesianSetup object of class 'bayesianSetup' or 'bayesianOuput'. +#' @param settings list with parameter values +#' @param iterations number of model evaluations +#' @param nCR parameter determining the number of cross-over proposals. If nCR = 1 all parameters are updated jointly. +#' @param updateInterval determines the interval for the pCR (crossover probabilities) update +#' @param gamma kurtosis parameter Bayesian Inference Scheme. +#' @param eps Ergodicity term +#' @param e Ergodicity term +#' @param pCRupdate update of crossover probabilities +#' @param burnin number of iterations treated as burn-in. These iterations are not recorded in the chain. +#' @param thin thinning parameter. Determines the interval in which values are recorded. +#' @param adaptation number or percentage of samples that are used for the adaptation in DREAM (see Details) +#' @param DEpairs number of pairs used to generate proposal +#' @param ZupdateFrequency frequency to update Z matrix +#' @param pSnooker probability of snooker update +#' @param Z starting matrix for Z +#' @param startValue either a matrix containing the start values (see details), an integer to define the number of chains to be run, a function to sample the start values or NUll - in which case the values are sampled from the prior. +#' @param consoleUpdates interval in which the sampling progress is printed to the console +#' @param message logical, determines whether the sampler's progress should be printed +#' @return mcmc.object containing the following elements: chains, X, pCR, Z +#' @references Vrugt, Jasper A., et al. "Accelerating Markov chain Monte Carlo simulation by differential evolution with self-adaptive randomized subspace sampling." International Journal of Nonlinear Sciences and Numerical Simulation 10.3 (2009): 273-290. +#' @references ter Braak C. J. F., and Vrugt J. A. (2008). Differential Evolution Markov Chain with snooker updater and fewer chains. Statistics and Computing http://dx.doi.org/10.1007/s11222-008-9104-9 +#' @details Instead of a bayesianSetup, the function can take the output of a previous run to restart the sampler +#' from the last iteration. Due to the sampler's internal structure you can only use the output +#' of DREAMzs. +#' If you provide a matrix with start values, the number of rows determines the number of chains that will be run. +#' The number of columns must be equivalent to the number of parameters in your bayesianSetup. \cr\cr +#' There are several small differences in the algorithm presented here compared to the original paper by Vrugt et al. (2009). Mainly +#' The algorithm implemented here does not have an automatic stopping criterion. Hence, it will +#' always run the number of iterations specified by the user. Also, convergence is not +#' monitored and left to the user. This can easily be done with coda::gelman.diag(chain). +#' Furthermore, the delayed rejection step proposed in Vrugt et al. (2009) is not implemented here.\cr\cr +#' During the adaptation phase DREAM is running two mechanisms to enhance the sampler's efficiency. +#' First, the distribution of crossover values is tuned to favor large jumps in the parameter space. +#' The crossover probabilities determine how many parameters are updated simultaneously. +#' Second, outlier chains are replaced as they can largely deteriorate the sampler's performance. +#' However, these steps destroy the detailed balance of the chain. Consequently these parts of the chain +#' should be discarded when summarizing posterior moments. This can be done automatically during the +#' sampling process (i.e. burn-in > adaptation) or subsequently by the user. We chose to distinguish between +#' the burn-in and adaptation phase to allow the user more flexibility in the sampler's settings. +#' @example /inst/examples/DEfamilyHelp.R +#' @seealso \code{\link{DREAM}} +#' @export +DREAMzs <- function(bayesianSetup, + settings = list(iterations = 10000, + nCR = 3, + gamma = NULL, + eps = 0, + e = 5e-2, + pCRupdate = FALSE, + updateInterval = 10, + burnin = 0, + thin = 1, + adaptation = 0.2, + parallel = NULL, + + Z = NULL, + ZupdateFrequency = 10, + pSnooker = 0.1, + + + DEpairs = 2, + consoleUpdates = 10, + startValue = NULL, + currentChain = 1, + message = FALSE)) { + + + + if("bayesianOutput" %in% class(bayesianSetup)){ + restart <- TRUE + } else restart <- FALSE + + + if(restart){ + if(is.null(settings)) settings <- bayesianSetup$settings + else settings <- applySettingsDefault(settings = settings, sampler = "DREAMzs") + + settings$adaptation <- 0 # set burnIn to 0 if restart because it has already been + # applied in chain that is restarted and destroys detailed balance. + + }else{ + # If nothing provided use default settings + settings <- applySettingsDefault(settings = settings, sampler = "DREAMzs") + } + + if(!restart){ + setup <- bayesianSetup + } else setup <- bayesianSetup$setup + + setup <- checkBayesianSetup(setup, parallel = settings$parallel) # calling parallel will check if requested parallelization in settings is provided by the BayesianSetup + if(is.null(settings$parallel)) settings$parallel = setup$parallel # checking back - if no parallelization is provided, we use the parallelization in the BayesianSetup. We could also set parallel = F, but I feel it makes more sense to use the Bayesiansetup as default + + if(!restart){ + if(is.null(settings$startValue)){ + parLen = length(bayesianSetup$prior$sampler(1)) + X = bayesianSetup$prior$sampler(3) + } + if(is.function(settings$startValue)){ + X = settings$startValue() + } + if(class(settings$startValue)[1] == "numeric"){ + X = bayesianSetup$prior$sampler(settings$startValue) + } + + if(is.matrix(settings$startValue)) X <- settings$startValue + + if(is.null(settings$Z)){ + parLen = length(bayesianSetup$prior$sampler(1)) + Z = bayesianSetup$prior$sampler(parLen * 10) + } + if(is.function(settings$Z)){ + Z = settings$Z() + } + + if(class(settings$Z)[1] == "numeric"){ + Z = bayesianSetup$prior$sampler(settings$Z) + } + if(is.matrix(settings$Z)) Z <- settings$Z + + }else{ + X <- bayesianSetup$X + Z <- bayesianSetup$Z + if(is.vector(Z)) Z = as.matrix(Z) + } + + + if (! is.matrix(X)) stop("wrong starting values") + if (! is.matrix(Z)) stop("wrong Z values") + + + FUN = setup$posterior$density + + pCRupdate <- settings$pCRupdate + nCR <- settings$nCR + Npar <- ncol(X) + + Npar12 <- (Npar - 1)/2 # factor for Metropolis ratio DE Snooker update + + parallel <- settings$parallel + if(!is.null(parallel)){ + if(is.numeric(parallel) | parallel == "external") parallel <- TRUE + }else parallel <- FALSE + + pCRupdate <- settings$pCRupdate + nCR <- settings$nCR + Npar <- ncol(X) + Npop <- nrow(X) + + + # Set adaptation if percentage is supplied + if(settings$adaptation <1) settings$adaptation <- settings$adaptation*settings$iterations + + # Determine number of iterations and initialize chain + n.iter <- ceiling(settings$iterations/Npop) + if (n.iter < 2) stop ("The total number of iterations must be greater than 3") + settings$burnin <- settings$burnin/Npop + lChain <- ceiling((n.iter - settings$burnin)/settings$thin)+1 + pChain <- array(NA, dim=c(lChain, Npar+3, Npop)) + + + # assign memory for Z and write first values in Z + M <- nrow(Z[complete.cases(Z),,drop = FALSE]) + Zold <- Z[complete.cases(Z),,drop = FALSE] + Z <- matrix(NA, nrow= M + floor((n.iter) /settings$ZupdateFrequency) * Npop, ncol=Npar) + Z[1:M,] <- Zold + + + colnames(pChain) <- c(setup$names, "LP", "LL", "LPr") + + + # Evaluate start values and write them in the chain + logfitness_X <- FUN(X, returnAll = T) + pChain[1,,] <- t(cbind(X,logfitness_X)) + + + # Set counter + counter <- 1 + iseq <- 1:Npop + + + #### gamma, initialization. However gamma is calculated every iteration (see below). + gamma <- 2.38/sqrt(settings$DEpairs*Npar) + + + ## delta initialization + delta <- rep(0, settings$nCR) + + funevals <- 0 + #### pCR update + # Initialization + if(!restart){ + pCR = rep(1/nCR, nCR) + lCR <- rep(0,nCR) + + CR <- matrix(1/nCR, nrow = Npop, ncol = settings$updateInterval) + }else{ + pCR <- bayesianSetup$pCR + CR <- generateCRvalues(pCR, settings, Npop) + + } + + + # helper counter for CR value index + counter_update <- 0 + + ## Omega initialization + omega <- numeric() + + ## eps and e + eps <- settings$eps + e <- settings$e + + + ##################### Start iterations ############################## + for(iter in 2:n.iter){ + + xOld <- X + + + if(parallel == TRUE){ + x_prop <- matrix(NA, nrow= Npop, ncol=Npar) + r_extra <- numeric(Npop) + + for(i in 1:Npop){ + + if(runif(1)>settings$pSnooker){ + selectedChains1 <- sample((1:M), settings$DEpairs, replace = FALSE) + selectedChains2 <- numeric(settings$DEpairs) + + # Avoid that selected chains are identical + for(k in 1:settings$DEpairs){ + selectedChains2[k] <- sample((1:M)[-c(selectedChains1[k],selectedChains2[1:k]) ],1) + } + + # Get indices of parameters that are updated = indX + rn <- runif(Npar) + indX <- which(rn>(1-CR[i])) + + # Make sure at least one dimension is updated + if(length(indX) == 0) indX <- sample(1:Npar, 1) + + # First update proposal + x_prop[i,] <- X[i,] + + # Calculate gamma based on DEpairs and number of dimensions + # that are updated simulateously. + # To jump between modes gamma is set to 1 every fifth iteration. + if(runif(1)>4/5){ + gamma <- 1 + }else{ + gamma <-2.38/sqrt(settings$DEpairs* length(indX)) + } + + # No snooker update + # Replace with new proposal for indX + x_prop[i,indX] <- X[i,indX] + (1+e)*gamma*(apply(as.matrix(Z[selectedChains1,indX]),2,sum)- + apply(as.matrix(Z[selectedChains2,indX]),2,sum)) + eps*rnorm(length(indX),0,1) + r_extra[i] <- 0 + + }else{ # Make proposal using snooker update + selectSnooker <- sample((1:M),replace = FALSE, 3) + + z <- Z[selectSnooker[1],] + x_z <- X[i,] - z + D2 <- max(sum(x_z*x_z), 1.0e-300) + projdiff <- sum((Z[selectSnooker[1],] -Z[selectSnooker[2],]) * x_z)/D2 # inner_product of difference with x_z / squared norm x_z + gamma_snooker <- runif(1, min=1.2,max=2.2) + + x_prop[i,] <- X[i,] + gamma_snooker * projdiff * x_z + x_z <- x_prop[i,] - z + D2prop <- max(sum(x_z*x_z), 1.0e-300) + r_extra[i] <- Npar12 * (log(D2prop) - log(D2)) + + } + } # Npop + + + # run proposals + logfitness_x_prop <- FUN(x_prop, returnAll = T) + + # evaluate acceptance + for(i in 1:Npop){ + if(!is.na(logfitness_x_prop[i,1] - logfitness_X[i,1])){ + if ((logfitness_x_prop[i,1] - logfitness_X[i,1] + r_extra[i]) > log(runif(1))){ + # accept <- accept + 1 + X[i,] <- x_prop[i,] + logfitness_X[i,] <- logfitness_x_prop[i,] + } + } + } + + + }else{ ## If not parallel + for(i in 1:Npop){ + + if(runif(1)>settings$pSnooker){ + selectedChains1 <- sample((1:M), settings$DEpairs, replace = FALSE) + selectedChains2 <- numeric(settings$DEpairs) + + # Avoid that selected chains are identical + for(k in 1:settings$DEpairs){ + selectedChains2[k] <- sample((1:M)[-c(selectedChains1[k],selectedChains2[1:k]) ],1) + } + + # Get indices of parameters that are updated = indX + rn <- runif(Npar) + indX <- which(rn>(1-CR[i])) + + # Make sure at least one dimension is updated + if(length(indX) == 0) indX <- sample(1:Npar, 1) + + # First update proposal + x_prop <- X[i,] + + # Calculate gamma based on DEpairs and number of dimensions + # that are updated simulateously. + # To jump between modes gamma is set to 1 every fifth iteration. + if(runif(1)>4/5){ + gamma <- 1 + }else{ + gamma <-2.38/sqrt(settings$DEpairs* length(indX)) + } + + # No snooker update + # Replace with new proposal for indX + x_prop[indX] <- X[i,indX] + (1+e)*gamma*(apply(as.matrix(Z[selectedChains1,indX]),2,sum)- + apply(as.matrix(Z[selectedChains2,indX]),2,sum)) + eps*rnorm(length(indX),0,1) + r_extra <- 0 + + }else{ # Make proposal using snooker update + selectSnooker <- sample((1:M),replace = FALSE, 3) + + z <- Z[selectSnooker[1],] + x_z <- X[i,] - z + D2 <- max(sum(x_z*x_z), 1.0e-300) + projdiff <- sum((Z[selectSnooker[1],] -Z[selectSnooker[2],]) * x_z)/D2 # inner_product of difference with x_z / squared norm x_z + gamma_snooker <- runif(1, min=1.2,max=2.2) + + x_prop <- X[i,] + gamma_snooker * projdiff * x_z + x_z <- x_prop - z + D2prop <- max(sum(x_z*x_z), 1.0e-300) + r_extra <- Npar12 * (log(D2prop) - log(D2)) + + } + + + logfitness_x_prop <- FUN(x_prop, returnAll = T) + + if(!is.na(logfitness_x_prop[1] - logfitness_X[i,1])){ # To catch possible error + if ((logfitness_x_prop[1] - logfitness_X[i,1] + r_extra) > log(runif(1))){ + X[i,] <- x_prop + logfitness_X[i,] <- logfitness_x_prop + } + + } + + } #Npop + + } # not parallel + + + ## Write values in chain + + if((iter > settings$burnin) && (iter %% settings$thin == 0)){ + counter <- counter+1 + pChain[counter,,] <- t(cbind(X,logfitness_X)) + } + + # Update Z + if(counter%%settings$ZupdateFrequency == 0){ + Z[(M+1):(M+Npop),] <- X + M <- M+Npop + + } + + ################################### + + if(iter < settings$adaptation){ + + if(pCRupdate){ ## Calculate delta, this is (unlike the update) done every iteration + ## Calculate delta + + ## Calculate standard deviation of each dimension of X + sdX <- apply(X[,1:Npar,drop=FALSE],2,sd) + + ## Compute Euclidean distance between old and new X values + delta_Norm <- rowSums(((xOld-X[,1:Npar,drop=FALSE])/sdX)^2) + + ## Now delta can be calculated + for (k in 1:settings$nCR){ # Loop over CR values + + # Find updated chains + ind <- which(abs(CR[,k]-(k/nCR)) < 1e-5) + + ## Add normalized squared distance to the current delta + delta[k] <- delta[k]+sum(delta_Norm[ind]) + #delta[k] <- delta[k]+sum(delta_Norm) + + } + + } + + + if(iter%%settings$updateInterval == 0){ + + + if(pCRupdate){ + # Update CR values + tmp <- AdaptpCR(CR, delta, lCR, settings, Npop) + pCR <- tmp$pCR + lCR <- tmp$lCR + } + + ## remove outliers + ## TODO include if(remOutliers = TRUE) ?? + for(out in 1:Npop){ + omega[out] <- mean(pChain[((counter/2):counter),Npar+1, out]) + } + + if(NaN %in% omega){ + outlierChain <- NULL # Prevent possible error + }else{ + # Inter quantile range + IQR <- quantile(omega, probs = c(0.25, 0.75)) + + # Determine outlier chains + outlierChain <- which(omega< IQR[1] - 2*(IQR[2]-IQR[1])) + } + + + # Replace with best chain + if(length(outlierChain) > 0){ + best <- which.max(pChain[counter,Npar+1,]) + pChain[counter,,outlierChain] <- pChain[counter,,best] + + } # Remove outliers + + } + } + + if(iter%%settings$updateInterval == 0){ + counter_update <- 0 # set counter back to zero + CR <- generateCRvalues(pCR, settings, Npop) + + } + ############################### + + + + if(settings$message){ + if( (iter %% settings$consoleUpdates == 0) | (iter == n.iter)) cat("\r","Running DREAM-MCMC, chain ", settings$currentChain, + "iteration" ,iter*Npop,"of",n.iter*Npop,". Current logp ", + logfitness_X[,1], + "Please wait!","\r") + flush.console() + } + + + } # niter + + iterationsOld <- 0 + + pChain <- pChain[1:counter,,] + + if(restart){ # Combine chains + newchains <- array(NA, dim = c((counter+nrow(bayesianSetup$chain[[1]])), (Npar+3), Npop)) + + for(i in 1:Npop){ + for(k in 1:(Npar+3)){ + newchains[,k,i] <- c(bayesianSetup$chain[[i]][,k],pChain[,k,i]) + } + } + pChain <- newchains + } + + + + pChain<- coda::as.mcmc.list(lapply(1:Npop,function(i) coda::as.mcmc(pChain[,1:(Npar+3),i]))) + + + list(chains = pChain, X = as.matrix(X[,1:Npar]), Z = Z, pCR = pCR) + +} diff --git a/BayesianTools/R/mcmcFrancesco.R b/BayesianTools/R/mcmcFrancesco.R index be874ea..22288a3 100644 --- a/BayesianTools/R/mcmcFrancesco.R +++ b/BayesianTools/R/mcmcFrancesco.R @@ -1,349 +1,349 @@ -#' The Metropolis Algorithm -#' @author Francesco Minunno -#' @description The Metropolis Algorithm (Metropolis et al. 1953) -#' @param startValue vector with the start values for the algorithm. Can be NULL if FUN is of class BayesianSetup. In this case startValues are sampled from the prior. -#' @param iterations iterations to run -#' @param nBI number of burnin -#' @param parmin minimum values for the parameter vector or NULL if FUN is of class BayesianSetup -#' @param parmax maximum values for the parameter vector or NULL if FUN is of class BayesianSetup -#' @param f scaling factor -#' @param FUN function to be sampled from or object of class bayesianSetup -#' @param consoleUpdates interger, determines the frequency with which sampler progress is printed to the console -#' @references Metropolis, Nicholas, et al. "Equation of state calculations by fast computing machines." The journal of chemical physics 21.6 (1953): 1087-1092. -#' @keywords internal -# #' @export -M <- function(startValue = NULL, iterations = 10000, nBI = 0 , parmin = NULL, parmax= NULL, f = 1, FUN, consoleUpdates=1000) { - - - if(inherits(FUN, "BayesianSetup")){ - if(FUN$numPars==1) stop("Sampler cannot be started for 1 parameter") - - if(is.null(startValue)){ - startValue <- FUN$prior$sampler() - } - parmin <- FUN$prior$lower - parmax <- FUN$prior$upper - FUN <- FUN$posterior$density - } - - - pValues = startValue - lChain = iterations - - npar <- length(pValues) - logMAP <- -Inf - pChain <- matrix(NA_real_, nrow = lChain - nBI, ncol = npar+3) - -#******************************************************************************** - -# First call to the model. Calculate likelihood and prior - postL0 <- FUN(pValues, returnAll = T) - accept.prob <- 0 - -#******************************************************************************** - -# Define Variance-covariance matrix (vcovProp) for proposal generation an - - scalProp <- f * 2.4^2/npar # This f is the scaling factor tuned manually - covPar <- scalProp * diag((0.01 * (parmax - parmin))^2) - -#******************************************************************************** -# Build up the chain. Candidates for the parameter values (candidatepValues) -# are assumed to stem from a multivariate normal distribution (mvrnorm) with mean -# at the current state and covariance given by scalProp*covPar. -#----- - - for (j in 1:lChain) { - if (j%%consoleUpdates == 0) print(c(j,postL1[1])) - candidatepValues <- mvtnorm::rmvnorm(1, pValues, covPar) - - # Call the model and calculate the likelihood - postL1 <- FUN(candidatepValues, returnAll = T) - - # Check whether the candidates are accepted. - alpha <- min(exp(postL1[1] - postL0[1]), 1) - accept <- 0 - if (runif(1) < alpha) { - postL0 <- postL1 - pValues <- candidatepValues - accept <- 1 - if (postL0[1] > logMAP) - { - logMAP <- postL0[1] - psetMAP <- pValues - } - - } - if (j > nBI) { - pChain[j-nBI,] <- c(pValues,postL0) - accept.prob <- accept.prob + accept - } - } - accept.prob <- accept.prob/(lChain-nBI) - list(Draws = pChain, accept.prob = accept.prob,psetMAP=psetMAP) -} - - -#' The Adaptive Metropolis Algorithm -#' @author Francesco Minunno -#' @description The Adaptive Metropolis Algorithm (Haario et al. 2001) -#' @param startValue vector with the start values for the algorithm. Can be NULL if FUN is of class BayesianSetup. In this case startValues are sampled from the prior. -#' @param iterations iterations to run -#' @param nBI number of burnin -#' @param parmin minimum values for the parameter vector or NULL if FUN is of class BayesianSetup -#' @param parmax maximum values for the parameter vector or NULL if FUN is of class BayesianSetup -#' @param f scaling factor -#' @param FUN function to be sampled from or object of class bayesianSetup -#' @param eps small number to avoid singularity -#' @references Haario, Heikki, Eero Saksman, and Johanna Tamminen. "An adaptive Metropolis algorithm." Bernoulli (2001): 223-242. -#' @keywords internal -# #' @export -AM <- function(startValue = NULL, iterations = 10000, nBI = 0, parmin = NULL, parmax = NULL, FUN, f = 1, eps = 0) { - - if(inherits(FUN, "BayesianSetup")){ - if(FUN$numPars==1) stop("Sampler cannot be started for 1 parameter") - if(is.null(startValue)){ - startValue <- FUN$prior$sampler() - } - parmin <- FUN$prior$lower - parmax <- FUN$prior$upper - FUN <- FUN$posterior$density - } - - - - pValues = startValue - lChain = iterations - - noAdapt <- 1000 - n.iter <- lChain + noAdapt - npar = length(pValues) - pChain <- matrix(NA_real_, nrow = n.iter - nBI, ncol = npar+3) - - #******************************************************************************** - - # First call to the model. Calculate likelihood and prior - postL0 <- FUN(pValues, returnAll = T) - accept.prob <- 0 - - epsDiag <- eps * diag(npar) - scalProp <- f * (2.4^2/npar) - covPar <- scalProp * diag((0.01*(parmax - parmin))^2) - - for (j in 1:n.iter) { - candidatepValues <- as.vector(mvtnorm::rmvnorm(1, pValues, covPar)) - - postL1 <- FUN(candidatepValues, returnAll = T) - - alpha <- min(exp(postL1[1] - postL0[1]), 1) - accept <- 0 - if (runif(1) < alpha) { - postL0 <- postL1 - pValues <- candidatepValues - accept <- 1 - } - - if (j > nBI) { - pChain[j-nBI,] <- c(pValues, postL0) - } - - if (j == (nBI + noAdapt)) { - avePar <- apply(pChain[1:noAdapt,1:npar], 2, mean) - covPar <- scalProp * (cov(pChain[1:noAdapt,1:npar], pChain[1:noAdapt,1:npar]) + epsDiag) - } - if (j > (nBI + noAdapt)) { - accept.prob <- accept.prob + accept - t <- j - nBI - avePar_new <- as.vector(((t-1) * avePar + pValues) / t) - covPar_new <- ((t-2) * covPar + scalProp * ((t-1) * (avePar %o% avePar) - t * (avePar_new %o% avePar_new) + (pValues %o% pValues)) + epsDiag) / (t-1) - avePar <- avePar_new - covPar <- covPar_new - } - } - accept.prob = accept.prob/(lChain-nBI) - list(Draws = pChain[(noAdapt+1):(n.iter-nBI),], accept.prob = accept.prob) -} - - -#' The Delayed Rejection Algorithm -#' @author Francesco Minunno -#' @description The Delayed Rejection Algorithm (Tierney and Mira, 1999) -#' @param startValue vector with the start values for the algorithm. Can be NULL if FUN is of class BayesianSetup. In this case startValues are sampled from the prior. -#' @param iterations iterations to run -#' @param nBI number of burnin -#' @param parmin minimum values for the parameter vector or NULL if FUN is of class BayesianSetup -#' @param parmax maximum values for the parameter vector or NULL if FUN is of class BayesianSetup -#' @param f1 scaling factor for first proposal -#' @param f2 scaling factor for second proposal -#' @param FUN function to be sampled from or object of class bayesianSetup -#' @references Tierney, Luke, and Antonietta Mira. "Some adaptive Monte Carlo methods for Bayesian inference." Statistics in medicine 18.1718 (1999): 2507-2515. -#' @keywords internal -# #' @export -DR <- function(startValue = NULL, iterations = 10000, nBI=0, parmin = NULL, parmax =NULL, f1 = 1, f2= 0.5, FUN) { - - if(inherits(FUN, "BayesianSetup")){ - if(FUN$numPars==1) stop("Sampler cannot be started for 1 parameter") - if(is.null(startValue)){ - startValue <- FUN$prior$sampler() - } - parmin <- FUN$prior$lower - parmax <- FUN$prior$upper - FUN <- FUN$posterior$density - } - - pValues = startValue - lChain = iterations - - npar = length(pValues) - pChain <- matrix(NA_real_, nrow = lChain - nBI, ncol = npar+3) - - #******************************************************************************** - - # First call to the model. Calculate likelihood and prior - postL0 <- FUN(pValues, returnAll = T) - - #******************************************************************************** - # Define Variance-covariance matrix (vcovProp) for proposal generation an - covPar <- diag((0.01 * (parmax - parmin))^2) - sP <- (2.4^2/npar) * c(f1, f2) - accept.prob <- 0 - - for (j in 1:lChain) { - candidatepValues <- mvtnorm::rmvnorm(1, pValues, sP[1] * covPar) - - # Call the model and calculate the likelihood - postL1 <- FUN(candidatepValues, returnAll = T) - - # Check whether the candidates are accepted. If yes and if burn-in has been completed, - alpha1 <- min(exp(postL1[1]-postL0[1]), 1.0) - accept <- 0 - if (runif(1) < alpha1) { - pValues <- candidatepValues - postL0 = postL1 - accept <- 1 - } else { - candidatepValues2 <- mvtnorm::rmvnorm(1, pValues, sP[2] * covPar) - - # Call the model and calculate the likelihood - postL2 <- FUN(candidatepValues2, returnAll = T) - - # Check whether the candidates are accepted. - - alpha2 <- min(exp(postL1[1]-postL2[1]), 1.0) - temp <- mvtnorm::dmvnorm(candidatepValues, candidatepValues2, sP[1] * covPar) / mvtnorm::dmvnorm(candidatepValues, pValues, sP[1] * covPar) - alpha <- min(exp(postL2[1]-postL0[1]) * temp * ((1.0-alpha2)/(1.0-alpha1)), 1.0) - if(is.nan(alpha)) { - alpha <- -1 - } - if (runif(1) < alpha) { - pValues <- candidatepValues2 - postL0 <- postL2 - accept <- 1 - } - } - if (j > nBI) { - pChain[j-nBI,] <- c(pValues, postL0) - accept.prob <- accept.prob + accept - } - } - accept.prob = accept.prob/(lChain-nBI) - list(Draws = pChain, accept.prob = accept.prob) -} - - -#' The Delayed Rejection Adaptive Metropolis Algorithm -#' @author Francesco Minunno -#' @description The Delayed Rejection Adaptive Metropolis Algorithm (Haario et al. 2001) -#' @param startValue vector with the start values for the algorithm. Can be NULL if FUN is of class BayesianSetup. In this case startValues are sampled from the prior. -#' @param iterations iterations to run -#' @param nBI number of burnin -#' @param parmin minimum values for the parameter vector or NULL if FUN is of class BayesianSetup -#' @param parmax maximum values for the parameter vector or NULL if FUN is of class BayesianSetup -#' @param f scaling factor -#' @param FUN function to be sampled from -#' @param eps small number to avoid singularity or object of class bayesianSetup -#' @references Haario, Heikki, Eero Saksman, and Johanna Tamminen. "An adaptive Metropolis algorithm." Bernoulli (2001): 223-242. -#' @keywords internal -# #' @export -DRAM <- function(startValue = NULL, iterations = 10000, nBI = 0, parmin = NULL, parmax = NULL, FUN, f = 1, eps = 0) { - - if(inherits(FUN, "BayesianSetup")){ - if(FUN$numPars==1) stop("Sampler cannot be started for 1 parameter") - if(is.null(startValue)){ - startValue <- FUN$prior$sampler() - } - parmin <- FUN$prior$lower - parmax <- FUN$prior$upper - FUN <- FUN$posterior$density - } - - pValues = startValue - lChain = iterations - - noAdapt <- 1000 - n.iter <- lChain + noAdapt - npar = length(pValues) - pChain <- matrix(NA_real_, nrow = n.iter - nBI, ncol = npar+3) - - #******************************************************************************** - - # First call to the model. Calculate likelihood and prior - postL0 <- FUN(pValues, returnAll = T) - accept.prob <- 0 - - epsDiag <- eps * diag(npar) - scalProp <- f * (2.4^2/npar) - covPar <- scalProp * diag((0.01*(parmax - parmin))^2) - - for (j in 1:n.iter) { - candidatepValues <- as.vector(mvtnorm::rmvnorm(1, pValues, covPar)) - - postL1 <- FUN(candidatepValues, returnAll = T) - - alpha1 <- min(exp(postL1[1] - postL0[1]), 1) - accept <- 0 - if (runif(1) < alpha1) { - postL0 <- postL1 - pValues <- candidatepValues - accept <- 1 - } else { - candidatepValues2 <- as.vector(mvtnorm::rmvnorm(1, pValues, 0.5 * covPar)) - - # Call the model and calculate the likelihood - postL2 <- FUN(candidatepValues2, returnAll = T) - - # Check whether the candidates are accepted. - - alpha2 <- min(exp(postL1[1]-postL2[1]), 1.0) - temp <- mvtnorm::dmvnorm(candidatepValues, candidatepValues2, covPar) / mvtnorm::dmvnorm(candidatepValues, pValues, covPar) - alpha <- min(exp(postL2[1]-postL0[1]) * temp * ((1.0-alpha2)/(1.0-alpha1)), 1.0) - if(is.nan(alpha)) { - alpha <- -1 - } - if (runif(1) < alpha) { - pValues <- candidatepValues2 - postL0 <- postL2 - accept <- 1 - } - } - - if (j > nBI) { - pChain[j-nBI,] <- c(pValues, postL0) - } - - if (j == (nBI + noAdapt)) { - avePar <- apply(pChain[1:noAdapt,1:npar], 2, mean) - covPar <- scalProp * (cov(pChain[1:noAdapt,1:npar], pChain[1:noAdapt,1:npar]) + epsDiag) - } - if (j > (nBI + noAdapt)) { - accept.prob <- accept.prob + accept - t <- j - nBI - avePar_new <- as.vector(((t-1) * avePar + pValues) / t) - covPar_new <- ((t-2) * covPar + scalProp * ((t-1) * (avePar %o% avePar) - t * (avePar_new %o% avePar_new) + (pValues %o% pValues)) + epsDiag) / (t-1) - avePar <- avePar_new - covPar <- covPar_new - } - } - accept.prob = accept.prob/(lChain-nBI) - list(Draws = pChain[(noAdapt+1):(n.iter-nBI),], accept.prob = accept.prob) -} +#' The Metropolis Algorithm +#' @author Francesco Minunno +#' @description The Metropolis Algorithm (Metropolis et al. 1953) +#' @param startValue vector with the start values for the algorithm. Can be NULL if FUN is of class BayesianSetup. In this case, startValues are sampled from the prior. +#' @param iterations number of iterations to run +#' @param nBI number of burn-in +#' @param parmin minimum values for the parameter vector or NULL if FUN is of class BayesianSetup +#' @param parmax maximum values for the parameter vector or NULL if FUN is of class BayesianSetup +#' @param f scaling factor +#' @param FUN function to be sampled from or object of class bayesianSetup +#' @param consoleUpdates integer, determines the frequency with which sampler progress is printed to the console +#' @references Metropolis, Nicholas, et al. "Equation of state calculations by fast computing machines." The journal of chemical physics 21.6 (1953): 1087-1092. +#' @keywords internal +# #' @export +M <- function(startValue = NULL, iterations = 10000, nBI = 0 , parmin = NULL, parmax= NULL, f = 1, FUN, consoleUpdates=1000) { + + + if(inherits(FUN, "BayesianSetup")){ + if(FUN$numPars==1) stop("Sampler cannot be started for 1 parameter") + + if(is.null(startValue)){ + startValue <- FUN$prior$sampler() + } + parmin <- FUN$prior$lower + parmax <- FUN$prior$upper + FUN <- FUN$posterior$density + } + + + pValues = startValue + lChain = iterations + + npar <- length(pValues) + logMAP <- -Inf + pChain <- matrix(NA_real_, nrow = lChain - nBI, ncol = npar+3) + +#******************************************************************************** + +# First call to the model. Calculate likelihood and prior + postL0 <- FUN(pValues, returnAll = T) + accept.prob <- 0 + +#******************************************************************************** + +# Define Variance-covariance matrix (vcovProp) for proposal generation an + + scalProp <- f * 2.4^2/npar # This f is the scaling factor tuned manually + covPar <- scalProp * diag((0.01 * (parmax - parmin))^2) + +#******************************************************************************** +# Build up the chain. Candidates for the parameter values (candidatepValues) +# are assumed to stem from a multivariate normal distribution (mvrnorm) with mean +# at the current state and covariance given by scalProp*covPar. +#----- + + for (j in 1:lChain) { + if (j%%consoleUpdates == 0) print(c(j,postL1[1])) + candidatepValues <- mvtnorm::rmvnorm(1, pValues, covPar) + + # Call the model and calculate the likelihood + postL1 <- FUN(candidatepValues, returnAll = T) + + # Check whether the candidates are accepted. + alpha <- min(exp(postL1[1] - postL0[1]), 1) + accept <- 0 + if (runif(1) < alpha) { + postL0 <- postL1 + pValues <- candidatepValues + accept <- 1 + if (postL0[1] > logMAP) + { + logMAP <- postL0[1] + psetMAP <- pValues + } + + } + if (j > nBI) { + pChain[j-nBI,] <- c(pValues,postL0) + accept.prob <- accept.prob + accept + } + } + accept.prob <- accept.prob/(lChain-nBI) + list(Draws = pChain, accept.prob = accept.prob,psetMAP=psetMAP) +} + + +#' The Adaptive Metropolis Algorithm +#' @author Francesco Minunno +#' @description The Adaptive Metropolis Algorithm (Haario et al. 2001) +#' @param startValue vector with the start values for the algorithm. Can be NULL if FUN is of class BayesianSetup. In this case startValues are sampled from the prior. +#' @param iterations iterations to run +#' @param nBI number of burnin +#' @param parmin minimum values for the parameter vector or NULL if FUN is of class BayesianSetup +#' @param parmax maximum values for the parameter vector or NULL if FUN is of class BayesianSetup +#' @param f scaling factor +#' @param FUN function to be sampled from or object of class bayesianSetup +#' @param eps small number to avoid singularity +#' @references Haario, Heikki, Eero Saksman, and Johanna Tamminen. "An adaptive Metropolis algorithm." Bernoulli (2001): 223-242. +#' @keywords internal +# #' @export +AM <- function(startValue = NULL, iterations = 10000, nBI = 0, parmin = NULL, parmax = NULL, FUN, f = 1, eps = 0) { + + if(inherits(FUN, "BayesianSetup")){ + if(FUN$numPars==1) stop("Sampler cannot be started for 1 parameter") + if(is.null(startValue)){ + startValue <- FUN$prior$sampler() + } + parmin <- FUN$prior$lower + parmax <- FUN$prior$upper + FUN <- FUN$posterior$density + } + + + + pValues = startValue + lChain = iterations + + noAdapt <- 1000 + n.iter <- lChain + noAdapt + npar = length(pValues) + pChain <- matrix(NA_real_, nrow = n.iter - nBI, ncol = npar+3) + + #******************************************************************************** + + # First call to the model. Calculate likelihood and prior + postL0 <- FUN(pValues, returnAll = T) + accept.prob <- 0 + + epsDiag <- eps * diag(npar) + scalProp <- f * (2.4^2/npar) + covPar <- scalProp * diag((0.01*(parmax - parmin))^2) + + for (j in 1:n.iter) { + candidatepValues <- as.vector(mvtnorm::rmvnorm(1, pValues, covPar)) + + postL1 <- FUN(candidatepValues, returnAll = T) + + alpha <- min(exp(postL1[1] - postL0[1]), 1) + accept <- 0 + if (runif(1) < alpha) { + postL0 <- postL1 + pValues <- candidatepValues + accept <- 1 + } + + if (j > nBI) { + pChain[j-nBI,] <- c(pValues, postL0) + } + + if (j == (nBI + noAdapt)) { + avePar <- apply(pChain[1:noAdapt,1:npar], 2, mean) + covPar <- scalProp * (cov(pChain[1:noAdapt,1:npar], pChain[1:noAdapt,1:npar]) + epsDiag) + } + if (j > (nBI + noAdapt)) { + accept.prob <- accept.prob + accept + t <- j - nBI + avePar_new <- as.vector(((t-1) * avePar + pValues) / t) + covPar_new <- ((t-2) * covPar + scalProp * ((t-1) * (avePar %o% avePar) - t * (avePar_new %o% avePar_new) + (pValues %o% pValues)) + epsDiag) / (t-1) + avePar <- avePar_new + covPar <- covPar_new + } + } + accept.prob = accept.prob/(lChain-nBI) + list(Draws = pChain[(noAdapt+1):(n.iter-nBI),], accept.prob = accept.prob) +} + + +#' The Delayed Rejection Algorithm +#' @author Francesco Minunno +#' @description The Delayed Rejection Algorithm (Tierney and Mira, 1999) +#' @param startValue vector with the start values for the algorithm. Can be NULL if FUN is of class BayesianSetup. In this case startValues are sampled from the prior. +#' @param iterations iterations to run +#' @param nBI number of burnin +#' @param parmin minimum values for the parameter vector or NULL if FUN is of class BayesianSetup +#' @param parmax maximum values for the parameter vector or NULL if FUN is of class BayesianSetup +#' @param f1 scaling factor for first proposal +#' @param f2 scaling factor for second proposal +#' @param FUN function to be sampled from or object of class bayesianSetup +#' @references Tierney, Luke, and Antonietta Mira. "Some adaptive Monte Carlo methods for Bayesian inference." Statistics in medicine 18.1718 (1999): 2507-2515. +#' @keywords internal +# #' @export +DR <- function(startValue = NULL, iterations = 10000, nBI=0, parmin = NULL, parmax =NULL, f1 = 1, f2= 0.5, FUN) { + + if(inherits(FUN, "BayesianSetup")){ + if(FUN$numPars==1) stop("Sampler cannot be started for 1 parameter") + if(is.null(startValue)){ + startValue <- FUN$prior$sampler() + } + parmin <- FUN$prior$lower + parmax <- FUN$prior$upper + FUN <- FUN$posterior$density + } + + pValues = startValue + lChain = iterations + + npar = length(pValues) + pChain <- matrix(NA_real_, nrow = lChain - nBI, ncol = npar+3) + + #******************************************************************************** + + # First call to the model. Calculate likelihood and prior + postL0 <- FUN(pValues, returnAll = T) + + #******************************************************************************** + # Define Variance-covariance matrix (vcovProp) for proposal generation an + covPar <- diag((0.01 * (parmax - parmin))^2) + sP <- (2.4^2/npar) * c(f1, f2) + accept.prob <- 0 + + for (j in 1:lChain) { + candidatepValues <- mvtnorm::rmvnorm(1, pValues, sP[1] * covPar) + + # Call the model and calculate the likelihood + postL1 <- FUN(candidatepValues, returnAll = T) + + # Check whether the candidates are accepted. If yes and if burn-in has been completed, + alpha1 <- min(exp(postL1[1]-postL0[1]), 1.0) + accept <- 0 + if (runif(1) < alpha1) { + pValues <- candidatepValues + postL0 = postL1 + accept <- 1 + } else { + candidatepValues2 <- mvtnorm::rmvnorm(1, pValues, sP[2] * covPar) + + # Call the model and calculate the likelihood + postL2 <- FUN(candidatepValues2, returnAll = T) + + # Check whether the candidates are accepted. + + alpha2 <- min(exp(postL1[1]-postL2[1]), 1.0) + temp <- mvtnorm::dmvnorm(candidatepValues, candidatepValues2, sP[1] * covPar) / mvtnorm::dmvnorm(candidatepValues, pValues, sP[1] * covPar) + alpha <- min(exp(postL2[1]-postL0[1]) * temp * ((1.0-alpha2)/(1.0-alpha1)), 1.0) + if(is.nan(alpha)) { + alpha <- -1 + } + if (runif(1) < alpha) { + pValues <- candidatepValues2 + postL0 <- postL2 + accept <- 1 + } + } + if (j > nBI) { + pChain[j-nBI,] <- c(pValues, postL0) + accept.prob <- accept.prob + accept + } + } + accept.prob = accept.prob/(lChain-nBI) + list(Draws = pChain, accept.prob = accept.prob) +} + + +#' The Delayed Rejection Adaptive Metropolis Algorithm +#' @author Francesco Minunno +#' @description The Delayed Rejection Adaptive Metropolis Algorithm (Haario et al. 2001) +#' @param startValue vector with the start values for the algorithm. Can be NULL if FUN is of class BayesianSetup. In this case startValues are sampled from the prior. +#' @param iterations iterations to run +#' @param nBI number of burnin +#' @param parmin minimum values for the parameter vector or NULL if FUN is of class BayesianSetup +#' @param parmax maximum values for the parameter vector or NULL if FUN is of class BayesianSetup +#' @param f scaling factor +#' @param FUN function to be sampled from +#' @param eps small number to avoid singularity or object of class bayesianSetup +#' @references Haario, Heikki, Eero Saksman, and Johanna Tamminen. "An adaptive Metropolis algorithm." Bernoulli (2001): 223-242. +#' @keywords internal +# #' @export +DRAM <- function(startValue = NULL, iterations = 10000, nBI = 0, parmin = NULL, parmax = NULL, FUN, f = 1, eps = 0) { + + if(inherits(FUN, "BayesianSetup")){ + if(FUN$numPars==1) stop("Sampler cannot be started for 1 parameter") + if(is.null(startValue)){ + startValue <- FUN$prior$sampler() + } + parmin <- FUN$prior$lower + parmax <- FUN$prior$upper + FUN <- FUN$posterior$density + } + + pValues = startValue + lChain = iterations + + noAdapt <- 1000 + n.iter <- lChain + noAdapt + npar = length(pValues) + pChain <- matrix(NA_real_, nrow = n.iter - nBI, ncol = npar+3) + + #******************************************************************************** + + # First call to the model. Calculate likelihood and prior + postL0 <- FUN(pValues, returnAll = T) + accept.prob <- 0 + + epsDiag <- eps * diag(npar) + scalProp <- f * (2.4^2/npar) + covPar <- scalProp * diag((0.01*(parmax - parmin))^2) + + for (j in 1:n.iter) { + candidatepValues <- as.vector(mvtnorm::rmvnorm(1, pValues, covPar)) + + postL1 <- FUN(candidatepValues, returnAll = T) + + alpha1 <- min(exp(postL1[1] - postL0[1]), 1) + accept <- 0 + if (runif(1) < alpha1) { + postL0 <- postL1 + pValues <- candidatepValues + accept <- 1 + } else { + candidatepValues2 <- as.vector(mvtnorm::rmvnorm(1, pValues, 0.5 * covPar)) + + # Call the model and calculate the likelihood + postL2 <- FUN(candidatepValues2, returnAll = T) + + # Check whether the candidates are accepted. + + alpha2 <- min(exp(postL1[1]-postL2[1]), 1.0) + temp <- mvtnorm::dmvnorm(candidatepValues, candidatepValues2, covPar) / mvtnorm::dmvnorm(candidatepValues, pValues, covPar) + alpha <- min(exp(postL2[1]-postL0[1]) * temp * ((1.0-alpha2)/(1.0-alpha1)), 1.0) + if(is.nan(alpha)) { + alpha <- -1 + } + if (runif(1) < alpha) { + pValues <- candidatepValues2 + postL0 <- postL2 + accept <- 1 + } + } + + if (j > nBI) { + pChain[j-nBI,] <- c(pValues, postL0) + } + + if (j == (nBI + noAdapt)) { + avePar <- apply(pChain[1:noAdapt,1:npar], 2, mean) + covPar <- scalProp * (cov(pChain[1:noAdapt,1:npar], pChain[1:noAdapt,1:npar]) + epsDiag) + } + if (j > (nBI + noAdapt)) { + accept.prob <- accept.prob + accept + t <- j - nBI + avePar_new <- as.vector(((t-1) * avePar + pValues) / t) + covPar_new <- ((t-2) * covPar + scalProp * ((t-1) * (avePar %o% avePar) - t * (avePar_new %o% avePar_new) + (pValues %o% pValues)) + epsDiag) / (t-1) + avePar <- avePar_new + covPar <- covPar_new + } + } + accept.prob = accept.prob/(lChain-nBI) + list(Draws = pChain[(noAdapt+1):(n.iter-nBI),], accept.prob = accept.prob) +} diff --git a/BayesianTools/R/mcmcMetropolis.R b/BayesianTools/R/mcmcMetropolis.R index 3a6a4bc..9a6c681 100644 --- a/BayesianTools/R/mcmcMetropolis.R +++ b/BayesianTools/R/mcmcMetropolis.R @@ -1,196 +1,196 @@ -#' Creates a Metropolis-type MCMC with options for covariance adaptatin, delayed rejection, Metropolis-within-Gibbs, and tempering -#' @author Florian Hartig -#' @param bayesianSetup either an object of class bayesianSetup created by \code{\link{createBayesianSetup}} (recommended), or a log target function -#' @param settings a list of settings - possible options follow below -#' @param startValue startValue for the MCMC and optimization (if optimize = T). If not provided, the sampler will attempt to obtain the startValue from the bayesianSetup -#' @param optimize logical, determines whether an optimization for start values and proposal function should be run before starting the sampling -#' @param proposalGenerator optional proposalgenerator object (see \code{\link{createProposalGenerator}}) -#' @param proposalScaling additional scaling parameter for the proposals that controls the different scales of the proposals after delayed rejection (typical, after a rejection, one would want to try a smaller scale). Needs to be as long as DRlevels. Defaults to 0.5^(- 0:(mcmcSampler$settings$DRlevels -1) -#' @param burnin number of iterations treated as burn-in. These iterations are not recorded in the chain. -#' @param thin thinning parameter. Determines the interval in which values are recorded. -#' @param consoleUpdates integer, determines the frequency with which sampler progress is printed to the console -#' @param adapt logical, determines wheter an adaptive algorithm should be implemented. Default is TRUE. -#' @param adaptationInterval integer, determines the interval of the adaption if adapt = TRUE. -#' @param adaptationNotBefore integer, determines the start value for the adaption if adapt = TRUE. -#' @param DRlevels integer, determines the number of levels for a delayed rejection sampler. Default is 1, which means no delayed rejection is used. -#' @param temperingFunction function to implement simulated tempering in the algorithm. The function describes how the acceptance rate will be influenced in the course of the iterations. -#' @param gibbsProbabilities vector that defines the relative probabilities of the number of parameters to be changes simultaniously. -#' @param message logical determines whether the sampler's progress should be printed -#' @details The 'Metropolis' function is the main function for all Metropolis based samplers in this package. To call the derivatives from the basic Metropolis-Hastings MCMC, you can either use the corresponding function (e.g. \code{\link{AM}} for an adaptive Metropolis sampler) or use the parameters to adapt the basic Metropolis-Hastings. The advantage of the latter case is that you can easily combine different properties (e.g. adapive sampling and delayed rejection sampling) without changing the function. -#' @import coda -#' @example /inst/examples/MetropolisHelp.R -#' @export -#' @references Haario, H., E. Saksman, and J. Tamminen (2001). An adaptive metropolis algorithm. Bernoulli , 223-242. -#' @references Haario, Heikki, et al. "DRAM: efficient adaptive MCMC." Statistics and Computing 16.4 (2006): 339-354. -#' @references Hastings, W. K. (1970). Monte carlo sampling methods using markov chains and their applications. Biometrika 57 (1), 97-109. -#' @references Green, Peter J., and Antonietta Mira. "Delayed rejection in reversible jump Metropolis-Hastings." Biometrika (2001): 1035-1053. -#' @references Metropolis, N., A. W. Rosenbluth, M. N. Rosenbluth, A. H. Teller, and E. Teller (1953). Equation of state calculations by fast computing machines. The journal of chemical physics 21 (6), 1087 - 1092. -Metropolis <- function(bayesianSetup, - settings = list(startValue = NULL, - optimize = T, - proposalGenerator = NULL, - consoleUpdates=100, - burnin = 0, - thin = 1, - parallel = NULL, - adapt = T, - adaptationInterval= 500, - adaptationNotBefore = 3000, - DRlevels = 1 , - proposalScaling = NULL, - adaptationDepth = NULL, - temperingFunction = NULL, - gibbsProbabilities = NULL, - message = TRUE - )){ - - ## General setup - this template should be similar for all MCMC algorithms - - setup <- checkBayesianSetup(bayesianSetup, parallel = settings$parallel) # calling parallel will check if requested parallelization in settings is provided by the BayesianSetup - if(is.null(settings$parallel)) settings$parallel = bayesianSetup$parallel # checking back - if no parallelization is provided, we use the parallelization in the BayesianSetup. We could also set parallel = F, but I feel it makes more sense to use the Bayesiansetup as default - - settings = applySettingsDefault(settings, sampler = "Metropolis") - - if(is.null(settings$startValue)){ - settings$startValue = bayesianSetup$prior$sampler() - } - if(is.function(settings$startValue)){ - settings$startValue = settings$startValue() - } - - ## Parameter consistency checks - - if(is.null(settings$adaptationDepth)){ - settings$adaptationDepth = settings$adaptationNotBefore - } - - # Decreasing scaling for DRAM by default - if (is.null(settings$proposalScaling)) settings$proposalScaling = 0.5^(- 0:(settings$DRlevels -1)) - - tmp <- setupStartProposal(proposalGenerator = settings$proposalGenerator, bayesianSetup = bayesianSetup, settings = settings) - settings = tmp$settings - proposalGenerator = tmp$proposalGenerator - - ####### CREATE CHAIN - - chain = array(dim = c(1,bayesianSetup$numPars+3)) - chain[1,1:bayesianSetup$numPars] = settings$startValue - colnames(chain) = c(1:bayesianSetup$numPars, "LP", "LL", "LPr") - chain[1, (bayesianSetup$numPars+1):(bayesianSetup$numPars+3)] = setup$posterior$density(settings$startValue, returnAll = T) - - current = settings$startValue - currentLP = as.numeric(chain[1, (bayesianSetup$numPars+1)]) - - ##### Sampling - - classFields = list( - setup = setup, - settings = settings, - current = current, - currentLP = currentLP, - chain = chain, - proposalGenerator = proposalGenerator, - funEvals = 0, - acceptanceRate = 0 - ) - - class(classFields) <- c("mcmcSampler", "bayesianOutput") - return(classFields) -} - - -#' gets samples while adopting the MCMC proposal generator -#' @author Florian Hartig -#' @param mcmcSampler an mcmcSampler -#' @param iterations iterations -#' @description Function to sample with cobinations of the basic Metropolis-Hastings MCMC algorithm (Metropolis et al., 1953), a variation of the adaptive Metropolis MCMC (Haario et al., 2001), the delayed rejection algorithm (Tierney & Mira, 1999), and the delayed rejection adaptive Metropolis algorithm (DRAM, Haario et al), and the Metropolis within Gibbs -#' @export -#' @keywords internal -sampleMetropolis <- function(mcmcSampler, iterations){ - - burnin <- mcmcSampler$settings$burnin - thin <- mcmcSampler$settings$thin - - CounterFunEvals = mcmcSampler$funEvals - CounterAccept = nrow(mcmcSampler$chain)*mcmcSampler$acceptanceRate - - if (mcmcSampler$settings$DRlevels > 2) stop("DRlevels > 2 currently not implemented") - - # Increase chain - lastvalue = nrow(mcmcSampler$chain) - mcmcSampler$chain = rbind(mcmcSampler$chain, array(dim = c(floor((iterations-burnin)/thin),mcmcSampler$setup$numPars+3))) - - alpha = rep(NA, mcmcSampler$settings$DRlevels) - proposalEval = matrix( nrow = mcmcSampler$settings$DRlevels, ncol = 3) - proposal = matrix( nrow = mcmcSampler$settings$DRlevels, ncol = mcmcSampler$setup$numPars) - - # Initialize counter for chain update - counter <- lastvalue - - for (i in lastvalue:(lastvalue+iterations-1)){ - - accepted = F - - if(is.null(mcmcSampler$settings$temperingFunction)) tempering = 1 else tempering = mcmcSampler$settings$temperingFunction(i) - - if(tempering < 1) warning("Tempering option < 1. This usually doesn't make sense!") - - for (j in 1:mcmcSampler$settings$DRlevels){ - - proposal[j,] = mcmcSampler$proposalGenerator$returnProposal(x = mcmcSampler$current, scale = mcmcSampler$settings$proposalScaling[j]) - proposalEval[j,] <- mcmcSampler$setup$posterior$density(proposal[j,], returnAll = T) - CounterFunEvals <- CounterFunEvals+1 - - # case j = 1 (normal MH-MCMC) - if (j == 1){ - alpha[j] = metropolisRatio(proposalEval[j,1], mcmcSampler$currentLP, tempering) - jumpProbab = alpha[1] - # case j = 2 (first delayed rejection) - } else if (j == 2 & alpha[j-1] > 0 ){ - alpha[j] = metropolisRatio(proposalEval[j,1], proposalEval[j-1,1], tempering) - - temp <- metropolisRatio(mcmcSampler$proposalGenerator$returnDensity(proposal[1,], proposal[2,]), mcmcSampler$proposalGenerator$returnDensity(mcmcSampler$current, proposal[1,])) - - jumpProbab = metropolisRatio(proposalEval[j,1], mcmcSampler$currentLP, tempering) * temp * (1.0-alpha[j]) / (1.0-alpha[j-1]) - } - - if (runif(1) < jumpProbab){ - accepted = T - mcmcSampler$current = proposal[j,] - mcmcSampler$currentLP = proposalEval[j,1] - if((i > (lastvalue+burnin)) && (i %% thin == 0) ){ - counter <- counter+1 - mcmcSampler$chain[counter,] = c(proposal[j,], proposalEval[j,]) - } - break - } - } - if((accepted == F) && (i > (lastvalue+burnin)) && (i %% thin == 0)){ - counter <- counter +1 - mcmcSampler$chain[counter,] = mcmcSampler$chain[counter-1,] - } - if(accepted == T) CounterAccept <- CounterAccept+1 - - # Proposal update - - if(mcmcSampler$settings$adapt == T & i > mcmcSampler$settings$adaptationNotBefore & i %% mcmcSampler$settings$adaptationInterval == 0 ){ - start = max(1, counter - mcmcSampler$settings$adaptationDepth) - mcmcSampler$proposalGenerator = updateProposalGenerator(proposal = mcmcSampler$proposalGenerator, chain = mcmcSampler$chain[start:counter,1:mcmcSampler$setup$numPars], message = F) - } - - # Console update - - if(mcmcSampler$settings$message){ - if( i %% mcmcSampler$settings$consoleUpdates == 0 ) cat("\r","Running Metropolis-MCMC, chain ", - mcmcSampler$settings$currentChain, "iteration" ,i,"of",iterations, - ". Current logp: ", mcmcSampler$chain[counter,mcmcSampler$setup$numPars+1]," Please wait!","\r") - flush.console() - } - } - - # Make sure chain has right size TODO - why is this neccessary - mcmcSampler$chain <- mcmcSampler$chain[1:counter,] - mcmcSampler$funEvals <- CounterFunEvals - mcmcSampler$acceptanceRate <- CounterAccept/CounterFunEvals - return(mcmcSampler) +#' Creates a Metropolis-type MCMC with options for covariance adaptatin, delayed rejection, Metropolis-within-Gibbs, and tempering +#' @author Florian Hartig +#' @param bayesianSetup either an object of class bayesianSetup created by \code{\link{createBayesianSetup}} (recommended), or a log target function +#' @param settings a list of settings - possible options follow +#' @param startValue startValue for the MCMC and optimization (if optimize = T). If not provided, the sampler will attempt to obtain the startValue from the bayesianSetup +#' @param optimize logical, determines whether an optimization for start values and proposal function should be run before starting the sampling +#' @param proposalGenerator optional, proposalgenerator object (see \code{\link{createProposalGenerator}}) +#' @param proposalScaling additional scaling parameter for the proposals that controls the different scales of the proposals after delayed rejection (typical, after a rejection, one would want to try a smaller scale). Needs to be as long as DRlevels. Defaults to 0.5^(- 0:(mcmcSampler$settings$DRlevels -1) +#' @param burnin number of iterations treated as burn-in. These iterations are not recorded in the chain. +#' @param thin thinning parameter. Determines the interval in which values are recorded. +#' @param consoleUpdates integer, determines the frequency with which sampler progress is printed to the console +#' @param adapt logical, determines whether an adaptive algorithm should be implemented. Default is TRUE. +#' @param adaptationInterval integer, determines the interval of the adaption if adapt = TRUE. +#' @param adaptationNotBefore integer, determines the start value for the adaption if adapt = TRUE. +#' @param DRlevels integer, determines the number of levels for a delayed rejection sampler. Default is 1, which means no delayed rejection is used. +#' @param temperingFunction function to implement simulated tempering in the algorithm. The function describes how the acceptance rate will be influenced in the course of the iterations. +#' @param gibbsProbabilities vector that defines the relative probabilities of the number of parameters to be changed simultaneously. +#' @param message logical, determines whether the sampler's progress should be printed +#' @details The 'Metropolis' function is the main function for all Metropolis based samplers in this package. To call the derivatives from the basic Metropolis-Hastings MCMC, you can either use the corresponding function (e.g. \code{\link{AM}} for an adaptive Metropolis sampler) or use the parameters to adapt the basic Metropolis-Hastings. The advantage of the latter case is that you can easily combine different properties (e.g. adapive sampling and delayed rejection sampling) without changing the function. +#' @import coda +#' @example /inst/examples/MetropolisHelp.R +#' @export +#' @references Haario, H., E. Saksman, and J. Tamminen (2001). An adaptive metropolis algorithm. Bernoulli , 223-242. +#' @references Haario, Heikki, et al. "DRAM: efficient adaptive MCMC." Statistics and Computing 16.4 (2006): 339-354. +#' @references Hastings, W. K. (1970). Monte carlo sampling methods using markov chains and their applications. Biometrika 57 (1), 97-109. +#' @references Green, Peter J., and Antonietta Mira. "Delayed rejection in reversible jump Metropolis-Hastings." Biometrika (2001): 1035-1053. +#' @references Metropolis, N., A. W. Rosenbluth, M. N. Rosenbluth, A. H. Teller, and E. Teller (1953). Equation of state calculations by fast computing machines. The journal of chemical physics 21 (6), 1087 - 1092. +Metropolis <- function(bayesianSetup, + settings = list(startValue = NULL, + optimize = T, + proposalGenerator = NULL, + consoleUpdates=100, + burnin = 0, + thin = 1, + parallel = NULL, + adapt = T, + adaptationInterval= 500, + adaptationNotBefore = 3000, + DRlevels = 1 , + proposalScaling = NULL, + adaptationDepth = NULL, + temperingFunction = NULL, + gibbsProbabilities = NULL, + message = TRUE + )){ + + ## General setup - this template should be similar for all MCMC algorithms + + setup <- checkBayesianSetup(bayesianSetup, parallel = settings$parallel) # calling parallel will check if requested parallelization in settings is provided by the BayesianSetup + if(is.null(settings$parallel)) settings$parallel = bayesianSetup$parallel # checking back - if no parallelization is provided, we use the parallelization in the BayesianSetup. We could also set parallel = F, but I feel it makes more sense to use the Bayesiansetup as default + + settings = applySettingsDefault(settings, sampler = "Metropolis") + + if(is.null(settings$startValue)){ + settings$startValue = bayesianSetup$prior$sampler() + } + if(is.function(settings$startValue)){ + settings$startValue = settings$startValue() + } + + ## Parameter consistency checks + + if(is.null(settings$adaptationDepth)){ + settings$adaptationDepth = settings$adaptationNotBefore + } + + # Decreasing scaling for DRAM by default + if (is.null(settings$proposalScaling)) settings$proposalScaling = 0.5^(- 0:(settings$DRlevels -1)) + + tmp <- setupStartProposal(proposalGenerator = settings$proposalGenerator, bayesianSetup = bayesianSetup, settings = settings) + settings = tmp$settings + proposalGenerator = tmp$proposalGenerator + + ####### CREATE CHAIN + + chain = array(dim = c(1,bayesianSetup$numPars+3)) + chain[1,1:bayesianSetup$numPars] = settings$startValue + colnames(chain) = c(1:bayesianSetup$numPars, "LP", "LL", "LPr") + chain[1, (bayesianSetup$numPars+1):(bayesianSetup$numPars+3)] = setup$posterior$density(settings$startValue, returnAll = T) + + current = settings$startValue + currentLP = as.numeric(chain[1, (bayesianSetup$numPars+1)]) + + ##### Sampling + + classFields = list( + setup = setup, + settings = settings, + current = current, + currentLP = currentLP, + chain = chain, + proposalGenerator = proposalGenerator, + funEvals = 0, + acceptanceRate = 0 + ) + + class(classFields) <- c("mcmcSampler", "bayesianOutput") + return(classFields) +} + + +#' gets samples while adopting the MCMC proposal generator +#' @author Florian Hartig +#' @param mcmcSampler an mcmcSampler +#' @param iterations iterations +#' @description Function to sample with cobinations of the basic Metropolis-Hastings MCMC algorithm (Metropolis et al., 1953), a variation of the adaptive Metropolis MCMC (Haario et al., 2001), the delayed rejection algorithm (Tierney & Mira, 1999), and the delayed rejection adaptive Metropolis algorithm (DRAM, Haario et al), and the Metropolis within Gibbs +#' @export +#' @keywords internal +sampleMetropolis <- function(mcmcSampler, iterations){ + + burnin <- mcmcSampler$settings$burnin + thin <- mcmcSampler$settings$thin + + CounterFunEvals = mcmcSampler$funEvals + CounterAccept = nrow(mcmcSampler$chain)*mcmcSampler$acceptanceRate + + if (mcmcSampler$settings$DRlevels > 2) stop("DRlevels > 2 currently not implemented") + + # Increase chain + lastvalue = nrow(mcmcSampler$chain) + mcmcSampler$chain = rbind(mcmcSampler$chain, array(dim = c(floor((iterations-burnin)/thin),mcmcSampler$setup$numPars+3))) + + alpha = rep(NA, mcmcSampler$settings$DRlevels) + proposalEval = matrix( nrow = mcmcSampler$settings$DRlevels, ncol = 3) + proposal = matrix( nrow = mcmcSampler$settings$DRlevels, ncol = mcmcSampler$setup$numPars) + + # Initialize counter for chain update + counter <- lastvalue + + for (i in lastvalue:(lastvalue+iterations-1)){ + + accepted = F + + if(is.null(mcmcSampler$settings$temperingFunction)) tempering = 1 else tempering = mcmcSampler$settings$temperingFunction(i) + + if(tempering < 1) warning("Tempering option < 1. This usually doesn't make sense!") + + for (j in 1:mcmcSampler$settings$DRlevels){ + + proposal[j,] = mcmcSampler$proposalGenerator$returnProposal(x = mcmcSampler$current, scale = mcmcSampler$settings$proposalScaling[j]) + proposalEval[j,] <- mcmcSampler$setup$posterior$density(proposal[j,], returnAll = T) + CounterFunEvals <- CounterFunEvals+1 + + # case j = 1 (normal MH-MCMC) + if (j == 1){ + alpha[j] = metropolisRatio(proposalEval[j,1], mcmcSampler$currentLP, tempering) + jumpProbab = alpha[1] + # case j = 2 (first delayed rejection) + } else if (j == 2 & alpha[j-1] > 0 ){ + alpha[j] = metropolisRatio(proposalEval[j,1], proposalEval[j-1,1], tempering) + + temp <- metropolisRatio(mcmcSampler$proposalGenerator$returnDensity(proposal[1,], proposal[2,]), mcmcSampler$proposalGenerator$returnDensity(mcmcSampler$current, proposal[1,])) + + jumpProbab = metropolisRatio(proposalEval[j,1], mcmcSampler$currentLP, tempering) * temp * (1.0-alpha[j]) / (1.0-alpha[j-1]) + } + + if (runif(1) < jumpProbab){ + accepted = T + mcmcSampler$current = proposal[j,] + mcmcSampler$currentLP = proposalEval[j,1] + if((i > (lastvalue+burnin)) && (i %% thin == 0) ){ + counter <- counter+1 + mcmcSampler$chain[counter,] = c(proposal[j,], proposalEval[j,]) + } + break + } + } + if((accepted == F) && (i > (lastvalue+burnin)) && (i %% thin == 0)){ + counter <- counter +1 + mcmcSampler$chain[counter,] = mcmcSampler$chain[counter-1,] + } + if(accepted == T) CounterAccept <- CounterAccept+1 + + # Proposal update + + if(mcmcSampler$settings$adapt == T & i > mcmcSampler$settings$adaptationNotBefore & i %% mcmcSampler$settings$adaptationInterval == 0 ){ + start = max(1, counter - mcmcSampler$settings$adaptationDepth) + mcmcSampler$proposalGenerator = updateProposalGenerator(proposal = mcmcSampler$proposalGenerator, chain = mcmcSampler$chain[start:counter,1:mcmcSampler$setup$numPars], message = F) + } + + # Console update + + if(mcmcSampler$settings$message){ + if( i %% mcmcSampler$settings$consoleUpdates == 0 ) cat("\r","Running Metropolis-MCMC, chain ", + mcmcSampler$settings$currentChain, "iteration" ,i,"of",iterations, + ". Current logp: ", mcmcSampler$chain[counter,mcmcSampler$setup$numPars+1]," Please wait!","\r") + flush.console() + } + } + + # Make sure chain has right size TODO - why is this neccessary + mcmcSampler$chain <- mcmcSampler$chain[1:counter,] + mcmcSampler$funEvals <- CounterFunEvals + mcmcSampler$acceptanceRate <- CounterAccept/CounterFunEvals + return(mcmcSampler) } \ No newline at end of file diff --git a/BayesianTools/R/mcmcMultipleChains.R b/BayesianTools/R/mcmcMultipleChains.R index 84fa49c..4d0cd7d 100644 --- a/BayesianTools/R/mcmcMultipleChains.R +++ b/BayesianTools/R/mcmcMultipleChains.R @@ -1,39 +1,39 @@ -#' Run multiple chains -#' @param bayesianSetup Object of class "BayesianSetup" -#' @param settings list with settings for sampler -#' @param sampler character, either "Metropolis" or "DE" -#' @return list containing the single runs ($sampler) and the chains in a coda::mcmc.list ($mcmc.list) -#' @keywords internal -mcmcMultipleChains <- function(bayesianSetup, settings, sampler) { - # Get number of chains - nrChains <- settings$nrChains - - # Set settings$nrChains to one to avoid infinite loop - settings$nrChains <- 1 - - # Initialize output - out <- list() - out$sampler <- list() - - # Run sampler - for (i in 1:nrChains) { - out$sampler[[i]] <- - runMCMC(bayesianSetup, sampler = sampler, settings = settings) - } - - - # Make coda::mcmc.list object - for (i in 1:nrChains) { - txtemp <- paste("coda::mcmc(out$sampler[[", i, "]]$chain)", sep = "") - if (i == 1) - tx = txtemp - else - tx <- paste(tx, txtemp, sep = ", ") - } - - tx <- paste("coda::mcmc.list(", tx, ")", sep = "") - out$mcmc.list <- eval(parse(text = tx)) - - - return(out) -} +#' Run multiple chains +#' @param bayesianSetup object of class "BayesianSetup" +#' @param settings list with settings for sampler +#' @param sampler character, either "Metropolis" or "DE" +#' @return list containing the single runs ($sampler) and the chains in a coda::mcmc.list ($mcmc.list) +#' @keywords internal +mcmcMultipleChains <- function(bayesianSetup, settings, sampler) { + # Get number of chains + nrChains <- settings$nrChains + + # Set settings$nrChains to one to avoid infinite loop + settings$nrChains <- 1 + + # Initialize output + out <- list() + out$sampler <- list() + + # Run sampler + for (i in 1:nrChains) { + out$sampler[[i]] <- + runMCMC(bayesianSetup, sampler = sampler, settings = settings) + } + + + # Make coda::mcmc.list object + for (i in 1:nrChains) { + txtemp <- paste("coda::mcmc(out$sampler[[", i, "]]$chain)", sep = "") + if (i == 1) + tx = txtemp + else + tx <- paste(tx, txtemp, sep = ", ") + } + + tx <- paste("coda::mcmc.list(", tx, ")", sep = "") + out$mcmc.list <- eval(parse(text = tx)) + + + return(out) +} diff --git a/BayesianTools/R/mcmcRun.R b/BayesianTools/R/mcmcRun.R index 9ea4ca6..c653615 100644 --- a/BayesianTools/R/mcmcRun.R +++ b/BayesianTools/R/mcmcRun.R @@ -1,523 +1,523 @@ -#' Main wrapper function to start MCMCs, particle MCMCs and SMCs -#' @author Florian Hartig -#' @param bayesianSetup either a BayesianSetup (see \code{\link{createBayesianSetup}}), a function, or a BayesianOutput created by runMCMC. The latter allows to continue a previous MCMC run. See details for how to restart a sampler. -#' @param sampler sampling algorithm to be run. Default is DEzs. Options are "Metropolis", "AM", "DR", "DRAM", "DE", "DEzs", "DREAM", "DREAMzs", "SMC". For details see the help of the individual functions. -#' @param settings list with settings for each sampler. If a setting is not provided, defaults (see \code{\link{applySettingsDefault}}) will be used. -#' @details The runMCMC function can be started with either one of -#' -#' 1. an object of class BayesianSetup with prior and likelihood function (created with \code{\link{createBayesianSetup}}). check if appropriate parallelization options are used - many samplers can make use of parallelization if this option is activated when the class is created. -#' 2. a log posterior or other target function, -#' 3. an object of class BayesianOutput created by runMCMC. The latter allows to continue a previous MCMC run. -#' -#' Settings for the sampler are provides as a list. You can see the default values by running \code{\link{applySettingsDefault}} with the respective sampler name. The following settings can be used for all MCMCs: -#' -#' * startValue (no default) start values for the MCMC. Note that DE family samplers require a matrix of start values. If startvalues are not provided, they are sampled from the prior. -#' * iterations (10000) the MCMC iterations -#' * burnin (0) burnin -#' * thin (1) thinning while sampling -#' * consoleUpdates (100) update frequency for console updates -#' * parallel (NULL) whether parallelization is to be used -#' * message (TRUE) if progress messages are to be printed -#' * nrChains (1) the number of independent MCMC chains to be run. Note that this is not controlling the internal number of chains in population MCMCs such as DE, so if you run nrChains = 3 with a DEzs startValue that is a 4xparameter matrix (= 4 internal chains), you will run independent DEzs runs with 4 internal chains each. -#' -#' The MCMC samplers will have a number of additional settings, which are described in the Vignette (run vignette("BayesianTools", package="BayesianTools") and in the help of the samplers. See \code{\link{Metropolis}} for Metropolis based samplers, \code{\link{DE}} and \code{\link{DEzs}} for standard differential evolution samplers, \code{\link{DREAM}} and \code{\link{DREAMzs}} for DREAM sampler, \code{\link{Twalk}} for the Twalk sampler, and \code{\link{smcSampler}} for rejection and Sequential Monte Carlo sampling. Note that the samplers "AM", "DR", and "DRAM" are special cases of the "Metropolis" sampler and are shortcuts for predefined settings ("AM": adapt=TRUE; "DR": DRlevels=2; "DRAM": adapt=True, DRlevels=2). -#' -#' Note that even if you specify parallel = T, this will only turn on internal parallelization of the samplers. The independent samplers controlled by nrChains are not evaluated in parallel, so if time is an issue it will be better to run the MCMCs individually and then combine them via \code{\link{createMcmcSamplerList}} into one joint object. -#' -#' Note that DE and DREAM variants as well as SMC and T-walk require a population to start, which should be provided as a matrix. Default (NULL) sets the population size for DE to 3 x dimensions of parameters, for DREAM to 2 x dimensions of parameters and for DEzs and DREAMzs to three, sampled from the prior. Note also that the zs variants of DE and DREAM require two populations, the current population and the z matrix (a kind of memory) - if you want to set both, provide a list with startvalue$X and startvalue$Z. -#' -#' setting startValue for sampling with nrChains > 1 : if you want to provide different start values for the different chains, provide them as a list -#' -#' @return The function returns an object of class mcmcSampler (if one chain is run) or mcmcSamplerList. Both have the superclass bayesianOutput. It is possible to extract the samples as a coda object or matrix with \code{\link{getSample}}. -#' It is also possible to summarize the posterior as a new prior via \code{\link{createPriorDensity}}. -#' @example /inst/examples/mcmcRun.R -#' @seealso \code{\link{createBayesianSetup}} -#' @export -runMCMC <- function(bayesianSetup , sampler = "DEzs", settings = NULL){ - - options(warn = 0) - - ptm <- proc.time() - - ####### RESTART ########## - - if("bayesianOutput" %in% class(bayesianSetup)){ - - # TODO - the next statements should have assertions in case someone overwrites the existing setting or similar - - previousMcmcSampler <- bayesianSetup - - - # Catch the settings in case of nrChains > 1 - if(!("mcmcSamplerList" %in% class(previousMcmcSampler) | "smcSamplerList" %in% class(previousMcmcSampler) )){ - if(is.null(settings)) settings <- previousMcmcSampler$settings - setup <- previousMcmcSampler$setup - sampler <- previousMcmcSampler$settings$sampler - previousSettings <- previousMcmcSampler$settings - } else{ - if(is.null(settings)) settings <- previousMcmcSampler[[1]]$settings - settings$nrChains <- length(previousMcmcSampler) - setup <- previousMcmcSampler[[1]]$setup - sampler <- previousMcmcSampler[[1]]$settings$sampler - previousSettings <- previousMcmcSampler[[1]]$settings - } - - # Set settings$sampler (only needed if new settings are supplied) - settings$sampler <- sampler - - # overwrite new settings - for(name in names(settings)) previousSettings[[name]] <- settings[[name]] - - settings <- previousSettings - - # Check if previous settings will be new default - - previousMcmcSampler$settings <- applySettingsDefault(settings = settings, sampler = settings$sampler, check = TRUE) - - restart <- TRUE - - - ## NOT RESTART STARTS HERE ################### - - }else if(inherits(bayesianSetup, "BayesianSetup")){ - restart <- FALSE - - if(is.null(settings$parallel)) settings$parallel <- bayesianSetup$parallel - if(is.numeric(settings$parallel)) settings$parallel <- TRUE - - setup <- checkBayesianSetup(bayesianSetup, parallel = settings$parallel) - settings <- applySettingsDefault(settings = settings, sampler = sampler, check = TRUE) - } else stop("runMCMC requires a class of type BayesianOutput or BayesianSetup") - - ###### END RESTART ############## - - - # TODO - the following statement should be removed once all further functions access settings$sampler instead of sampler - # At the moment only the same sampler can be used to restart sampling. - sampler = settings$sampler - - #### Assertions - if(!restart && setup$numPars == 1) if(!getPossibleSamplerTypes()$univariate[which(getPossibleSamplerTypes()$BTname == settings$sampler)]) stop("This sampler can not be applied to a univariate distribution") - - if(restart == T) if(!getPossibleSamplerTypes()$restartable[which(getPossibleSamplerTypes()$BTname == settings$sampler)]) stop("This sampler can not be restarted") - - ########### Recursive call in case multiple chains are to be run - if(settings$nrChains >1){ - - # Initialize output list - out<- list() - - # Run several samplers - for(i in 1:settings$nrChains){ - - settingsTemp <- settings - settingsTemp$nrChains <- 1 # avoid infinite loop - settingsTemp$currentChain <- i - - if(restart){ - out[[i]] <- runMCMC(bayesianSetup = previousMcmcSampler[[i]], settings = settingsTemp) - }else{ - if(is.list(settings$startValue)) settingsTemp$startValue = settings$startValue[[i]] - out[[i]] <- runMCMC(bayesianSetup = setup, sampler = settings$sampler, settings = settingsTemp) - } - } - if(settings$sampler == "SMC") class(out) = c("smcSamplerList", "bayesianOutput") - else class(out) = c("mcmcSamplerList", "bayesianOutput") - return(out) - - ######### END RECURSIVE CALL - # MAIN RUN FUNCTION HERE - }else{ - - # check start values - setup$prior$checkStart(settings$startValue) - - - if (sampler == "Metropolis" || sampler == "AM" || sampler == "DR" || sampler == "DRAM"){ - if(restart == FALSE){ - mcmcSampler <- Metropolis(bayesianSetup = setup, settings = settings) - mcmcSampler <- sampleMetropolis(mcmcSampler = mcmcSampler, iterations = settings$iterations) - } else { - mcmcSampler <- sampleMetropolis(mcmcSampler = previousMcmcSampler, iterations = settings$iterations) - } - } - - - - ############## Differential Evolution ##################### - if (sampler == "DE"){ - - if(restart == F) out <- DE(bayesianSetup = setup, settings = settings) - else out <- DE(bayesianSetup = previousMcmcSampler, settings = settings) - - #out <- DE(bayesianSetup = bayesianSetup, settings = list(startValue = NULL, iterations = settings$iterations, burnin = settings$burnin, eps = settings$eps, parallel = settings$parallel, consoleUpdates = settings$consoleUpdates, - # blockUpdate = settings$blockUpdate, currentChain = settings$currentChain)) - - mcmcSampler = list( - setup = setup, - settings = settings, - chain = out$Draws, - X = out$X, - sampler = "DE" - ) - } - - ############## Differential Evolution with snooker update - if (sampler == "DEzs"){ - # check z matrix - if(!is.null(settings$Z)) setup$prior$checkStart(settings$Z,z = TRUE) - - if(restart == F) out <- DEzs(bayesianSetup = setup, settings = settings) - else out <- DEzs(bayesianSetup = previousMcmcSampler, settings = settings) - - mcmcSampler = list( - setup = setup, - settings = settings, - chain = out$Draws, - X = out$X, - Z = out$Z, - sampler = "DEzs" - ) - } - - ############## DREAM - if (sampler == "DREAM"){ - - if(restart == F) out <- DREAM(bayesianSetup = setup, settings = settings) - else out <- DREAM(bayesianSetup = previousMcmcSampler, settings = settings) - - mcmcSampler = list( - setup = setup, - settings = settings, - chain = out$chains, - pCR = out$pCR, - sampler = "DREAM", - lCR = out$lCR, - X = out$X, - delta = out$delta - ) - } - - ############## DREAMzs - if (sampler == "DREAMzs"){ - # check z matrix - if(!is.null(settings$Z)) setup$prior$checkStart(settings$Z,z = TRUE) - - if(restart == F) out <- DREAMzs(bayesianSetup = setup, settings = settings) - else out <- DREAMzs(bayesianSetup = previousMcmcSampler, settings = settings) - - mcmcSampler = list( - setup = setup, - settings = settings, - chain = out$chains, - pCR = out$pCR, - sampler = "DREAMzs", - JumpRates = out$JumpRates, - X = out$X, - Z = out$Z - ) - - } - - if(sampler == "Twalk"){ - warning("At the moment using T-walk is discouraged: numeric instability") - if(!restart){ - if(is.null(settings$startValue)){ - settings$startValue = bayesianSetup$prior$sampler(2) - } - mcmcSampler <- Twalk(bayesianSetup = setup, settings = settings) - }else{ - mcmcSampler <- Twalk(bayesianSetup = previousMcmcSampler, settings = settings) - } - mcmcSampler$setup <- setup - mcmcSampler$sampler <- "Twalk" - } - - - if ((sampler != "SMC")){ - class(mcmcSampler) <- c("mcmcSampler", "bayesianOutput") - } - - ############# SMC ##################### - - if (sampler == "SMC"){ - - mcmcSampler <- smcSampler(bayesianSetup = bayesianSetup, initialParticles = settings$initialParticles, iterations = settings$iterations, resampling = settings$resampling, resamplingSteps = settings$resamplingSteps, proposal = settings$proposal, adaptive = settings$adaptive, proposalScale = settings$proposalScale ) - mcmcSampler$settings = settings - } - - mcmcSampler$settings$runtime = mcmcSampler$settings$runtime + proc.time() - ptm - if(is.null(settings$message) || settings$message == TRUE){ - message("runMCMC terminated after ", mcmcSampler$settings$runtime[3], "seconds") - } - return(mcmcSampler) - } -} - - -#bayesianSetup = bayesianSetup, initialParticles = settings$initialParticles, iterations = settings$iterations, resampling = settings$resampling, resamplingSteps = settings$resamplingSteps, proposal = settings$proposal, adaptive = settings$adaptive, parallel = settings$parallel - - -#' Provides the default settings for the different samplers in runMCMC -#' @author Florian Hartig -#' @param settings optional list with parameters that will be used instead of the defaults -#' @param sampler one of the samplers in \code{\link{runMCMC}} -#' @param check logical determines whether parameters should be checked for consistency -#' @details see \code{\link{runMCMC}} -#' @export -applySettingsDefault<-function(settings=NULL, sampler = "DEzs", check = FALSE){ - - if(is.null(settings)) settings = list() - - if(!is.null(sampler)){ - if(!is.null(settings$sampler)) { - # TODO: this is a bit hacky. The best would prabably be to change the Metropolis function to allow AM, DR and DRAM - # arguments and call applySettingsDefault for those - if (settings$sampler %in% c("AM", "DR", "DRAM") && sampler == "Metropolis") { - sampler <- settings$sampler - } - if(settings$sampler != sampler) { - warning("sampler argument overwrites an existing settings$sampler in applySettingsDefault. This only makes sense if one wants to take over settings from one sampler to another") - } - } - settings$sampler = sampler - } - - if(!settings$sampler %in% getPossibleSamplerTypes()$BTname) stop("trying to set values for a sampler that does not exist") - - - mcmcDefaults <- list(startValue = NULL, - iterations = 10000, - burnin = 0, - thin = 1, - consoleUpdates = 100, - parallel = NULL, - message = TRUE) - - #### Metropolis #### - if(settings$sampler %in% c("AM", "DR", "DRAM", "Metropolis")){ - - defaultSettings <- c(mcmcDefaults, list(optimize = T, - proposalGenerator = NULL, - adapt = F, - adaptationInterval = 500, - adaptationNotBefore = 3000, - DRlevels = 1 , - proposalScaling = NULL, - adaptationDepth = NULL, - temperingFunction = NULL, - proposalGenerator = NULL, - gibbsProbabilities = NULL)) - - if (settings$sampler %in% c("AM", "DRAM")) defaultSettings$adapt <- TRUE - if (settings$sampler %in% c("DR", "DRAM")) defaultSettings$DRlevels <- 2 - } - - #### DE Family #### - if(settings$sampler %in% c("DE", "DEzs")){ - defaultSettings <- c(mcmcDefaults, list(eps = 0, - currentChain = 1, - blockUpdate = list("none", - k = NULL, - h = NULL, - pSel = NULL, - pGroup = NULL, - groupStart = 1000, - groupIntervall = 1000) - )) - - if (settings$sampler == "DE"){ - defaultSettings$f <- -2.38 # TODO CHECK - - } - - if (settings$sampler == "DEzs"){ - defaultSettings$f <- 2.38 - defaultSettings <- c(defaultSettings, list(Z = NULL, - zUpdateFrequency = 1, - pSnooker = 0.1, - pGamma1 = 0.1, - eps.mult =0.2, - eps.add = 0)) - } - - } - - #### DREAM Family #### - - if(settings$sampler %in% c("DREAM", "DREAMzs")){ - defaultSettings <- c(mcmcDefaults, list(nCR = 3, - currentChain = 1, - gamma = NULL, - eps = 0, - e = 5e-2, - DEpairs = 2, - adaptation = 0.2, - updateInterval = 10)) - - if (settings$sampler == "DREAM"){ - defaultSettings$pCRupdate <- TRUE - } - - if (settings$sampler == "DREAMzs"){ - defaultSettings = c(defaultSettings, list( - pCRupdate = FALSE, - Z = NULL, - ZupdateFrequency = 10, - pSnooker = 0.1 - )) - } - } - - #### Twalk #### - - if (settings$sampler == "Twalk"){ - defaultSettings = c(mcmcDefaults, - list(at = 6, - aw = 1.5, - pn1 = NULL, - Ptrav = 0.4918, - Pwalk = NULL, - Pblow = NULL)) - defaultSettings$parallel = NULL - } - - #### SMC #### - - if (settings$sampler == "SMC"){ - defaultSettings = list(iterations = 10, - resampling = T, - resamplingSteps = 2, - proposal = NULL, - adaptive = T, - proposalScale = 0.5, - initialParticles = 1000 - ) - } - - - - ## CHECK DEFAULTS - - if(check){ - nam = c(names(defaultSettings), "sampler", "nrChains", - "runtime", "sessionInfo", "parallel") - - ind <- which((names(settings) %in% nam == FALSE)) - - nam_n <- names(settings)[ind] - for(i in 1:length(nam_n)) nam_n[i] <- paste(nam_n[i], " ") - - if(length(ind) > 0){ - message("Parameter(s) ", nam_n , " not used in ", settings$sampler, "\n") - } - } - - defaultSettings$nrChains = 1 - defaultSettings$runtime = 0 - defaultSettings$sessionInfo = utils::sessionInfo() - - nam = names(defaultSettings) - - for (i in 1:length(defaultSettings)){ - if(! nam[i] %in% names(settings)){ - addition = list( defaultSettings[[i]]) - names(addition) = nam[i] - settings = c(settings, addition) - } - } - - - if (! is.null(settings$burnin)){ - if (settings$burnin > settings$iterations) stop("BayesianToools::applySettingsDefault - setting burnin cannnot be larger than setting iteration") - if (! is.null(settings$adaptationNotBefore)){ - if (settings$burnin >= settings$adaptationNotBefore) stop("BayesianToools::applySettingsDefault - setting burnin cannnot be larger than setting adaptationNotBefore") - } - } - - return(settings) -} - - -#' Help function to find starvalues and proposalGenerator settings -#' @author Florian Hartig -#' @param proposalGenerator proposal generator -#' @param bayesianSetup either an object of class bayesianSetup created by \code{\link{createBayesianSetup}} (recommended), or a log target function -#' @param settings list with settings -#' @keywords internal -setupStartProposal <- function(proposalGenerator = NULL, bayesianSetup, settings){ - - # Proposal - range = (bayesianSetup$prior$upper - bayesianSetup$prior$lower) / 50 - - if(is.null(settings$startValue)) settings$startValue = (bayesianSetup$prior$upper + bayesianSetup$prior$lower) / 2 - - if (length(range) != bayesianSetup$numPars) range = rep(1,bayesianSetup$numPars) - - if(is.null(proposalGenerator)){ - proposalGenerator = createProposalGenerator(range, gibbsProbabilities = settings$gibbsProbabilities) - } - - ####### OPTIMIZATION - - if (settings$optimize == T){ - if(is.null(settings$message) || settings$message == TRUE){ - cat("BT runMCMC: trying to find optimal start and covariance values", "\b") - } - - target <- function(x){ - out <- bayesianSetup$posterior$density(x) - if (out == -Inf) out = -1e20 # rnorm(1, mean = -1e20, sd = 1e-20) - return(out) - } - - try( { - if(bayesianSetup$numPars > 1) optresul <- optim(par=settings$startValue,fn=target, method="Nelder-Mead", hessian=F, control=list("fnscale"=-1, "maxit" = 10000)) - else optresul <- optim(par=settings$startValue,fn=target, method="Brent", hessian=F, control=list("fnscale"=-1, "maxit" = 10000), lower = bayesianSetup$prior$lower, upper = bayesianSetup$prior$upper) - settings$startValue = optresul$par - hessian = numDeriv::hessian(target, optresul$par) - - - proposalGenerator$covariance = as.matrix(Matrix::nearPD(MASS::ginv(-hessian))$mat) - #proposalGenerator$covariance = MASS::ginv(-optresul$hessian) - - # Create objects for startValues and covariance to add space between values - startV <-covV <- character() - - for(i in 1:length(settings$startValue)){ - startV[i] <- paste(settings$startValue[i], "") - } - for(i in 1:length( proposalGenerator$covariance)){ - covV[i] <- paste( proposalGenerator$covariance[i], "") - } - - if(is.null(settings$message) || settings$message == TRUE){ - message("BT runMCMC: Optimization finished, setting startValues to " , - startV, " - Setting covariance to " , covV) - } - - proposalGenerator = updateProposalGenerator(proposalGenerator) - - } - , silent = FALSE) - } - out = list(proposalGenerator = proposalGenerator, settings = settings) - return(out) -} - -#' Returns possible sampler types -#' @export -#' @author Florian Hartig -getPossibleSamplerTypes <- function(){ - - out = list( - BTname = c("AM", "DR", "DRAM", "Metropolis", "DE", "DEzs", "DREAM", "DREAMzs", "Twalk", "SMC"), - possibleSettings = list() , - possibleSettingsName = list() , - - univariatePossible = c(T, T, T, T, T, T, T, T, T, F), - restartable = c(T, T, T, T, T, T, T, T, T, F) - ) - - return(out) +#' Main wrapper function to start MCMCs, particle MCMCs and SMCs +#' @author Florian Hartig +#' @param bayesianSetup either a BayesianSetup (see \code{\link{createBayesianSetup}}), a function, or a BayesianOutput created by runMCMC. The latter allows to continue a previous MCMC run. See details for how to restart a sampler. +#' @param sampler sampling algorithm to be run. Default is DEzs. Options are "Metropolis", "AM", "DR", "DRAM", "DE", "DEzs", "DREAM", "DREAMzs", "SMC". For details see the help of the individual functions. +#' @param settings list with settings for each sampler. If a setting is not provided, defaults (see \code{\link{applySettingsDefault}}) will be used. +#' @details The runMCMC function can be started with either one of +#' +#' 1. an object of class BayesianSetup with prior and likelihood function (created with \code{\link{createBayesianSetup}}). check if appropriate parallelization options are used - many samplers can make use of parallelization if this option is activated when the class is created. +#' 2. a log posterior or other target function, +#' 3. an object of class BayesianOutput created by runMCMC. The latter allows to continue a previous MCMC run. +#' +#' Settings for the sampler are provides as a list. You can see the default values by running \code{\link{applySettingsDefault}} with the respective sampler name. The following settings can be used for all MCMCs: +#' +#' * startValue (no default) start values for the MCMC. Note that DE family samplers require a matrix of start values. If startvalues are not provided, they are sampled from the prior. +#' * iterations (10000) the MCMC iterations +#' * burnin (0) burnin +#' * thin (1) thinning while sampling +#' * consoleUpdates (100) update frequency for console updates +#' * parallel (NULL) whether parallelization is to be used +#' * message (TRUE) if progress messages are to be printed +#' * nrChains (1) the number of independent MCMC chains to be run. Note that this is not controlling the internal number of chains in population MCMCs such as DE, so if you run nrChains = 3 with a DEzs startValue that is a 4xparameter matrix (= 4 internal chains), you will run independent DEzs runs with 4 internal chains each. +#' +#' The MCMC samplers will have a number of additional settings, which are described in the Vignette (run vignette("BayesianTools", package="BayesianTools") and in the help of the samplers. See \code{\link{Metropolis}} for Metropolis based samplers, \code{\link{DE}} and \code{\link{DEzs}} for standard differential evolution samplers, \code{\link{DREAM}} and \code{\link{DREAMzs}} for DREAM sampler, \code{\link{Twalk}} for the Twalk sampler, and \code{\link{smcSampler}} for rejection and Sequential Monte Carlo sampling. Note that the samplers "AM", "DR", and "DRAM" are special cases of the "Metropolis" sampler and are shortcuts for predefined settings ("AM": adapt=TRUE; "DR": DRlevels=2; "DRAM": adapt=True, DRlevels=2). +#' +#' Note that even if you specify parallel = T, this will only turn on internal parallelization of the samplers. The independent samplers controlled by nrChains are not evaluated in parallel, so if time is an issue it will be better to run the MCMCs individually and then combine them via \code{\link{createMcmcSamplerList}} into one joint object. +#' +#' Note that, DE and DREAM variants as well as SMC and T-walk require a population to start, which should be provided as a matrix. Default (NULL) sets the population size for DE to 3 x dimensions of parameters, for DREAM to 2 x dimensions of parameters and for DEzs and DREAMzs to three, sampled from the prior. Note also that the zs variants of DE and DREAM require two populations, the current population and the z matrix (a kind of memory) - if you want to set both, provide a list with startvalue$X and startvalue$Z. +#' +#' setting startValue for sampling with nrChains > 1 : if you want to provide different start values for the different chains, provide them as a list +#' +#' @return The function returns an object of class mcmcSampler (if one chain is run) or mcmcSamplerList. Both have the superclass bayesianOutput. It is possible to extract the samples as a coda object or matrix with \code{\link{getSample}}. +#' It is also possible to summarize the posterior as a new prior via \code{\link{createPriorDensity}}. +#' @example /inst/examples/mcmcRun.R +#' @seealso \code{\link{createBayesianSetup}} +#' @export +runMCMC <- function(bayesianSetup , sampler = "DEzs", settings = NULL){ + + options(warn = 0) + + ptm <- proc.time() + + ####### RESTART ########## + + if("bayesianOutput" %in% class(bayesianSetup)){ + + # TODO - the next statements should have assertions in case someone overwrites the existing setting or similar + + previousMcmcSampler <- bayesianSetup + + + # Catch the settings in case of nrChains > 1 + if(!("mcmcSamplerList" %in% class(previousMcmcSampler) | "smcSamplerList" %in% class(previousMcmcSampler) )){ + if(is.null(settings)) settings <- previousMcmcSampler$settings + setup <- previousMcmcSampler$setup + sampler <- previousMcmcSampler$settings$sampler + previousSettings <- previousMcmcSampler$settings + } else{ + if(is.null(settings)) settings <- previousMcmcSampler[[1]]$settings + settings$nrChains <- length(previousMcmcSampler) + setup <- previousMcmcSampler[[1]]$setup + sampler <- previousMcmcSampler[[1]]$settings$sampler + previousSettings <- previousMcmcSampler[[1]]$settings + } + + # Set settings$sampler (only needed if new settings are supplied) + settings$sampler <- sampler + + # overwrite new settings + for(name in names(settings)) previousSettings[[name]] <- settings[[name]] + + settings <- previousSettings + + # Check if previous settings will be new default + + previousMcmcSampler$settings <- applySettingsDefault(settings = settings, sampler = settings$sampler, check = TRUE) + + restart <- TRUE + + + ## NOT RESTART STARTS HERE ################### + + }else if(inherits(bayesianSetup, "BayesianSetup")){ + restart <- FALSE + + if(is.null(settings$parallel)) settings$parallel <- bayesianSetup$parallel + if(is.numeric(settings$parallel)) settings$parallel <- TRUE + + setup <- checkBayesianSetup(bayesianSetup, parallel = settings$parallel) + settings <- applySettingsDefault(settings = settings, sampler = sampler, check = TRUE) + } else stop("runMCMC requires a class of type BayesianOutput or BayesianSetup") + + ###### END RESTART ############## + + + # TODO - the following statement should be removed once all further functions access settings$sampler instead of sampler + # At the moment only the same sampler can be used to restart sampling. + sampler = settings$sampler + + #### Assertions + if(!restart && setup$numPars == 1) if(!getPossibleSamplerTypes()$univariate[which(getPossibleSamplerTypes()$BTname == settings$sampler)]) stop("This sampler can not be applied to a univariate distribution") + + if(restart == T) if(!getPossibleSamplerTypes()$restartable[which(getPossibleSamplerTypes()$BTname == settings$sampler)]) stop("This sampler can not be restarted") + + ########### Recursive call in case multiple chains are to be run + if(settings$nrChains >1){ + + # Initialize output list + out<- list() + + # Run several samplers + for(i in 1:settings$nrChains){ + + settingsTemp <- settings + settingsTemp$nrChains <- 1 # avoid infinite loop + settingsTemp$currentChain <- i + + if(restart){ + out[[i]] <- runMCMC(bayesianSetup = previousMcmcSampler[[i]], settings = settingsTemp) + }else{ + if(is.list(settings$startValue)) settingsTemp$startValue = settings$startValue[[i]] + out[[i]] <- runMCMC(bayesianSetup = setup, sampler = settings$sampler, settings = settingsTemp) + } + } + if(settings$sampler == "SMC") class(out) = c("smcSamplerList", "bayesianOutput") + else class(out) = c("mcmcSamplerList", "bayesianOutput") + return(out) + + ######### END RECURSIVE CALL + # MAIN RUN FUNCTION HERE + }else{ + + # check start values + setup$prior$checkStart(settings$startValue) + + + if (sampler == "Metropolis" || sampler == "AM" || sampler == "DR" || sampler == "DRAM"){ + if(restart == FALSE){ + mcmcSampler <- Metropolis(bayesianSetup = setup, settings = settings) + mcmcSampler <- sampleMetropolis(mcmcSampler = mcmcSampler, iterations = settings$iterations) + } else { + mcmcSampler <- sampleMetropolis(mcmcSampler = previousMcmcSampler, iterations = settings$iterations) + } + } + + + + ############## Differential Evolution ##################### + if (sampler == "DE"){ + + if(restart == F) out <- DE(bayesianSetup = setup, settings = settings) + else out <- DE(bayesianSetup = previousMcmcSampler, settings = settings) + + #out <- DE(bayesianSetup = bayesianSetup, settings = list(startValue = NULL, iterations = settings$iterations, burnin = settings$burnin, eps = settings$eps, parallel = settings$parallel, consoleUpdates = settings$consoleUpdates, + # blockUpdate = settings$blockUpdate, currentChain = settings$currentChain)) + + mcmcSampler = list( + setup = setup, + settings = settings, + chain = out$Draws, + X = out$X, + sampler = "DE" + ) + } + + ############## Differential Evolution with snooker update + if (sampler == "DEzs"){ + # check z matrix + if(!is.null(settings$Z)) setup$prior$checkStart(settings$Z,z = TRUE) + + if(restart == F) out <- DEzs(bayesianSetup = setup, settings = settings) + else out <- DEzs(bayesianSetup = previousMcmcSampler, settings = settings) + + mcmcSampler = list( + setup = setup, + settings = settings, + chain = out$Draws, + X = out$X, + Z = out$Z, + sampler = "DEzs" + ) + } + + ############## DREAM + if (sampler == "DREAM"){ + + if(restart == F) out <- DREAM(bayesianSetup = setup, settings = settings) + else out <- DREAM(bayesianSetup = previousMcmcSampler, settings = settings) + + mcmcSampler = list( + setup = setup, + settings = settings, + chain = out$chains, + pCR = out$pCR, + sampler = "DREAM", + lCR = out$lCR, + X = out$X, + delta = out$delta + ) + } + + ############## DREAMzs + if (sampler == "DREAMzs"){ + # check z matrix + if(!is.null(settings$Z)) setup$prior$checkStart(settings$Z,z = TRUE) + + if(restart == F) out <- DREAMzs(bayesianSetup = setup, settings = settings) + else out <- DREAMzs(bayesianSetup = previousMcmcSampler, settings = settings) + + mcmcSampler = list( + setup = setup, + settings = settings, + chain = out$chains, + pCR = out$pCR, + sampler = "DREAMzs", + JumpRates = out$JumpRates, + X = out$X, + Z = out$Z + ) + + } + + if(sampler == "Twalk"){ + warning("At the moment using T-walk is discouraged: numeric instability") + if(!restart){ + if(is.null(settings$startValue)){ + settings$startValue = bayesianSetup$prior$sampler(2) + } + mcmcSampler <- Twalk(bayesianSetup = setup, settings = settings) + }else{ + mcmcSampler <- Twalk(bayesianSetup = previousMcmcSampler, settings = settings) + } + mcmcSampler$setup <- setup + mcmcSampler$sampler <- "Twalk" + } + + + if ((sampler != "SMC")){ + class(mcmcSampler) <- c("mcmcSampler", "bayesianOutput") + } + + ############# SMC ##################### + + if (sampler == "SMC"){ + + mcmcSampler <- smcSampler(bayesianSetup = bayesianSetup, initialParticles = settings$initialParticles, iterations = settings$iterations, resampling = settings$resampling, resamplingSteps = settings$resamplingSteps, proposal = settings$proposal, adaptive = settings$adaptive, proposalScale = settings$proposalScale ) + mcmcSampler$settings = settings + } + + mcmcSampler$settings$runtime = mcmcSampler$settings$runtime + proc.time() - ptm + if(is.null(settings$message) || settings$message == TRUE){ + message("runMCMC terminated after ", mcmcSampler$settings$runtime[3], "seconds") + } + return(mcmcSampler) + } +} + + +#bayesianSetup = bayesianSetup, initialParticles = settings$initialParticles, iterations = settings$iterations, resampling = settings$resampling, resamplingSteps = settings$resamplingSteps, proposal = settings$proposal, adaptive = settings$adaptive, parallel = settings$parallel + + +#' Provides the default settings for the different samplers in runMCMC +#' @author Florian Hartig +#' @param settings optional list with parameters that will be used instead of the defaults +#' @param sampler one of the samplers in \code{\link{runMCMC}} +#' @param check logical determines whether parameters should be checked for consistency +#' @details see \code{\link{runMCMC}} +#' @export +applySettingsDefault<-function(settings=NULL, sampler = "DEzs", check = FALSE){ + + if(is.null(settings)) settings = list() + + if(!is.null(sampler)){ + if(!is.null(settings$sampler)) { + # TODO: this is a bit hacky. The best would prabably be to change the Metropolis function to allow AM, DR and DRAM + # arguments and call applySettingsDefault for those + if (settings$sampler %in% c("AM", "DR", "DRAM") && sampler == "Metropolis") { + sampler <- settings$sampler + } + if(settings$sampler != sampler) { + warning("sampler argument overwrites an existing settings$sampler in applySettingsDefault. This only makes sense if one wants to take over settings from one sampler to another") + } + } + settings$sampler = sampler + } + + if(!settings$sampler %in% getPossibleSamplerTypes()$BTname) stop("trying to set values for a sampler that does not exist") + + + mcmcDefaults <- list(startValue = NULL, + iterations = 10000, + burnin = 0, + thin = 1, + consoleUpdates = 100, + parallel = NULL, + message = TRUE) + + #### Metropolis #### + if(settings$sampler %in% c("AM", "DR", "DRAM", "Metropolis")){ + + defaultSettings <- c(mcmcDefaults, list(optimize = T, + proposalGenerator = NULL, + adapt = F, + adaptationInterval = 500, + adaptationNotBefore = 3000, + DRlevels = 1 , + proposalScaling = NULL, + adaptationDepth = NULL, + temperingFunction = NULL, + proposalGenerator = NULL, + gibbsProbabilities = NULL)) + + if (settings$sampler %in% c("AM", "DRAM")) defaultSettings$adapt <- TRUE + if (settings$sampler %in% c("DR", "DRAM")) defaultSettings$DRlevels <- 2 + } + + #### DE Family #### + if(settings$sampler %in% c("DE", "DEzs")){ + defaultSettings <- c(mcmcDefaults, list(eps = 0, + currentChain = 1, + blockUpdate = list("none", + k = NULL, + h = NULL, + pSel = NULL, + pGroup = NULL, + groupStart = 1000, + groupIntervall = 1000) + )) + + if (settings$sampler == "DE"){ + defaultSettings$f <- -2.38 # TODO CHECK + + } + + if (settings$sampler == "DEzs"){ + defaultSettings$f <- 2.38 + defaultSettings <- c(defaultSettings, list(Z = NULL, + zUpdateFrequency = 1, + pSnooker = 0.1, + pGamma1 = 0.1, + eps.mult =0.2, + eps.add = 0)) + } + + } + + #### DREAM Family #### + + if(settings$sampler %in% c("DREAM", "DREAMzs")){ + defaultSettings <- c(mcmcDefaults, list(nCR = 3, + currentChain = 1, + gamma = NULL, + eps = 0, + e = 5e-2, + DEpairs = 2, + adaptation = 0.2, + updateInterval = 10)) + + if (settings$sampler == "DREAM"){ + defaultSettings$pCRupdate <- TRUE + } + + if (settings$sampler == "DREAMzs"){ + defaultSettings = c(defaultSettings, list( + pCRupdate = FALSE, + Z = NULL, + ZupdateFrequency = 10, + pSnooker = 0.1 + )) + } + } + + #### Twalk #### + + if (settings$sampler == "Twalk"){ + defaultSettings = c(mcmcDefaults, + list(at = 6, + aw = 1.5, + pn1 = NULL, + Ptrav = 0.4918, + Pwalk = NULL, + Pblow = NULL)) + defaultSettings$parallel = NULL + } + + #### SMC #### + + if (settings$sampler == "SMC"){ + defaultSettings = list(iterations = 10, + resampling = T, + resamplingSteps = 2, + proposal = NULL, + adaptive = T, + proposalScale = 0.5, + initialParticles = 1000 + ) + } + + + + ## CHECK DEFAULTS + + if(check){ + nam = c(names(defaultSettings), "sampler", "nrChains", + "runtime", "sessionInfo", "parallel") + + ind <- which((names(settings) %in% nam == FALSE)) + + nam_n <- names(settings)[ind] + for(i in 1:length(nam_n)) nam_n[i] <- paste(nam_n[i], " ") + + if(length(ind) > 0){ + message("Parameter(s) ", nam_n , " not used in ", settings$sampler, "\n") + } + } + + defaultSettings$nrChains = 1 + defaultSettings$runtime = 0 + defaultSettings$sessionInfo = utils::sessionInfo() + + nam = names(defaultSettings) + + for (i in 1:length(defaultSettings)){ + if(! nam[i] %in% names(settings)){ + addition = list( defaultSettings[[i]]) + names(addition) = nam[i] + settings = c(settings, addition) + } + } + + + if (! is.null(settings$burnin)){ + if (settings$burnin > settings$iterations) stop("BayesianToools::applySettingsDefault - setting burnin cannnot be larger than setting iteration") + if (! is.null(settings$adaptationNotBefore)){ + if (settings$burnin >= settings$adaptationNotBefore) stop("BayesianToools::applySettingsDefault - setting burnin cannnot be larger than setting adaptationNotBefore") + } + } + + return(settings) +} + + +#' Help function to find starvalues and proposalGenerator settings +#' @author Florian Hartig +#' @param proposalGenerator proposal generator +#' @param bayesianSetup either an object of class bayesianSetup created by \code{\link{createBayesianSetup}} (recommended), or a log target function +#' @param settings list with settings +#' @keywords internal +setupStartProposal <- function(proposalGenerator = NULL, bayesianSetup, settings){ + + # Proposal + range = (bayesianSetup$prior$upper - bayesianSetup$prior$lower) / 50 + + if(is.null(settings$startValue)) settings$startValue = (bayesianSetup$prior$upper + bayesianSetup$prior$lower) / 2 + + if (length(range) != bayesianSetup$numPars) range = rep(1,bayesianSetup$numPars) + + if(is.null(proposalGenerator)){ + proposalGenerator = createProposalGenerator(range, gibbsProbabilities = settings$gibbsProbabilities) + } + + ####### OPTIMIZATION + + if (settings$optimize == T){ + if(is.null(settings$message) || settings$message == TRUE){ + cat("BT runMCMC: trying to find optimal start and covariance values", "\b") + } + + target <- function(x){ + out <- bayesianSetup$posterior$density(x) + if (out == -Inf) out = -1e20 # rnorm(1, mean = -1e20, sd = 1e-20) + return(out) + } + + try( { + if(bayesianSetup$numPars > 1) optresul <- optim(par=settings$startValue,fn=target, method="Nelder-Mead", hessian=F, control=list("fnscale"=-1, "maxit" = 10000)) + else optresul <- optim(par=settings$startValue,fn=target, method="Brent", hessian=F, control=list("fnscale"=-1, "maxit" = 10000), lower = bayesianSetup$prior$lower, upper = bayesianSetup$prior$upper) + settings$startValue = optresul$par + hessian = numDeriv::hessian(target, optresul$par) + + + proposalGenerator$covariance = as.matrix(Matrix::nearPD(MASS::ginv(-hessian))$mat) + #proposalGenerator$covariance = MASS::ginv(-optresul$hessian) + + # Create objects for startValues and covariance to add space between values + startV <-covV <- character() + + for(i in 1:length(settings$startValue)){ + startV[i] <- paste(settings$startValue[i], "") + } + for(i in 1:length( proposalGenerator$covariance)){ + covV[i] <- paste( proposalGenerator$covariance[i], "") + } + + if(is.null(settings$message) || settings$message == TRUE){ + message("BT runMCMC: Optimization finished, setting startValues to " , + startV, " - Setting covariance to " , covV) + } + + proposalGenerator = updateProposalGenerator(proposalGenerator) + + } + , silent = FALSE) + } + out = list(proposalGenerator = proposalGenerator, settings = settings) + return(out) +} + +#' Returns possible sampler types +#' @export +#' @author Florian Hartig +getPossibleSamplerTypes <- function(){ + + out = list( + BTname = c("AM", "DR", "DRAM", "Metropolis", "DE", "DEzs", "DREAM", "DREAMzs", "Twalk", "SMC"), + possibleSettings = list() , + possibleSettingsName = list() , + + univariatePossible = c(T, T, T, T, T, T, T, T, T, F), + restartable = c(T, T, T, T, T, T, T, T, T, F) + ) + + return(out) } \ No newline at end of file diff --git a/BayesianTools/R/mcmcTwalk.R b/BayesianTools/R/mcmcTwalk.R index ffceb46..63c53c4 100644 --- a/BayesianTools/R/mcmcTwalk.R +++ b/BayesianTools/R/mcmcTwalk.R @@ -1,154 +1,154 @@ -#' T-walk MCMC -#' @author Stefan Paul -#' @param bayesianSetup Object of class 'bayesianSetup' or 'bayesianOuput'. -#' @param settings list with parameter values. -#' @param iterations Number of model evaluations -#' @param at "traverse" move proposal parameter. Default to 6 -#' @param aw "walk" move proposal parameter. Default to 1.5 -#' @param pn1 Probability determining the number of parameters that are changed -#' @param Ptrav Move probability of "traverse" moves, default to 0.4918 -#' @param Pwalk Move probability of "walk" moves, default to 0.4918 -#' @param Pblow Move probability of "traverse" moves, default to 0.0082 -#' @param burnin number of iterations treated as burn-in. These iterations are not recorded in the chain. -#' @param thin thinning parameter. Determines the interval in which values are recorded. -#' @param startValue Matrix with start values -#' @param consoleUpdates Intervall in which the sampling progress is printed to the console -#' @param message logical determines whether the sampler's progress should be printed -#' @details -##' The probability of "hop" moves is 1 minus the sum of all other probabilities. -#' @return Object of class bayesianOutput. -#' @references Christen, J. Andres, and Colin Fox. "A general purpose sampling algorithm for continuous distributions (the t-walk)." Bayesian Analysis 5.2 (2010): 263-281. -#' @export -Twalk <- function (bayesianSetup, settings = list(iterations = 10000, at = 6, aw = 1.5, - pn1 = NULL, Ptrav = 0.4918, Pwalk = 0.4918, - Pblow = 0.0082, burnin = 0, thin= 1, startValue = NULL, consoleUpdates = 100, - message = TRUE)) -{ - if("bayesianOutput" %in% class(bayesianSetup)){ - restart <- TRUE - setup <- bayesianSetup$setup - }else{ - restart <- FALSE - setup <- bayesianSetup - } - - setup <- checkBayesianSetup(setup, parallel = settings$parallel) # calling parallel will check if requested parallelization in settings is provided by the BayesianSetup - if(is.null(settings$parallel)) settings$parallel = setup$parallel # checking back - if no parallelization is provided, we use the parallelization in the BayesianSetup. We could also set parallel = F, but I feel it makes more sense to use the Bayesiansetup as default - - - aw <- settings$aw - at <- settings$at - Npar <- setup$numPars - iterations <- floor(settings$iterations/2) # Divided by 2 because two chains are run - if(is.null(settings$pn1)) pn1 <- min(Npar,4)/Npar - else pn1 <- settings$pn1 - Ptrav <- settings$Ptrav - if(is.null(settings$Pwalk)) Pwalk <- 0.4918 - else Pwalk <- settings$Pwalk - if(is.null(settings$Pblow)) Pblow <- 0.0082 - else Pblow <- settings$Pblow - - - # Set burnin and thin - burnin <- settings$burnin - thin <- settings$thin - - # Set Phop - Phop <- 1-(Ptrav+Pwalk+Pblow) - - # Check for consistency of move probabilities - if((Pwalk + Ptrav + Pblow) > 1) stop("Move probabilities larger one") - - consoleUpdates <- settings$consoleUpdates - - - FUN <- setup$posterior$density - - if(!restart){ - # Initialize x and x2 - - if(is.null(settings$startValue)){ - settings$startValue = setup$prior$sampler(2) - } - if(is.function(settings$startValue)){ - settings$startValue = settings$startValue(2) - } - x <- settings$startValue[1,] - x2 <- settings$startValue[2,] - - # Evaluate - Eval <- FUN(x, returnAll = T) - Eval2 <- FUN(x2, returnAll = T) - }else{ - x <- bayesianSetup$chain[[1]][nrow(bayesianSetup$chain[[1]]), 1:Npar] - x2 <- bayesianSetup$chain[[2]][nrow(bayesianSetup$chain[[2]]), 1:Npar] - - Eval <- bayesianSetup$chain[[1]][nrow(bayesianSetup$chain[[1]]), (Npar+1):(Npar+3)] - Eval2 <- bayesianSetup$chain[[2]][nrow(bayesianSetup$chain[[2]]), (Npar+1):(Npar+3)] - - } - - # Initialize chains - chain <- matrix(NA, nrow = floor((iterations+1-burnin)/thin), ncol = Npar+3) - chain2 <- matrix(NA, nrow = floor((iterations+1-burnin)/thin), ncol = Npar+3) - - # Fill first values in chain - chain[1,] <- c(x,Eval) - chain2[1,] <- c(x2,Eval2) - - # Initialize counter for acceptance rate - acceptance <- 0 - - # Initialize counter - counter <- 0 - - - for (i in 1:iterations) { - - move <- TwalkMove(Npar = Npar, FUN = FUN, x = x, - Eval = Eval, x2 = x2, Eval2 = Eval2, - at = at, aw = aw, pn1 = pn1, Ptrav = Ptrav, - Pwalk = Pwalk, Pblow = Pblow, Phop = Phop) - - if(!is.na(move$alpha)){ - if (runif(1) < move$alpha) { - x <- move$y - Eval<- move$val - x2 <- move$y2 - Eval2 <- move$val2 - } - } - - if((i > burnin) && (i %% thin == 0) ){ # retain sample - counter <- counter + 1 - chain[counter,] <- c(x, Eval) - chain2[counter,] <- c(x2, Eval2) - } - - if(settings$message){ - if( (i %% consoleUpdates == 0) | (i == iterations)) { - cat("\r","Running Twalk-MCMC, chain ", settings$currentChain , "iteration" ,(i*2),"of",(iterations*2), - ". Current logp ", Eval[1], Eval2[1] ,". Please wait!","\r") - flush.console() - } - } - } - colnames(chain) <- c(setup$names,"LP", "LL", "LPr") - colnames(chain2) <- c(setup$names,"LP", "LL", "LPr") - - if(restart){ # Combine chains - chain <- rbind(bayesianSetup$chain[[1]], chain) - chain2 <- rbind(bayesianSetup$chain[[2]], chain2) - } - - # Make sure chains have the right size - chain <- chain[1:counter,] - chain2 <- chain2[1:counter,] - - chain <- coda::mcmc.list(coda::mcmc(chain), coda::mcmc(chain2)) - - out <- list(chain = chain, settings = settings) - class(out) <- c("mcmcSampler", "bayesianOutput") - return(out) -} - +#' T-walk MCMC +#' @author Stefan Paul +#' @param bayesianSetup object of class 'bayesianSetup' or 'bayesianOuput'. +#' @param settings list with parameter values. +#' @param iterations number of model evaluations +#' @param at "traverse" move proposal parameter. Default to 6 +#' @param aw "walk" move proposal parameter. Default to 1.5 +#' @param pn1 probability determining the number of parameters that are changed +#' @param Ptrav move probability of "traverse" moves, default to 0.4918 +#' @param Pwalk move probability of "walk" moves, default to 0.4918 +#' @param Pblow move probability of "traverse" moves, default to 0.0082 +#' @param burnin number of iterations treated as burn-in. These iterations are not recorded in the chain. +#' @param thin thinning parameter. Determines the interval in which values are recorded. +#' @param startValue matrix with start values +#' @param consoleUpdates intervall in which the sampling progress is printed to the console +#' @param message logical, determines whether the sampler's progress should be printed +#' @details +##' The probability of "hop" moves is 1 minus the sum of all other probabilities. +#' @return Object of class bayesianOutput. +#' @references Christen, J. Andres, and Colin Fox. "A general purpose sampling algorithm for continuous distributions (the t-walk)." Bayesian Analysis 5.2 (2010): 263-281. +#' @export +Twalk <- function (bayesianSetup, settings = list(iterations = 10000, at = 6, aw = 1.5, + pn1 = NULL, Ptrav = 0.4918, Pwalk = 0.4918, + Pblow = 0.0082, burnin = 0, thin= 1, startValue = NULL, consoleUpdates = 100, + message = TRUE)) +{ + if("bayesianOutput" %in% class(bayesianSetup)){ + restart <- TRUE + setup <- bayesianSetup$setup + }else{ + restart <- FALSE + setup <- bayesianSetup + } + + setup <- checkBayesianSetup(setup, parallel = settings$parallel) # calling parallel will check if requested parallelization in settings is provided by the BayesianSetup + if(is.null(settings$parallel)) settings$parallel = setup$parallel # checking back - if no parallelization is provided, we use the parallelization in the BayesianSetup. We could also set parallel = F, but I feel it makes more sense to use the Bayesiansetup as default + + + aw <- settings$aw + at <- settings$at + Npar <- setup$numPars + iterations <- floor(settings$iterations/2) # Divided by 2 because two chains are run + if(is.null(settings$pn1)) pn1 <- min(Npar,4)/Npar + else pn1 <- settings$pn1 + Ptrav <- settings$Ptrav + if(is.null(settings$Pwalk)) Pwalk <- 0.4918 + else Pwalk <- settings$Pwalk + if(is.null(settings$Pblow)) Pblow <- 0.0082 + else Pblow <- settings$Pblow + + + # Set burnin and thin + burnin <- settings$burnin + thin <- settings$thin + + # Set Phop + Phop <- 1-(Ptrav+Pwalk+Pblow) + + # Check for consistency of move probabilities + if((Pwalk + Ptrav + Pblow) > 1) stop("Move probabilities larger one") + + consoleUpdates <- settings$consoleUpdates + + + FUN <- setup$posterior$density + + if(!restart){ + # Initialize x and x2 + + if(is.null(settings$startValue)){ + settings$startValue = setup$prior$sampler(2) + } + if(is.function(settings$startValue)){ + settings$startValue = settings$startValue(2) + } + x <- settings$startValue[1,] + x2 <- settings$startValue[2,] + + # Evaluate + Eval <- FUN(x, returnAll = T) + Eval2 <- FUN(x2, returnAll = T) + }else{ + x <- bayesianSetup$chain[[1]][nrow(bayesianSetup$chain[[1]]), 1:Npar] + x2 <- bayesianSetup$chain[[2]][nrow(bayesianSetup$chain[[2]]), 1:Npar] + + Eval <- bayesianSetup$chain[[1]][nrow(bayesianSetup$chain[[1]]), (Npar+1):(Npar+3)] + Eval2 <- bayesianSetup$chain[[2]][nrow(bayesianSetup$chain[[2]]), (Npar+1):(Npar+3)] + + } + + # Initialize chains + chain <- matrix(NA, nrow = floor((iterations+1-burnin)/thin), ncol = Npar+3) + chain2 <- matrix(NA, nrow = floor((iterations+1-burnin)/thin), ncol = Npar+3) + + # Fill first values in chain + chain[1,] <- c(x,Eval) + chain2[1,] <- c(x2,Eval2) + + # Initialize counter for acceptance rate + acceptance <- 0 + + # Initialize counter + counter <- 0 + + + for (i in 1:iterations) { + + move <- TwalkMove(Npar = Npar, FUN = FUN, x = x, + Eval = Eval, x2 = x2, Eval2 = Eval2, + at = at, aw = aw, pn1 = pn1, Ptrav = Ptrav, + Pwalk = Pwalk, Pblow = Pblow, Phop = Phop) + + if(!is.na(move$alpha)){ + if (runif(1) < move$alpha) { + x <- move$y + Eval<- move$val + x2 <- move$y2 + Eval2 <- move$val2 + } + } + + if((i > burnin) && (i %% thin == 0) ){ # retain sample + counter <- counter + 1 + chain[counter,] <- c(x, Eval) + chain2[counter,] <- c(x2, Eval2) + } + + if(settings$message){ + if( (i %% consoleUpdates == 0) | (i == iterations)) { + cat("\r","Running Twalk-MCMC, chain ", settings$currentChain , "iteration" ,(i*2),"of",(iterations*2), + ". Current logp ", Eval[1], Eval2[1] ,". Please wait!","\r") + flush.console() + } + } + } + colnames(chain) <- c(setup$names,"LP", "LL", "LPr") + colnames(chain2) <- c(setup$names,"LP", "LL", "LPr") + + if(restart){ # Combine chains + chain <- rbind(bayesianSetup$chain[[1]], chain) + chain2 <- rbind(bayesianSetup$chain[[2]], chain2) + } + + # Make sure chains have the right size + chain <- chain[1:counter,] + chain2 <- chain2[1:counter,] + + chain <- coda::mcmc.list(coda::mcmc(chain), coda::mcmc(chain2)) + + out <- list(chain = chain, settings = settings) + class(out) <- c("mcmcSampler", "bayesianOutput") + return(out) +} + diff --git a/BayesianTools/R/mcmcTwalk_helperFunctions.R b/BayesianTools/R/mcmcTwalk_helperFunctions.R index 8aaaf41..9d2c092 100644 --- a/BayesianTools/R/mcmcTwalk_helperFunctions.R +++ b/BayesianTools/R/mcmcTwalk_helperFunctions.R @@ -1,299 +1,299 @@ -###### -# Twalk helper functions -###### - -#' Wrapper for step function -#' @param Npar Number of parameters -#' @param FUN Log posterior density -#' @param x parameter vector of chain 1 -#' @param Eval last evaluation of x -#' @param x2 parameter vector of chain 2 -#' @param Eval2 last evaluation of x -#' @param at "traverse" move proposal parameter. -#' @param aw "walk" move proposal parameter. -#' @param pn1 Probability determining the number of parameters that are changed. -#' @param Ptrav Move probability of "traverse" moves, default to 0.4918 -#' @param Pwalk Move probability of "walk" moves, default to 0.4918 -#' @param Pblow Move probability of "blow" moves, default to 0.0082 -#' @param Phop Move probability of "hop" moves -#' @references Christen, J. Andres, and Colin Fox. "A general purpose sampling algorithm for continuous distributions (the t-walk)." Bayesian Analysis 5.2 (2010): 263-281. -#' @keywords internal -TwalkMove <- function (Npar, FUN, x, Eval, x2, Eval2, at = 6, aw = 1.5, pn1 = min(Npar, 4)/Npar, - Ptrav = 0.4918, Pwalk = 0.4918, Pblow = 0.0082, Phop = 0.0082) -{ - - p <- sample(4,1, prob = c(Ptrav,Pwalk,Pblow,Phop)) - - if(p == 1)case <- "traverse" - else if(p ==2) case <- "walk" - else if(p ==3) case <- "blow" - else case <- "hop" - - - out <- Twalksteps(case = case, Npar = Npar, FUN = FUN, x = x, - Eval = Eval, x2 = x2, Eval2 = Eval2, at = at, aw = aw, pn1 = pn1) - - - return(list(y = out$y, val = out$val, y2 = out$y2, val2 = out$val2, alpha = out$alpha)) -} - - - -#' Main function that is executing and evaluating the moves -#' @param case Type of Twalk move. Either "walk", "traverse", "hop" or "blow" -#' @param Npar number of parameters -#' @param FUN Log posterior density -#' @param x parameter vector of chain 1 -#' @param Eval last evaluation of x -#' @param x2 parameter vector of chain 2 -#' @param Eval2 last evaluation of x -#' @param at "traverse" move proposal parameter. -#' @param aw "walk" move proposal parameter. -#' @param pn1 Probability determining the number of parameters that are changed. -#' @references Christen, J. Andres, and Colin Fox. "A general purpose sampling algorithm for continuous distributions (the t-walk)." Bayesian Analysis 5.2 (2010): 263-281. -#' @keywords internal -Twalksteps <- function(case, Npar, FUN, x, - Eval, x2, Eval2, at, aw, pn1){ - - val <- NULL - val2 <- NULL - p <- runif(1) - - switch(case, - "traverse" = { #Traverse - if (p < 0.5) { - beta <- betaFun(at) - tmp <- propFun(case, Npar = Npar, pn1 = pn1, x2 = x, x = x2, beta = beta) - y2 <- tmp$prop - npSel <- tmp$npSel - y <- x - val <- Eval - val2 <- FUN(y2, returnAll = T) - - if (npSel == 0) alpha <- 1 - else alpha <- exp((- Eval2[1] + val2[1]) + (npSel - 2) * log(beta)) - - }else{ - beta <- betaFun(at) - tmp <- propFun(case, Npar = Npar, pn1 = pn1, x = x, x2 = x2, beta = beta) - y <- tmp$prop - npSel <- tmp$npSel - y2 <- x2 - val2 <- Eval2 - - val <- FUN(y, returnAll = T) - - if (npSel == 0) alpha <- 1 - else alpha <- exp((-Eval[1] + val[1]) + (npSel - 2) * log(beta)) - - }}, # End traverse - "walk" = { # walk - if (p < 0.5) { - tmp <- propFun(case, Npar = Npar, pn1 = pn1, aw = aw, x2 = x, x = x2) - y2 <- tmp$prop - npSel <- tmp$npSel - y <- x - val <- Eval - if ( (all(abs(y2 - y) > 0))) { - val2 <- FUN(y2, returnAll = T) - - alpha <- exp(-Eval2[1] + val2[1]) - } - else { - alpha <- 0 - } - }else{ - tmp <- propFun(case, Npar = Npar, pn1 = pn1, aw = aw, x = x, x2 = x2) - y <- tmp$prop - npSel <- tmp$npSel - y2 <- x2 - val2 <- Eval2 - if ( (all(abs(y2 - y) > 0))) { - val <- FUN(y, returnAll = T) - - alpha <- exp(-Eval[1] + val[1]) - } - else { - alpha <- 0 - } - }}, # End walk - "blow" = { #blow - if (p < 0.5) { - tmp <- propFun(case, Npar = Npar, pn1 = pn1, x = x2, x2 = x) - y2 <- tmp$prop - npSel <- tmp$npSel - pSel <- tmp$pSel - y <- x - val <- Eval - if ( all(y2 != x)) { - val2 <- FUN(y2, returnAll = T) - - G1 <- Gfun(case, npSel, pSel, y2, x2, x) - G2 <- Gfun(case, npSel, pSel, x2, y2, x) - alpha <- exp((-Eval2[1] + val2[1]) + (G1 - G2)) - } - else { - alpha <- 0 - } - }else{ - tmp <- propFun(case, Npar = Npar, pn1 = pn1, x = x, x2 = x2) - y <- tmp$prop - npSel <- tmp$npSel - pSel <- tmp$pSel - y2 <- x2 - val2 <- Eval2 - if (all(y != x2)) { - val <- FUN(y, returnAll = T) - - G1 <- Gfun(case, npSel, pSel, y, x, x2) - G2 <- Gfun(case, npSel, pSel, x, y, x2) - alpha <- exp((-Eval[1] + val[1]) + (G1 - G2)) - } - else { - alpha <- 0 - } - } - }, # End blow - "hop" = { #hop - if (p < 0.5) { - tmp <- propFun(case, Npar = Npar, pn1 = pn1, x2 = x, x = x2) - y2 <- tmp$prop - npSel <- tmp$npSel - pSel <- tmp$pSel - y <- x - val <- Eval - if ( all(y2 != x)) { - val2 <- FUN(y2, returnAll = T) - - G1 <- Gfun(case, npSel, pSel, y2, x2, x) - G2 <- Gfun(case, npSel, pSel, x2, y2, x) - alpha <- exp((-Eval2[1] + val2[1]) + (G1 - G2)) - } - else { - alpha <- 0 - } - }else{ - tmp <- propFun(case, Npar = Npar, pn1 = pn1, x = x, x2 = x2) - y <- tmp$prop - npSel <- tmp$npSel - pSel <- tmp$pSel - y2 <- x2 - val2 <- Eval2 - if ( all(y != x2)) { - val <- FUN(y, returnAll = T) - - G1 <- Gfun(case, npSel, pSel, y, x, x2) - G2 <- Gfun(case, npSel, pSel, x, y, x2) - alpha <- exp((-Eval[1] + val[1]) + (G1 - G2)) - } - else { - alpha <- 0 - } - - }}) # End hop and end switch - return(list(y = y, val = val, y2 = y2, val2 = val2, alpha = alpha, - npSel = npSel)) -} - - - - - - - -################## Helper functions -############################################################### - -#' Helper function for sum of x*x -#' @param x vector of values -#' @keywords internal -sumSquare <- function(x){return(sum(x*x))} - - -#' Helper function to create proposal -#' @param case Type of Twalk move. Either "walk", "traverse", "hop" or "blow" -#' @param Npar number of parameters -#' @param pn1 Probability determining the number of parameters that are changed. -#' @param aw "walk" move proposal parameter. -#' @param beta parameter for "traverse" move proposals. -#' @param x parameter vector of chain 1 -#' @param x2 parameter vector of chain 2 -#' @references Christen, J. Andres, and Colin Fox. "A general purpose sampling algorithm for continuous distributions (the t-walk)." Bayesian Analysis 5.2 (2010): 263-281. -#' @keywords internal -propFun <- function(case, Npar, pn1, x, x2, beta = NULL, aw = NULL){ - - switch(case, - "traverse"={ - pSel <- (runif(Npar) < pn1) - prop <- NULL - for (i in 1:Npar){ - if (pSel[i]) prop <- c( prop, x2[i] + beta*(x2[i] - x[i])) - else prop <- c( prop, x[i]) - } - return(list(prop=prop, npSel=sum(pSel))) - }, - "walk"={ - u <- runif(Npar) - pSel <- (runif(Npar) < pn1) - z <- (aw/(1+aw))*(aw*u^2 + 2*u -1) - z <- z*pSel - return(list( prop=x + (x - x2)*z, npSel=sum(pSel))) - }, - "blow"={ - pSel <- (runif(Npar) < pn1) - sigma <- max(pSel*abs(x2 - x)) - return(list( prop=x2*pSel + sigma*rnorm(Npar)*pSel + x*(1-pSel), npSel=sum(pSel), pSel=pSel)) - - }, - "hop"={ - pSel <- (runif(Npar) < pn1) - sigma <- max(pSel*abs(x2 - x))/3 - prop <- NULL - for (i in 1:Npar){ - if (pSel[i]) prop <- c( prop, x[i] + sigma*rnorm(1)) - else prop <- c( prop, x[i]) - } - return(list( prop=prop, npSel=sum(pSel), pSel=pSel)) - - } - - ) -} - - -#' Helper function for calculating beta -#' @param at "traverse" move proposal parameter. -#' @keywords internal -betaFun <- 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)))) -} - - -#' Helper function for blow and hop moves -#' @param case Type of Twalk move. Either "hop" or "blow" -#' @param npSel number of parameters that are changed. -#' @param pSel vector containing information about which parameters are changed. -#' @param h Parameter for "blow" and hop moves -#' @param x parameter vector of chain 1 -#' @param x2 parameter vector of chain 2 -#' @references Christen, J. Andres, and Colin Fox. "A general purpose sampling algorithm for continuous distributions (the t-walk)." Bayesian Analysis 5.2 (2010): 263-281. -#' @keywords internal -Gfun <- function(case, npSel, pSel, h, x, x2){ - switch(case, - "blow"= { - sigma <- max(pSel*abs(x2 - x)) - if(npSel > 0) return((npSel/2)*log(2*pi) + npSel*log(sigma) + 0.5*sumSquare(h - x2)/(sigma^2)) - else return(0) - }, - "hop" = { - sigma <- max(pSel*abs(x2 - x))/3 - if (npSel > 0) return((npSel/2)*log(2*pi) - npSel*log(3) + npSel*log(sigma) + 0.5*9*sumSquare((h - x))/(sigma^2)) - else return(0) - }) - -} - - - +###### +# Twalk helper functions +###### + +#' Wrapper for step function +#' @param Npar number of parameters +#' @param FUN log posterior density +#' @param x parameter vector of chain 1 +#' @param Eval last evaluation of x +#' @param x2 parameter vector of chain 2 +#' @param Eval2 last evaluation of x +#' @param at "traverse" move proposal parameter. +#' @param aw "walk" move proposal parameter. +#' @param pn1 Probability determining the number of parameters that are changed. +#' @param Ptrav Move probability of "traverse" moves, default to 0.4918 +#' @param Pwalk Move probability of "walk" moves, default to 0.4918 +#' @param Pblow Move probability of "blow" moves, default to 0.0082 +#' @param Phop Move probability of "hop" moves +#' @references Christen, J. Andres, and Colin Fox. "A general purpose sampling algorithm for continuous distributions (the t-walk)." Bayesian Analysis 5.2 (2010): 263-281. +#' @keywords internal +TwalkMove <- function (Npar, FUN, x, Eval, x2, Eval2, at = 6, aw = 1.5, pn1 = min(Npar, 4)/Npar, + Ptrav = 0.4918, Pwalk = 0.4918, Pblow = 0.0082, Phop = 0.0082) +{ + + p <- sample(4,1, prob = c(Ptrav,Pwalk,Pblow,Phop)) + + if(p == 1)case <- "traverse" + else if(p ==2) case <- "walk" + else if(p ==3) case <- "blow" + else case <- "hop" + + + out <- Twalksteps(case = case, Npar = Npar, FUN = FUN, x = x, + Eval = Eval, x2 = x2, Eval2 = Eval2, at = at, aw = aw, pn1 = pn1) + + + return(list(y = out$y, val = out$val, y2 = out$y2, val2 = out$val2, alpha = out$alpha)) +} + + + +#' Main function that is executing and evaluating the moves +#' @param case Type of Twalk move. Either "walk", "traverse", "hop" or "blow" +#' @param Npar number of parameters +#' @param FUN Log posterior density +#' @param x parameter vector of chain 1 +#' @param Eval last evaluation of x +#' @param x2 parameter vector of chain 2 +#' @param Eval2 last evaluation of x +#' @param at "traverse" move proposal parameter. +#' @param aw "walk" move proposal parameter. +#' @param pn1 Probability determining the number of parameters that are changed. +#' @references Christen, J. Andres, and Colin Fox. "A general purpose sampling algorithm for continuous distributions (the t-walk)." Bayesian Analysis 5.2 (2010): 263-281. +#' @keywords internal +Twalksteps <- function(case, Npar, FUN, x, + Eval, x2, Eval2, at, aw, pn1){ + + val <- NULL + val2 <- NULL + p <- runif(1) + + switch(case, + "traverse" = { #Traverse + if (p < 0.5) { + beta <- betaFun(at) + tmp <- propFun(case, Npar = Npar, pn1 = pn1, x2 = x, x = x2, beta = beta) + y2 <- tmp$prop + npSel <- tmp$npSel + y <- x + val <- Eval + val2 <- FUN(y2, returnAll = T) + + if (npSel == 0) alpha <- 1 + else alpha <- exp((- Eval2[1] + val2[1]) + (npSel - 2) * log(beta)) + + }else{ + beta <- betaFun(at) + tmp <- propFun(case, Npar = Npar, pn1 = pn1, x = x, x2 = x2, beta = beta) + y <- tmp$prop + npSel <- tmp$npSel + y2 <- x2 + val2 <- Eval2 + + val <- FUN(y, returnAll = T) + + if (npSel == 0) alpha <- 1 + else alpha <- exp((-Eval[1] + val[1]) + (npSel - 2) * log(beta)) + + }}, # End traverse + "walk" = { # walk + if (p < 0.5) { + tmp <- propFun(case, Npar = Npar, pn1 = pn1, aw = aw, x2 = x, x = x2) + y2 <- tmp$prop + npSel <- tmp$npSel + y <- x + val <- Eval + if ( (all(abs(y2 - y) > 0))) { + val2 <- FUN(y2, returnAll = T) + + alpha <- exp(-Eval2[1] + val2[1]) + } + else { + alpha <- 0 + } + }else{ + tmp <- propFun(case, Npar = Npar, pn1 = pn1, aw = aw, x = x, x2 = x2) + y <- tmp$prop + npSel <- tmp$npSel + y2 <- x2 + val2 <- Eval2 + if ( (all(abs(y2 - y) > 0))) { + val <- FUN(y, returnAll = T) + + alpha <- exp(-Eval[1] + val[1]) + } + else { + alpha <- 0 + } + }}, # End walk + "blow" = { #blow + if (p < 0.5) { + tmp <- propFun(case, Npar = Npar, pn1 = pn1, x = x2, x2 = x) + y2 <- tmp$prop + npSel <- tmp$npSel + pSel <- tmp$pSel + y <- x + val <- Eval + if ( all(y2 != x)) { + val2 <- FUN(y2, returnAll = T) + + G1 <- Gfun(case, npSel, pSel, y2, x2, x) + G2 <- Gfun(case, npSel, pSel, x2, y2, x) + alpha <- exp((-Eval2[1] + val2[1]) + (G1 - G2)) + } + else { + alpha <- 0 + } + }else{ + tmp <- propFun(case, Npar = Npar, pn1 = pn1, x = x, x2 = x2) + y <- tmp$prop + npSel <- tmp$npSel + pSel <- tmp$pSel + y2 <- x2 + val2 <- Eval2 + if (all(y != x2)) { + val <- FUN(y, returnAll = T) + + G1 <- Gfun(case, npSel, pSel, y, x, x2) + G2 <- Gfun(case, npSel, pSel, x, y, x2) + alpha <- exp((-Eval[1] + val[1]) + (G1 - G2)) + } + else { + alpha <- 0 + } + } + }, # End blow + "hop" = { #hop + if (p < 0.5) { + tmp <- propFun(case, Npar = Npar, pn1 = pn1, x2 = x, x = x2) + y2 <- tmp$prop + npSel <- tmp$npSel + pSel <- tmp$pSel + y <- x + val <- Eval + if ( all(y2 != x)) { + val2 <- FUN(y2, returnAll = T) + + G1 <- Gfun(case, npSel, pSel, y2, x2, x) + G2 <- Gfun(case, npSel, pSel, x2, y2, x) + alpha <- exp((-Eval2[1] + val2[1]) + (G1 - G2)) + } + else { + alpha <- 0 + } + }else{ + tmp <- propFun(case, Npar = Npar, pn1 = pn1, x = x, x2 = x2) + y <- tmp$prop + npSel <- tmp$npSel + pSel <- tmp$pSel + y2 <- x2 + val2 <- Eval2 + if ( all(y != x2)) { + val <- FUN(y, returnAll = T) + + G1 <- Gfun(case, npSel, pSel, y, x, x2) + G2 <- Gfun(case, npSel, pSel, x, y, x2) + alpha <- exp((-Eval[1] + val[1]) + (G1 - G2)) + } + else { + alpha <- 0 + } + + }}) # End hop and end switch + return(list(y = y, val = val, y2 = y2, val2 = val2, alpha = alpha, + npSel = npSel)) +} + + + + + + + +################## Helper functions +############################################################### + +#' Helper function for sum of x*x +#' @param x vector of values +#' @keywords internal +sumSquare <- function(x){return(sum(x*x))} + + +#' Helper function to create proposal +#' @param case Type of Twalk move. Either "walk", "traverse", "hop" or "blow" +#' @param Npar number of parameters +#' @param pn1 Probability determining the number of parameters that are changed. +#' @param aw "walk" move proposal parameter. +#' @param beta parameter for "traverse" move proposals. +#' @param x parameter vector of chain 1 +#' @param x2 parameter vector of chain 2 +#' @references Christen, J. Andres, and Colin Fox. "A general purpose sampling algorithm for continuous distributions (the t-walk)." Bayesian Analysis 5.2 (2010): 263-281. +#' @keywords internal +propFun <- function(case, Npar, pn1, x, x2, beta = NULL, aw = NULL){ + + switch(case, + "traverse"={ + pSel <- (runif(Npar) < pn1) + prop <- NULL + for (i in 1:Npar){ + if (pSel[i]) prop <- c( prop, x2[i] + beta*(x2[i] - x[i])) + else prop <- c( prop, x[i]) + } + return(list(prop=prop, npSel=sum(pSel))) + }, + "walk"={ + u <- runif(Npar) + pSel <- (runif(Npar) < pn1) + z <- (aw/(1+aw))*(aw*u^2 + 2*u -1) + z <- z*pSel + return(list( prop=x + (x - x2)*z, npSel=sum(pSel))) + }, + "blow"={ + pSel <- (runif(Npar) < pn1) + sigma <- max(pSel*abs(x2 - x)) + return(list( prop=x2*pSel + sigma*rnorm(Npar)*pSel + x*(1-pSel), npSel=sum(pSel), pSel=pSel)) + + }, + "hop"={ + pSel <- (runif(Npar) < pn1) + sigma <- max(pSel*abs(x2 - x))/3 + prop <- NULL + for (i in 1:Npar){ + if (pSel[i]) prop <- c( prop, x[i] + sigma*rnorm(1)) + else prop <- c( prop, x[i]) + } + return(list( prop=prop, npSel=sum(pSel), pSel=pSel)) + + } + + ) +} + + +#' Helper function for calculating beta +#' @param at "traverse" move proposal parameter. +#' @keywords internal +betaFun <- 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)))) +} + + +#' Helper function for blow and hop moves +#' @param case Type of Twalk move. Either "hop" or "blow" +#' @param npSel number of parameters that are changed. +#' @param pSel vector containing information about which parameters are changed. +#' @param h Parameter for "blow" and hop moves +#' @param x parameter vector of chain 1 +#' @param x2 parameter vector of chain 2 +#' @references Christen, J. Andres, and Colin Fox. "A general purpose sampling algorithm for continuous distributions (the t-walk)." Bayesian Analysis 5.2 (2010): 263-281. +#' @keywords internal +Gfun <- function(case, npSel, pSel, h, x, x2){ + switch(case, + "blow"= { + sigma <- max(pSel*abs(x2 - x)) + if(npSel > 0) return((npSel/2)*log(2*pi) + npSel*log(sigma) + 0.5*sumSquare(h - x2)/(sigma^2)) + else return(0) + }, + "hop" = { + sigma <- max(pSel*abs(x2 - x))/3 + if (npSel > 0) return((npSel/2)*log(2*pi) - npSel*log(3) + npSel*log(sigma) + 0.5*9*sumSquare((h - x))/(sigma^2)) + else return(0) + }) + +} + + + From 465036fec98b3e73d22cc90f994da905991f941b Mon Sep 17 00:00:00 2001 From: Tahmina Mojumder Date: Fri, 1 Sep 2023 09:03:27 +0200 Subject: [PATCH 06/13] updated help files for plot files. --- BayesianTools/R/plotCorrelationDensity.r | 178 +++---- BayesianTools/R/plotDiagnostic.R | 502 +++++++++--------- BayesianTools/R/plotMarginals.R | 648 +++++++++++------------ BayesianTools/R/plotSensitivityOAT.R | 114 ++-- BayesianTools/R/plotTrace.R | 26 +- 5 files changed, 734 insertions(+), 734 deletions(-) diff --git a/BayesianTools/R/plotCorrelationDensity.r b/BayesianTools/R/plotCorrelationDensity.r index 9a87d65..9c07bb6 100644 --- a/BayesianTools/R/plotCorrelationDensity.r +++ b/BayesianTools/R/plotCorrelationDensity.r @@ -1,89 +1,89 @@ -#' Flexible function to create correlation density plots -#' @author Florian Hartig -#' @param mat object of class "bayesianOutput" or a matrix or data frame of variables -#' @param density type of plot to do. Either "smooth" (default), "corellipseCor", or "ellipse" -#' @param thin thinning of the matrix to make things faster. Default is to thin to 5000 -#' @param method method for calculating correlations. Possible choices are "pearson" (default), "kendall" and "spearman" -#' @param whichParameters indices of parameters that should be plotted -#' @param scaleCorText should the text to display correlation be scaled to the strength of the correlation -#' @param ... additional parameters to pass on to the \code{\link{getSample}}, for example parametersOnly =F, or start = 1000 -#' @references The code for the correlation density plot originates from Hartig, F.; Dislich, C.; Wiegand, T. & Huth, A. (2014) Technical Note: Approximate Bayesian parameterization of a process-based tropical forest model. Biogeosciences, 11, 1261-1272. -#' @export -#' @seealso \code{\link{marginalPlot}} \cr -#' \code{\link{plotTimeSeries}} \cr -#' \code{\link{tracePlot}} \cr -#' @example /inst/examples/correlationPlotHelp.R - -correlationPlot<- function(mat, density = "smooth", thin = "auto", method = "pearson", whichParameters = NULL, scaleCorText = T, ...){ - - mat = getSample(mat, thin = thin, whichParameters = whichParameters, ...) - - numPars = ncol(mat) - - if(numPars < 2) stop("BayesianTools::correlationPlot - using this function only makes sense if you have more than 1 parameter") - - names = colnames(mat) - - panel.hist.dens <- function(x, ...) - { - usr <- par("usr"); on.exit(par(usr = usr)) - par(usr = c(usr[1:2], 0, 1.5) ) - h <- hist(x, plot = FALSE) - breaks <- h$breaks; nB <- length(breaks) - y <- h$counts; y <- y/max(y) - rect(breaks[-nB], 0, breaks[-1], y, col="blue4", ...) - } - - # replaced by spearman - panel.cor <- function(x, y, digits = 2, prefix = "", cex.cor, ...) - { - usr <- par("usr"); on.exit(par(usr = usr)) - par(usr = c(0, 1, 0, 1)) - r <- cor(x, y, use = "complete.obs", method = method) - txt <- format(c(r, 0.123456789), digits = digits)[1] - txt <- paste0(prefix, txt) - if(missing(cex.cor)) cex.cor <- 0.8/strwidth(txt) - if(scaleCorText == T) text(0.5, 0.5, txt, cex = cex.cor * abs(r)) - else text(0.5, 0.5, txt, cex = cex.cor) - } - - plotEllipse <- function(x,y){ - usr <- par("usr"); on.exit(par(usr = usr)) - par(usr = c(usr[1:2], 0, 1.5) ) - cor <- cor(x,y) - el = ellipse::ellipse(cor) - polygon(el[,1] + mean(x), el[,2] + mean(y), col = "red") - } - - - correlationEllipse <- function(x){ - cor = cor(x) - ToRGB <- function(x){grDevices::rgb(x[1]/255, x[2]/255, x[3]/255)} - C1 <- ToRGB(c(178, 24, 43)) - C2 <- ToRGB(c(214, 96, 77)) - C3 <- ToRGB(c(244, 165, 130)) - C4 <- ToRGB(c(253, 219, 199)) - C5 <- ToRGB(c(247, 247, 247)) - C6 <- ToRGB(c(209, 229, 240)) - C7 <- ToRGB(c(146, 197, 222)) - C8 <- ToRGB(c(67, 147, 195)) - C9 <- ToRGB(c(33, 102, 172)) - CustomPalette <- grDevices::colorRampPalette(rev(c(C1, C2, C3, C4, C5, C6, C7, C8, C9))) - ord <- order(cor[1, ]) - xc <- cor[ord, ord] - colors <- unlist(CustomPalette(100)) - ellipse::plotcorr(xc, col=colors[xc * 50 + 50]) - } - - if (density == "smooth"){ - return(pairs(mat, lower.panel=function(...) {par(new=TRUE);IDPmisc::ipanel.smooth(...)}, diag.panel=panel.hist.dens, upper.panel=panel.cor)) - }else if (density == "corellipseCor"){ - return(pairs(mat, lower.panel=plotEllipse, diag.panel=panel.hist.dens, upper.panel=panel.cor)) - }else if (density == "ellipse"){ - correlationEllipse(mat) - }else if (density == F){ - return(pairs(mat, lower.panel=panel.cor, diag.panel=panel.hist.dens, upper.panel=panel.cor)) - }else stop("wrong sensity argument") - -} - +#' Flexible function to create correlation density plots +#' @author Florian Hartig +#' @param mat object of class "bayesianOutput" or a matrix or data frame of variables +#' @param density type of plot to do. Either "smooth" (default), "corellipseCor", or "ellipse" +#' @param thin thinning of the matrix to make things faster. Default is to thin to 5000 +#' @param method method for calculating correlations. Possible choices are "pearson" (default), "kendall" and "spearman" +#' @param whichParameters indices of parameters that should be plotted +#' @param scaleCorText should the text to display correlation be scaled to the strength of the correlation? +#' @param ... additional parameters to pass on to the \code{\link{getSample}}, for example parametersOnly = F, or start = 1000 +#' @references The code for the correlation density plot originates from Hartig, F.; Dislich, C.; Wiegand, T. & Huth, A. (2014) Technical Note: Approximate Bayesian parameterization of a process-based tropical forest model. Biogeosciences, 11, 1261-1272. +#' @export +#' @seealso \code{\link{marginalPlot}} \cr +#' \code{\link{plotTimeSeries}} \cr +#' \code{\link{tracePlot}} \cr +#' @example /inst/examples/correlationPlotHelp.R + +correlationPlot<- function(mat, density = "smooth", thin = "auto", method = "pearson", whichParameters = NULL, scaleCorText = T, ...){ + + mat = getSample(mat, thin = thin, whichParameters = whichParameters, ...) + + numPars = ncol(mat) + + if(numPars < 2) stop("BayesianTools::correlationPlot - using this function only makes sense if you have more than 1 parameter") + + names = colnames(mat) + + panel.hist.dens <- function(x, ...) + { + usr <- par("usr"); on.exit(par(usr = usr)) + par(usr = c(usr[1:2], 0, 1.5) ) + h <- hist(x, plot = FALSE) + breaks <- h$breaks; nB <- length(breaks) + y <- h$counts; y <- y/max(y) + rect(breaks[-nB], 0, breaks[-1], y, col="blue4", ...) + } + + # replaced by spearman + panel.cor <- function(x, y, digits = 2, prefix = "", cex.cor, ...) + { + usr <- par("usr"); on.exit(par(usr = usr)) + par(usr = c(0, 1, 0, 1)) + r <- cor(x, y, use = "complete.obs", method = method) + txt <- format(c(r, 0.123456789), digits = digits)[1] + txt <- paste0(prefix, txt) + if(missing(cex.cor)) cex.cor <- 0.8/strwidth(txt) + if(scaleCorText == T) text(0.5, 0.5, txt, cex = cex.cor * abs(r)) + else text(0.5, 0.5, txt, cex = cex.cor) + } + + plotEllipse <- function(x,y){ + usr <- par("usr"); on.exit(par(usr = usr)) + par(usr = c(usr[1:2], 0, 1.5) ) + cor <- cor(x,y) + el = ellipse::ellipse(cor) + polygon(el[,1] + mean(x), el[,2] + mean(y), col = "red") + } + + + correlationEllipse <- function(x){ + cor = cor(x) + ToRGB <- function(x){grDevices::rgb(x[1]/255, x[2]/255, x[3]/255)} + C1 <- ToRGB(c(178, 24, 43)) + C2 <- ToRGB(c(214, 96, 77)) + C3 <- ToRGB(c(244, 165, 130)) + C4 <- ToRGB(c(253, 219, 199)) + C5 <- ToRGB(c(247, 247, 247)) + C6 <- ToRGB(c(209, 229, 240)) + C7 <- ToRGB(c(146, 197, 222)) + C8 <- ToRGB(c(67, 147, 195)) + C9 <- ToRGB(c(33, 102, 172)) + CustomPalette <- grDevices::colorRampPalette(rev(c(C1, C2, C3, C4, C5, C6, C7, C8, C9))) + ord <- order(cor[1, ]) + xc <- cor[ord, ord] + colors <- unlist(CustomPalette(100)) + ellipse::plotcorr(xc, col=colors[xc * 50 + 50]) + } + + if (density == "smooth"){ + return(pairs(mat, lower.panel=function(...) {par(new=TRUE);IDPmisc::ipanel.smooth(...)}, diag.panel=panel.hist.dens, upper.panel=panel.cor)) + }else if (density == "corellipseCor"){ + return(pairs(mat, lower.panel=plotEllipse, diag.panel=panel.hist.dens, upper.panel=panel.cor)) + }else if (density == "ellipse"){ + correlationEllipse(mat) + }else if (density == F){ + return(pairs(mat, lower.panel=panel.cor, diag.panel=panel.hist.dens, upper.panel=panel.cor)) + }else stop("wrong sensity argument") + +} + diff --git a/BayesianTools/R/plotDiagnostic.R b/BayesianTools/R/plotDiagnostic.R index 6178c14..27caf6a 100644 --- a/BayesianTools/R/plotDiagnostic.R +++ b/BayesianTools/R/plotDiagnostic.R @@ -1,251 +1,251 @@ -#' @author Maximilian Pichler -#' @title Diagnostic Plot -#' @description This function plots the DIC, WAIC, mPSRF, PSRF(with upper C.I.) and traces of the parameters in dependence of iterations. DIC, WAIC are plotted separately for the chains and the trace plots also for the internal chains. -#' @param out object of class "bayesianOutput" -#' @param start start value for calculating DIC, WAIC, mPSRF and PSRF, default = 50 -#' @param numSamples for calculating WAIC, default = 10 because of high computational costs -#' @param window plot range to show, vector of percents or only one value as start value for the window -#' @param plotWAIC whether to calculate WAIC or not, default = T -#' @param plotPSRF calculate and plot mPSRF/PSRF or not, default = T -#' @param plotDIC calculate and plot DICor not, default = T -#' @param plotTrace show trace plots or not, default = T -#' @param graphicParameters graphic parameters as list for plot function -#' @param ... parameters to give to getSample -#' @example /inst/examples/plotDiagnosticHelp.R -#' @export - - - -plotDiagnostic <- function(out, start = 50, numSamples = 100, window = 0.2, plotWAIC = F, plotPSRF = T, plotDIC = T, plotTrace = T, graphicParameters = NULL, ...){ - - oldpar = NULL - on.exit(par(oldpar)) - - - - if(!"bayesianOutput" %in% class(out)) stop("Wrong input, object of class bayesianOutput required. see runMCMC()") - - calcWAIC <- TRUE - - if("mcmcSamplerList" %in% class(out) && out[[1]]$setup$pwLikelihood) calcWAIC <- FALSE - - if("mcmcSampler" %in% class(out) && out$setup$pwLikelihood) calcWAIC <- FALSE - - if(!plotWAIC) calcWAIC <- FALSE - - - defaultGraphicParameters <- graphicParameters - - - # calculate DIC and WAIC, minimum range: start - start+1 - if("mcmcSamplerList" %in% class(out)){ - - if(is.matrix(out[[1]]$chain)) len <- out[[1]]$settings$iterations - else len <- round(out[[1]]$settings$iterations / length(out[[1]]$chain)) - - iter = out[[1]]$settings$iterations - - internal = length(out[[1]]$chain) - - start = start + 1 - - lenW <- length(seq(start , by = 10, to = len)) - - DICResult <- matrix(NA, nrow = length(out), ncol = len - start) - - WAICResult<- matrix(NA, nrow = length(out), ncol = length(seq(start , by = 10, to = len))) - - numPars <- out[[1]]$setup$numPars - - Wseq <- seq(start , by = 10, to = len) - - for(i in 1:length(out)) { - if(plotDIC) DICResult[i,] <- sapply(start:len, FUN = function(x){return(DIC(out[[i]], start = start - 1 , end = x, ...)$DIC)}) - if(calcWAIC) WAICResult[i,] <- sapply(seq(start , by = 10, to = len), FUN = function(x){return(WAIC(out[[i]], start = start - 1 ,end = x, numSamples = numSamples, ...)$WAIC1)}) - } - - } else { - if(is.matrix(out$chain)) len <- out$settings$iterations - - else len <- round(out$settings$iterations / length(out$chain)) - - internal = length(out$chain) - - iter = out$settings$iterations - - start = start + 1 - - lenW<- length(seq(start, by = 10, to = len)) - - Wseq <- seq(start , by = 10, to = len) - - if(plotDIC) DICResult <- sapply(start:len, FUN = function(x){return(DIC(out, start = start - 1, end = x, ...)$DIC)}) - - if(calcWAIC) WAICResult<- sapply(seq(start, by = 10, to = len), FUN = function(x){return(WAIC(out, end = x, start = start - 1, numSamples = numSamples, ...)$WAIC1)}) - - numPars <- out$setup$numPars - } - - # TODO: missing: check if sampler with multiple chains - # should user call method with plotPSFR=F for one-chain-sampler? - - # calc mPSRF, first checking which low values we could calculate - if(plotPSRF){ - - seq <- vector() - for(i in start:len){ - success <- try(coda::gelman.diag(getSample(out, start = start - 1, parametersOnly = T, coda = T, end = i, ...))$mpsrf, silent = T) - if(!"try-error" %in% class(success)){ - # break - seq[i] <- i - } - } - seq <- seq[complete.cases(seq)] - - # calculate the actual PSRF values - if(numPars > 1) PSRF <- matrix(0, nrow = length(seq), ncol = numPars*2 + 1) - else PSRF <- matrix(0, nrow = length(seq), ncol = numPars*2 ) - - for(i in 1:length(seq)){ - res <- coda::gelman.diag(getSample(out, start = start - 1, parametersOnly = T, coda = T, end = seq[i], ...)) - if(numPars > 1)PSRF[i,] <- c(as.vector(res$psrf), res$mpsrf) - else PSRF[i,] <- c(as.vector(res$psrf)) - } - } - - - # Get number of plots - nrPlots <- 2 - if(calcWAIC) nrPlots <- nrPlots + 1 - if(plotDIC) nrPlots <- nrPlots + 1 - if(plotPSRF) nrPlots <- nrPlots + 2 - if(plotTrace) nrPlots<- numPars*2 + nrPlots - par(mfrow = getPanels(nrPlots)) - - - - - # set graphicParameters - if(is.null(graphicParameters)){ - graphicParameters = list(lty = 1, lwd = 1, type = "l", xlab = "Iterations", ylab = "", col = 1:6) - } else { - if(is.null(graphicParameters$lty)) graphicParameters$lty = 1 - if(is.null(graphicParameters$lwd)) graphicParameters$lwd = 1 - if(is.null(graphicParameters$type)) graphicParameters$type = "l" - if(is.null(graphicParameters$xlab)) graphicParameters$xlab = "Iterations" - if(is.null(graphicParameters$ylab)) graphicParameters$ylab = "" - if(is.null(graphicParameters$col)) graphicParameters$col = 1:6 - } - - - - # plot DIC - if(plotDIC){ - - - if(is.matrix(DICResult)){ - # col <- 1:ncol(DICResult) - if(is.na(window[2])) endV <- nrow(DICResult) - else endV <- window[2]*nrow(DICResult) - startV <- window[1]*nrow(DICResult) - x = nrow(DICResult) - ylim = c(min(DICResult[startV:endV,])*0.99, max(DICResult[startV:endV,])*1.01) - } else { - if(is.na(window[2])) endV <- length(DICResult) - else endV <- window[2]*length(DICResult) - startV <- window[1]*length(DICResult) - x = length(DICResult) - ylim = c(min(DICResult[startV:endV])*0.99, max(DICResult[startV:endV])*1.01) - } - graphicParameters$y = DICResult - graphicParameters$x = 1:x - graphicParameters$main = "DIC" - graphicParameters$xlim = c(startV, endV) - graphicParameters$ylim = ylim - if(is.null(graphicParameters$xaxt)) graphicParameters$xaxt = "n" - do.call(matplot, graphicParameters) - if(graphicParameters$xaxt == "n" ){ - axis(1, at = seq(startV, by = 100, to = endV), labels = seq(startV, by = 100, to = endV)*internal) - graphicParameters$xaxt <- NULL - } - } - - - # plot WAIC - if(calcWAIC){ - if(is.matrix(WAICResult)){ - # col <- 1:ncol(DICResult) - if(is.na(window[2])) endV <- nrow(WAICResult) - else endV <- window[2]*nrow(WAICResult) - startV <- window[1]*nrow(WAICResult) - x = nrow(WAICResult) - ylim = c(min(WAICResult[startV:endV,])*0.99, max(WAICResult[startV:endV,])*1.01) - } else { - if(is.na(window[2])) endV <- length(WAICResult) - else endV <- window[2]*length(WAICResult) - startV <- window[1]*length(WAICResult) - x = length(WAICResult) - ylim = c(min(WAICResult[startV:endV])*0.99, max(WAICResult[startV:endV])*1.01) - } - graphicParameters$y = WAICResult - graphicParameters$x = 1:x - graphicParameters$main = "WAIC" - graphicParameters$xlim = c(startV, endV) - graphicParameters$ylim = ylim - if(is.null(graphicParameters$xaxt)) graphicParameters$xaxt = "n" - do.call(matplot, graphicParameters) - if(graphicParameters$xaxt == "n" ){ - axis(1, at = seq(startV, by = 10, to = endV), labels = seq(startV, by = 10, to = endV)*10*internal) - graphicParameters$xaxt <- NULL - } - - } - - - if(plotPSRF){ - if(is.na(window[2])) endV <- nrow(PSRF) - else endV <- window[2]*nrow(PSRF) - startV <- window[1]*nrow(PSRF) - graphicParameters$xlim = c(startV, endV) - graphicParameters$x = 1:nrow(PSRF) - # plot mPSRF - if(numPars > 1){ - if(!typeof(seq) == "logical" ) { - - graphicParameters$ylim = c(min(PSRF[startV:endV,ncol(PSRF)])*0.99, max(PSRF[startV:endV,ncol(PSRF)])*1.01) - graphicParameters$y = PSRF[,ncol(PSRF)] - graphicParameters$main = "mPSRF" - do.call(plot, graphicParameters) - } - } - - graphicParameters$ylim = c(min(PSRF[startV:endV,-ncol(PSRF)])*0.99, max(PSRF[startV:endV,-ncol(PSRF)])*1.01) - graphicParameters$y = PSRF[,-ncol(PSRF)] - graphicParameters$main = "PSRF" - - lty = NULL - for(i in 1:numPars)lty <- c(lty, c(1,2)) - graphicParameters$lty <- lty - - col = NULL - for(i in 1:6)col <- c(col, c(i,i)) - graphicParameters$col <- col - - do.call(matplot, graphicParameters) - - } - # plot parameter traces - if(plotTrace){ - # if(is.null(defaultGraphicParameters)) defaultGraphicParameters <- list() - # if(is.na(window[2])) endV <- len - # else endV <- window[2]*len - # defaultGraphicParameters$xlim <- c(len*window[1], endV) - # defaultGraphicParameters$ask = F - # defaultGraphicParameters$auto.layout = F - # defaultGraphicParameters$x = getSample(out, start = start, coda = T, parametersOnly = T,...) - # do.call(coda::cumuplot, defaultGraphicParameters) - - coda::cumuplot(getSample(out, start = start, coda = T, parametersOnly = T, ...), ask = F, auto.layout = F) - } -} - +#' @author Maximilian Pichler +#' @title Diagnostic Plot +#' @description This function plots the DIC, WAIC, mPSRF, PSRF(with upper C.I.) and traces of the parameters in dependence of iterations. DIC, WAIC are plotted separately for the chains and the trace plots also for the internal chains. +#' @param out object of class "bayesianOutput" +#' @param start start value for calculating DIC, WAIC, mPSRF and PSRF, default = 50 +#' @param numSamples for calculating WAIC, default = 10 because of high computational costs +#' @param window plot range to show, vector of percents or only one value as start value for the window +#' @param plotWAIC logical, whether to calculate WAIC or not, default = T +#' @param plotPSRF logical, whether to calculate and plot mPSRF/PSRF or not, default = T +#' @param plotDIC logical, whether to calculate and plot DIC or not, default = T +#' @param plotTrace logical, whether to show trace plots or not, default = T +#' @param graphicParameters graphic parameters as list for plot function +#' @param ... parameters to give to getSample +#' @example /inst/examples/plotDiagnosticHelp.R +#' @export + + + +plotDiagnostic <- function(out, start = 50, numSamples = 100, window = 0.2, plotWAIC = F, plotPSRF = T, plotDIC = T, plotTrace = T, graphicParameters = NULL, ...){ + + oldpar = NULL + on.exit(par(oldpar)) + + + + if(!"bayesianOutput" %in% class(out)) stop("Wrong input, object of class bayesianOutput required. see runMCMC()") + + calcWAIC <- TRUE + + if("mcmcSamplerList" %in% class(out) && out[[1]]$setup$pwLikelihood) calcWAIC <- FALSE + + if("mcmcSampler" %in% class(out) && out$setup$pwLikelihood) calcWAIC <- FALSE + + if(!plotWAIC) calcWAIC <- FALSE + + + defaultGraphicParameters <- graphicParameters + + + # calculate DIC and WAIC, minimum range: start - start+1 + if("mcmcSamplerList" %in% class(out)){ + + if(is.matrix(out[[1]]$chain)) len <- out[[1]]$settings$iterations + else len <- round(out[[1]]$settings$iterations / length(out[[1]]$chain)) + + iter = out[[1]]$settings$iterations + + internal = length(out[[1]]$chain) + + start = start + 1 + + lenW <- length(seq(start , by = 10, to = len)) + + DICResult <- matrix(NA, nrow = length(out), ncol = len - start) + + WAICResult<- matrix(NA, nrow = length(out), ncol = length(seq(start , by = 10, to = len))) + + numPars <- out[[1]]$setup$numPars + + Wseq <- seq(start , by = 10, to = len) + + for(i in 1:length(out)) { + if(plotDIC) DICResult[i,] <- sapply(start:len, FUN = function(x){return(DIC(out[[i]], start = start - 1 , end = x, ...)$DIC)}) + if(calcWAIC) WAICResult[i,] <- sapply(seq(start , by = 10, to = len), FUN = function(x){return(WAIC(out[[i]], start = start - 1 ,end = x, numSamples = numSamples, ...)$WAIC1)}) + } + + } else { + if(is.matrix(out$chain)) len <- out$settings$iterations + + else len <- round(out$settings$iterations / length(out$chain)) + + internal = length(out$chain) + + iter = out$settings$iterations + + start = start + 1 + + lenW<- length(seq(start, by = 10, to = len)) + + Wseq <- seq(start , by = 10, to = len) + + if(plotDIC) DICResult <- sapply(start:len, FUN = function(x){return(DIC(out, start = start - 1, end = x, ...)$DIC)}) + + if(calcWAIC) WAICResult<- sapply(seq(start, by = 10, to = len), FUN = function(x){return(WAIC(out, end = x, start = start - 1, numSamples = numSamples, ...)$WAIC1)}) + + numPars <- out$setup$numPars + } + + # TODO: missing: check if sampler with multiple chains + # should user call method with plotPSFR=F for one-chain-sampler? + + # calc mPSRF, first checking which low values we could calculate + if(plotPSRF){ + + seq <- vector() + for(i in start:len){ + success <- try(coda::gelman.diag(getSample(out, start = start - 1, parametersOnly = T, coda = T, end = i, ...))$mpsrf, silent = T) + if(!"try-error" %in% class(success)){ + # break + seq[i] <- i + } + } + seq <- seq[complete.cases(seq)] + + # calculate the actual PSRF values + if(numPars > 1) PSRF <- matrix(0, nrow = length(seq), ncol = numPars*2 + 1) + else PSRF <- matrix(0, nrow = length(seq), ncol = numPars*2 ) + + for(i in 1:length(seq)){ + res <- coda::gelman.diag(getSample(out, start = start - 1, parametersOnly = T, coda = T, end = seq[i], ...)) + if(numPars > 1)PSRF[i,] <- c(as.vector(res$psrf), res$mpsrf) + else PSRF[i,] <- c(as.vector(res$psrf)) + } + } + + + # Get number of plots + nrPlots <- 2 + if(calcWAIC) nrPlots <- nrPlots + 1 + if(plotDIC) nrPlots <- nrPlots + 1 + if(plotPSRF) nrPlots <- nrPlots + 2 + if(plotTrace) nrPlots<- numPars*2 + nrPlots + par(mfrow = getPanels(nrPlots)) + + + + + # set graphicParameters + if(is.null(graphicParameters)){ + graphicParameters = list(lty = 1, lwd = 1, type = "l", xlab = "Iterations", ylab = "", col = 1:6) + } else { + if(is.null(graphicParameters$lty)) graphicParameters$lty = 1 + if(is.null(graphicParameters$lwd)) graphicParameters$lwd = 1 + if(is.null(graphicParameters$type)) graphicParameters$type = "l" + if(is.null(graphicParameters$xlab)) graphicParameters$xlab = "Iterations" + if(is.null(graphicParameters$ylab)) graphicParameters$ylab = "" + if(is.null(graphicParameters$col)) graphicParameters$col = 1:6 + } + + + + # plot DIC + if(plotDIC){ + + + if(is.matrix(DICResult)){ + # col <- 1:ncol(DICResult) + if(is.na(window[2])) endV <- nrow(DICResult) + else endV <- window[2]*nrow(DICResult) + startV <- window[1]*nrow(DICResult) + x = nrow(DICResult) + ylim = c(min(DICResult[startV:endV,])*0.99, max(DICResult[startV:endV,])*1.01) + } else { + if(is.na(window[2])) endV <- length(DICResult) + else endV <- window[2]*length(DICResult) + startV <- window[1]*length(DICResult) + x = length(DICResult) + ylim = c(min(DICResult[startV:endV])*0.99, max(DICResult[startV:endV])*1.01) + } + graphicParameters$y = DICResult + graphicParameters$x = 1:x + graphicParameters$main = "DIC" + graphicParameters$xlim = c(startV, endV) + graphicParameters$ylim = ylim + if(is.null(graphicParameters$xaxt)) graphicParameters$xaxt = "n" + do.call(matplot, graphicParameters) + if(graphicParameters$xaxt == "n" ){ + axis(1, at = seq(startV, by = 100, to = endV), labels = seq(startV, by = 100, to = endV)*internal) + graphicParameters$xaxt <- NULL + } + } + + + # plot WAIC + if(calcWAIC){ + if(is.matrix(WAICResult)){ + # col <- 1:ncol(DICResult) + if(is.na(window[2])) endV <- nrow(WAICResult) + else endV <- window[2]*nrow(WAICResult) + startV <- window[1]*nrow(WAICResult) + x = nrow(WAICResult) + ylim = c(min(WAICResult[startV:endV,])*0.99, max(WAICResult[startV:endV,])*1.01) + } else { + if(is.na(window[2])) endV <- length(WAICResult) + else endV <- window[2]*length(WAICResult) + startV <- window[1]*length(WAICResult) + x = length(WAICResult) + ylim = c(min(WAICResult[startV:endV])*0.99, max(WAICResult[startV:endV])*1.01) + } + graphicParameters$y = WAICResult + graphicParameters$x = 1:x + graphicParameters$main = "WAIC" + graphicParameters$xlim = c(startV, endV) + graphicParameters$ylim = ylim + if(is.null(graphicParameters$xaxt)) graphicParameters$xaxt = "n" + do.call(matplot, graphicParameters) + if(graphicParameters$xaxt == "n" ){ + axis(1, at = seq(startV, by = 10, to = endV), labels = seq(startV, by = 10, to = endV)*10*internal) + graphicParameters$xaxt <- NULL + } + + } + + + if(plotPSRF){ + if(is.na(window[2])) endV <- nrow(PSRF) + else endV <- window[2]*nrow(PSRF) + startV <- window[1]*nrow(PSRF) + graphicParameters$xlim = c(startV, endV) + graphicParameters$x = 1:nrow(PSRF) + # plot mPSRF + if(numPars > 1){ + if(!typeof(seq) == "logical" ) { + + graphicParameters$ylim = c(min(PSRF[startV:endV,ncol(PSRF)])*0.99, max(PSRF[startV:endV,ncol(PSRF)])*1.01) + graphicParameters$y = PSRF[,ncol(PSRF)] + graphicParameters$main = "mPSRF" + do.call(plot, graphicParameters) + } + } + + graphicParameters$ylim = c(min(PSRF[startV:endV,-ncol(PSRF)])*0.99, max(PSRF[startV:endV,-ncol(PSRF)])*1.01) + graphicParameters$y = PSRF[,-ncol(PSRF)] + graphicParameters$main = "PSRF" + + lty = NULL + for(i in 1:numPars)lty <- c(lty, c(1,2)) + graphicParameters$lty <- lty + + col = NULL + for(i in 1:6)col <- c(col, c(i,i)) + graphicParameters$col <- col + + do.call(matplot, graphicParameters) + + } + # plot parameter traces + if(plotTrace){ + # if(is.null(defaultGraphicParameters)) defaultGraphicParameters <- list() + # if(is.na(window[2])) endV <- len + # else endV <- window[2]*len + # defaultGraphicParameters$xlim <- c(len*window[1], endV) + # defaultGraphicParameters$ask = F + # defaultGraphicParameters$auto.layout = F + # defaultGraphicParameters$x = getSample(out, start = start, coda = T, parametersOnly = T,...) + # do.call(coda::cumuplot, defaultGraphicParameters) + + coda::cumuplot(getSample(out, start = start, coda = T, parametersOnly = T, ...), ask = F, auto.layout = F) + } +} + diff --git a/BayesianTools/R/plotMarginals.R b/BayesianTools/R/plotMarginals.R index b962779..d58359e 100644 --- a/BayesianTools/R/plotMarginals.R +++ b/BayesianTools/R/plotMarginals.R @@ -1,324 +1,324 @@ -#' @export -marginalPlot <- function(x, ...) UseMethod("marginalPlot") - -#' Plot MCMC marginals -#' @param x bayesianOutput, or matrix or data.frame containing with samples as rows and parameters as columns -#' @param prior if x is a bayesianOutput, T/F will determine if the prior is drawn (default = T). If x is matrix oder data.frame, a prior can be drawn if a matrix of prior draws with values as rows and parameters as columns can be provided here. -#' @param xrange vector or matrix of plotting ranges for the x axis. If matrix, the rows must be parameters and the columns min and max values. -#' @param type character determining the plot type. Either 'd' for density plot, or 'v' for violin plot -#' @param singlePanel logical, determining whether the parameter should be plotted in a single panel or each in its own panel -#' @param settings optional list of additional settings for \code{\link{marginalPlotDensity}}, and \code{\link{marginalPlotViolin}}, respectively -#' @param nPriorDraws number of draws from the prior, if x is bayesianOutput -#' @param ... additional arguments passed to \code{\link{getSample}}. If you have a high number of draws from the posterior it is advised to set numSamples (to e.g. 5000) for performance reasons. -#' @example /inst/examples/marginalPlotHelp.R -#' @author Tankred Ott, Florian Hartig -marginalPlot <- function(x, prior = NULL, xrange = NULL, type = 'd', singlePanel = FALSE, settings = NULL, - nPriorDraws = 10000, ...) { - - posteriorMat <- getSample(x, parametersOnly = TRUE, ...) - - # checking for which - args <- list(...) - if("which" %in% names(args)) - which = args$which - else - which = 1:ncol(posteriorMat) - - # check prior - if ('bayesianOutput' %in% class(x)) { - - # default T if NULL and BayesianOutput provide - if (is.null(prior)) prior = TRUE - - if (any(c('data.frame', 'matrix') %in% class(prior))) priorMat = prior - else if (is.logical(prior)){ - if (prior == TRUE) priorMat = getSetup(x)$prior$sampler(nPriorDraws) # draw prior from bayesianSetup - else if (prior == F) priorMat = NULL - } - else stop('wrong argument to prior') - } else { - - # default F - if (is.null(prior)) prior = FALSE - - if (any(c('data.frame', 'matrix') %in% class(prior))) priorMat = prior - else if (is.logical(prior)){ - priorMat = NULL - if (prior == TRUE) message("prior = T will only have an effect if x is of class BayesianOutput") - } - else stop('wrong argument to prior') - } - - if (!is.null(priorMat)) { - priorMat = priorMat[,which,drop=F] - if (ncol(posteriorMat) != ncol(priorMat)) stop("wrong dimensions of prior") - colnames(priorMat) <- colnames(posteriorMat) - } - - nPar <- ncol(posteriorMat) - - # check xrange - if (!is.null(xrange)) { - if (!any(c('numeric', 'matrix') %in% class(xrange))) stop('xrange must be numeric or matrix, or NULL') - if ('numeric' %in% class(xrange)) xrange <- matrix(rep(xrange), nPar, nrow = 2) - else if ('matrix' %in% class(xrange)) { - if (ncol(xrange) != ncol(posteriorMat)) stop('xrange must have as many colums as there are parameterss') - else if (nrow(xrange) != 2) stop('xrange must have two rows (min, max)') - } - } else { - posteriorRanges <- apply(posteriorMat, 2, range) - priorRanges <- if(!is.null(priorMat)) apply(priorMat, 2, range) else NULL - - xrange <- if (is.null(priorRanges)) posteriorRanges else apply(rbind(priorRanges, posteriorRanges), 2, range) - } - - # check type - if (any(c('d', 'dens', 'density') == type)) type <- 'd' - # else if (any(c('h', 'hist', 'histogram') == type)) type <- 'h' - else if (any(c('v', 'violin') == type)) type <- 'v' - # else stop('type must be one of "d", "h", "v"') - else stop('type must be one of "d", "v"') - - # check parameter names - if (is.null(colnames(posteriorMat))) colnames(posteriorMat) <- paste('par', 1:nPar, sep = '') - if (!is.null(priorMat)) colnames(priorMat) <- colnames(posteriorMat) - - # prepare arguments for sub-functions - .args <- c(list(posteriorMat = posteriorMat, priorMat = priorMat, xrange = xrange, singlePanel = singlePanel), - settings) - - if (type == 'd') do.call(marginalPlotDensity, .args) - # else if (type == 'h') do.call(marginalPlotHistogram, .args) - else if (type == 'v') do.call(marginalPlotViolin, .args) -} - - -#' Plot marginals as densities -#' @param posteriorMat matrix with samples as rows and parameters as columns -#' @param priorMat matrix (optional) with samples as rows and parameters as columns -#' @param xrange vector or matrix (optional), determining the plotting range, with parameters as columns and min, max as rows -#' @param col vector of colors for posterior and -#' @param singlePanel logical, determining whether the parameter should be plotted in a single panel or each in its own panel -# #' @param ... further options -#' @author Tankred Ott -#' @keywords internal -# TODO: this could be simplified. It is verbose for now to be able to change stuff easily -marginalPlotDensity <- function(posteriorMat, priorMat = NULL, xrange = NULL, col=c('#FC006299','#00BBAA30'), - singlePanel = TRUE, ...) { - - nPar <- ncol(posteriorMat) - parNames <- colnames(posteriorMat) - - if (is.null(xrange)) { - posteriorRanges <- apply(posteriorMat, 2, range) - priorRanges <- if(!is.null(priorMat)) apply(priorMat, 2, range) else NULL - - xrange <- if (is.null(priorRanges)) posteriorRanges else apply(rbind(priorRanges, posteriorRanges), 2, range) - } - - posteriorDensities <- lapply(1:ncol(posteriorMat), - function(i) density(posteriorMat[,i], from = xrange[1,i], to = xrange[2,i], ...)) - priorDensities <- if (!is.null(priorMat)) lapply(1:ncol(priorMat), - function(i) density(priorMat[,i], from = xrange[1,i], to = xrange[2,i], ...)) - else NULL - - postXY <- lapply(posteriorDensities, function(d) { - xy <- cbind(c(d$x[1], d$x, d$x[length(d$x)]), - c(0, d$y, 0)) - colnames(xy) <- c('x', 'y') - xy - }) - - priorXY <- if (!is.null(priorDensities)) lapply(priorDensities, function(d) { - xy <- cbind(c(d$x[1], d$x, d$x[length(d$x)]), - c(0, d$y, 0)) - colnames(xy) <- c('x', 'y') - xy - }) else NULL - - - if (singlePanel) { - op <- par(mfrow = c(nPar,1), mar = c(2, 5, 2, 2), oma = c(5, 4, 4, 0)) - on.exit(par(op)) - - - for (i in 1:length(posteriorDensities)) { - postX <- postXY[[i]][,1] - postY <- postXY[[i]][,2] - - priorX <- if (!is.null(priorXY[[i]])) priorXY[[i]][,1] else NULL - priorY <- if (!is.null(priorXY[[i]])) priorXY[[i]][,2] else NULL - - yrange <- if (is.null(priorX)) range(postY) else range(c(postY, priorY)) - - plot(NULL, NULL, xlim = xrange[,i], ylim = yrange, main = NA, - xlab = NA, ylab = NA, bty = 'n', yaxt = 'n', xaxt = 'n') - axis(1, at = xrange[,i], labels = NA, lwd.ticks=0) - xticks <- axTicks(1) - xticks <- xticks[xticks >= xrange[1,i] & xticks <= xrange[2,i]] - - axis(1, at = xticks) - - mtext(sprintf('%20s', parNames[i]), 2, las = 1, adj = 1.25) - - - polygon(postX, postY, col = col[1], border = 1) - if (!is.null(priorX)) polygon(priorX, priorY, col = col[2], border = 1) - - } - - mtext('Marginal parameter uncertainty', outer = TRUE, cex = 1.5) - - } else { - mfrow <- if (nPar < 16) getPanels(nPar) else c(4,4) - - op <- par(mfrow = mfrow, mar = c(4.5, 4, 5, 3), oma=c(3, 1.5, 2, 0), xpd=TRUE) - on.exit(par(op)) - - for (i in 1:length(posteriorDensities)) { - postX <- postXY[[i]][,1] - postY <- postXY[[i]][,2] - - priorX <- if (!is.null(priorXY[[i]])) priorXY[[i]][,1] else NULL - priorY <- if (!is.null(priorXY[[i]])) priorXY[[i]][,2] else NULL - - yrange <- if (is.null(priorX)) range(postY) else range(c(postY, priorY)) - - plot(NULL, NULL, xlim = xrange[,i], ylim = yrange, main = parNames[i], - xlab = NA, ylab = 'density') - - polygon(postX, postY, col = col[1], border = 1) - if (!is.null(priorX)) polygon(priorX, priorY, col = col[2], border = 1) - - if (i %% 16 == 1) mtext('Marginal parameter uncertainty', outer = TRUE, cex = 1.5) - } - } - - # overlay plot with empty plot to be able to place the legends freely - par(fig = c(0, 1, 0, 1), oma = c(0, 0, 0, 0), mar = c(0, 0, 0, 0), new = TRUE) - plot(0, 0, type = 'n', bty = 'n', xaxt = 'n', yaxt = 'n') - - legend('bottom', if (!is.null(priorX)) c('posterior', 'prior') else 'posterior', xpd = TRUE, horiz = TRUE, inset = c(0, 0), - bty = 'n', pch = 15, col = col, cex = 1.5) -} - - -#' Plot marginals as violin plot -#' @param posteriorMat matrix with samples as rows and parameters as columns -#' @param priorMat matrix (optional) with samples as rows and parameters as columns -#' @param xrange vector or matrix (optional), determining the plotting range, with parameters as columns and min, max as rows -#' @param col vector of colors for posterior and -#' @param singlePanel logical, determining whether the parameter should be plotted in a single panel or each in its own panel -# #' @param ... further options -#' @author Tankred Ott -#' @keywords internal -# TODO: this could be simplified. It is verbose for now to be able to change stuff easily -marginalPlotViolin <- function(posteriorMat, priorMat = NULL, xrange = NULL, col=c('#FC006299','#00BBAA88'), - singlePanel = TRUE, ...) { - - nPar <- ncol(posteriorMat) - parNames <- colnames(posteriorMat) - - if (is.null(xrange)) { - posteriorRanges <- apply(posteriorMat, 2, range) - priorRanges <- if(!is.null(priorMat)) apply(priorMat, 2, range) else NULL - - xrange <- if (is.null(priorRanges)) posteriorRanges else apply(rbind(priorRanges, posteriorRanges), 2, range) - } - - posteriorDensities <- lapply(1:ncol(posteriorMat), - function(i) density(posteriorMat[,i], from = xrange[1,i], to = xrange[2,i], ...)) - priorDensities <- if (!is.null(priorMat)) lapply(1:ncol(priorMat), - function(i) density(priorMat[,i], from = xrange[1,i], to = xrange[2,i], ...)) - else NULL - - - postXY <- lapply(posteriorDensities, function(d) { - xy <- cbind(c(d$x[1], d$x, d$x[length(d$x)]), - c(0, d$y, 0)) - colnames(xy) <- c('x', 'y') - if (is.null(priorDensities)) xy <- rbind(xy, - cbind(rev(xy[,1]), rev(-xy[,2]))) - xy - }) - - priorXY <- if (!is.null(priorDensities)) lapply(priorDensities, function(d) { - xy <- cbind(c(d$x[1], d$x, d$x[length(d$x)]), - -c(0, d$y, 0)) - colnames(xy) <- c('x', 'y') - xy - }) else NULL - - - if (singlePanel) { - nChar <- max(nchar(parNames)) - op <- par(mfrow = c(nPar,1), mar = c(2, min(nChar, 20), 2, 2), oma = c(5, 0, 4, 0)) - on.exit(par(op)) - - for (i in 1:length(posteriorDensities)) { - postX <- postXY[[i]][,1] - postY <- postXY[[i]][,2] - - priorX <- if (!is.null(priorXY[[i]])) priorXY[[i]][,1] else NULL - priorY <- if (!is.null(priorXY[[i]])) priorXY[[i]][,2] else NULL - - yrange <- if (is.null(priorX)) range(postY) else range(c(postY, priorY)) - - plot(NULL, NULL, xlim = xrange[,i], ylim = yrange, main = NA, - xlab = NA, ylab = NA, bty = 'n', yaxt = 'n', xaxt = 'n') - - axis(1, at = xrange[,i], labels = NA, lwd.ticks=0) - xticks <- axTicks(1) - xticks <- xticks[xticks >= xrange[1,i] & xticks <= xrange[2,i]] - - axis(1, at = xticks) - mtext(sprintf('%20s', parNames[i]), 2, las = 1, adj = 1) - - polygon(postX, postY, col = col[1], border = 1) - if (!is.null(priorX)) polygon(priorX, priorY, col = col[2], border = 1) - - } - - mtext('Marginal parameter uncertainty', outer = TRUE, cex = 1.5) - - } else { - mfrow <- if (nPar < 16) getPanels(nPar) else c(4,4) - - op <- par(mfrow = mfrow, mar = c(4.5, 4.5, 5, 3), oma=c(3, 0, 2, 0), xpd=TRUE) - - on.exit(par(op)) - for (i in 1:length(posteriorDensities)) { - postX <- postXY[[i]][,1] - postY <- postXY[[i]][,2] - - priorX <- if (!is.null(priorXY[[i]])) priorXY[[i]][,1] else NULL - priorY <- if (!is.null(priorXY[[i]])) priorXY[[i]][,2] else NULL - - yrange <- if (is.null(priorX)) range(postY) else range(c(postY, priorY)) - - plot(NULL, NULL, xlim = xrange[,i], ylim = yrange, main = parNames[i], - xlab = NA, ylab = 'density', yaxt = 'n') - yticks <- sort(c(0, axTicks(2))) - axis(2, at = yticks, labels = abs(yticks)) - - - polygon(postX, postY, col = col[1], border = 1) - if (!is.null(priorX)) polygon(priorX, priorY, col = col[2], border = 1) - - if (i %% 16 == 1) mtext('Marginal parameter uncertainty', outer = TRUE, cex = 1.5) - } - } - - # overlay plot with empty plot to be able to place the legends freely - par(fig = c(0, 1, 0, 1), oma = c(0, 0, 0, 0), mar = c(0, 0, 0, 0), new = TRUE) - plot(0, 0, type = 'n', bty = 'n', xaxt = 'n', yaxt = 'n') - - legend('bottom', if (!is.null(priorX)) c('posterior', 'prior') else 'posterior', xpd = TRUE, horiz = TRUE, - inset = c(0, 0), bty = 'n', pch = 15, col = col, cex = 1.5) -} - -#' #' @keywords internal -#' marginalPlotHistogram <- function(posteriorMat, priorMat = NULL, xrange = NULL, col=c('#FF5000A0','#4682B4A0'), -#' singlePanel = TRUE, breaks = NULL, ...) { -#' -#' } +#' @export +marginalPlot <- function(x, ...) UseMethod("marginalPlot") + +#' Plot MCMC marginals +#' @param x bayesianOutput, or matrix or data.frame with samples as rows and parameters as columns +#' @param prior if x is a bayesianOutput, T/F will determines whether the prior is drawn (default = T). If x is matrix or data.frame, a prior can be drawn if a matrix of prior draws with values as rows and parameters as columns can be provided here. +#' @param xrange vector or matrix of plot ranges for the x-axis. If matrix, the rows must be parameters and the columns must be min and max values. +#' @param type character, determes the plot type. Either 'd' for density plot, or 'v' for violin plot +#' @param singlePanel logical, determines whether the parameter should be plotted in a single panel or each in its own panel +#' @param settings optional, list of additional settings for \code{\link{marginalPlotDensity}}, and \code{\link{marginalPlotViolin}}, respectively +#' @param nPriorDraws number of draws from the prior, if x is bayesianOutput +#' @param ... additional arguments passed to \code{\link{getSample}}. If you have a high number of draws from the posterior it is advised to set numSamples (to e.g. 5000) for performance reasons. +#' @example /inst/examples/marginalPlotHelp.R +#' @author Tankred Ott, Florian Hartig +marginalPlot <- function(x, prior = NULL, xrange = NULL, type = 'd', singlePanel = FALSE, settings = NULL, + nPriorDraws = 10000, ...) { + + posteriorMat <- getSample(x, parametersOnly = TRUE, ...) + + # checking for which + args <- list(...) + if("which" %in% names(args)) + which = args$which + else + which = 1:ncol(posteriorMat) + + # check prior + if ('bayesianOutput' %in% class(x)) { + + # default T if NULL and BayesianOutput provide + if (is.null(prior)) prior = TRUE + + if (any(c('data.frame', 'matrix') %in% class(prior))) priorMat = prior + else if (is.logical(prior)){ + if (prior == TRUE) priorMat = getSetup(x)$prior$sampler(nPriorDraws) # draw prior from bayesianSetup + else if (prior == F) priorMat = NULL + } + else stop('wrong argument to prior') + } else { + + # default F + if (is.null(prior)) prior = FALSE + + if (any(c('data.frame', 'matrix') %in% class(prior))) priorMat = prior + else if (is.logical(prior)){ + priorMat = NULL + if (prior == TRUE) message("prior = T will only have an effect if x is of class BayesianOutput") + } + else stop('wrong argument to prior') + } + + if (!is.null(priorMat)) { + priorMat = priorMat[,which,drop=F] + if (ncol(posteriorMat) != ncol(priorMat)) stop("wrong dimensions of prior") + colnames(priorMat) <- colnames(posteriorMat) + } + + nPar <- ncol(posteriorMat) + + # check xrange + if (!is.null(xrange)) { + if (!any(c('numeric', 'matrix') %in% class(xrange))) stop('xrange must be numeric or matrix, or NULL') + if ('numeric' %in% class(xrange)) xrange <- matrix(rep(xrange), nPar, nrow = 2) + else if ('matrix' %in% class(xrange)) { + if (ncol(xrange) != ncol(posteriorMat)) stop('xrange must have as many colums as there are parameterss') + else if (nrow(xrange) != 2) stop('xrange must have two rows (min, max)') + } + } else { + posteriorRanges <- apply(posteriorMat, 2, range) + priorRanges <- if(!is.null(priorMat)) apply(priorMat, 2, range) else NULL + + xrange <- if (is.null(priorRanges)) posteriorRanges else apply(rbind(priorRanges, posteriorRanges), 2, range) + } + + # check type + if (any(c('d', 'dens', 'density') == type)) type <- 'd' + # else if (any(c('h', 'hist', 'histogram') == type)) type <- 'h' + else if (any(c('v', 'violin') == type)) type <- 'v' + # else stop('type must be one of "d", "h", "v"') + else stop('type must be one of "d", "v"') + + # check parameter names + if (is.null(colnames(posteriorMat))) colnames(posteriorMat) <- paste('par', 1:nPar, sep = '') + if (!is.null(priorMat)) colnames(priorMat) <- colnames(posteriorMat) + + # prepare arguments for sub-functions + .args <- c(list(posteriorMat = posteriorMat, priorMat = priorMat, xrange = xrange, singlePanel = singlePanel), + settings) + + if (type == 'd') do.call(marginalPlotDensity, .args) + # else if (type == 'h') do.call(marginalPlotHistogram, .args) + else if (type == 'v') do.call(marginalPlotViolin, .args) +} + + +#' Plot marginals as densities +#' @param posteriorMat matrix with samples as rows and parameters as columns +#' @param priorMat matrix (optional) with samples as rows and parameters as columns +#' @param xrange vector or matrix (optional), determining the plotting range, with parameters as columns and min, max as rows +#' @param col vector of colors for posterior and +#' @param singlePanel logical, determining whether the parameter should be plotted in a single panel or each in its own panel +# #' @param ... further options +#' @author Tankred Ott +#' @keywords internal +# TODO: this could be simplified. It is verbose for now to be able to change stuff easily +marginalPlotDensity <- function(posteriorMat, priorMat = NULL, xrange = NULL, col=c('#FC006299','#00BBAA30'), + singlePanel = TRUE, ...) { + + nPar <- ncol(posteriorMat) + parNames <- colnames(posteriorMat) + + if (is.null(xrange)) { + posteriorRanges <- apply(posteriorMat, 2, range) + priorRanges <- if(!is.null(priorMat)) apply(priorMat, 2, range) else NULL + + xrange <- if (is.null(priorRanges)) posteriorRanges else apply(rbind(priorRanges, posteriorRanges), 2, range) + } + + posteriorDensities <- lapply(1:ncol(posteriorMat), + function(i) density(posteriorMat[,i], from = xrange[1,i], to = xrange[2,i], ...)) + priorDensities <- if (!is.null(priorMat)) lapply(1:ncol(priorMat), + function(i) density(priorMat[,i], from = xrange[1,i], to = xrange[2,i], ...)) + else NULL + + postXY <- lapply(posteriorDensities, function(d) { + xy <- cbind(c(d$x[1], d$x, d$x[length(d$x)]), + c(0, d$y, 0)) + colnames(xy) <- c('x', 'y') + xy + }) + + priorXY <- if (!is.null(priorDensities)) lapply(priorDensities, function(d) { + xy <- cbind(c(d$x[1], d$x, d$x[length(d$x)]), + c(0, d$y, 0)) + colnames(xy) <- c('x', 'y') + xy + }) else NULL + + + if (singlePanel) { + op <- par(mfrow = c(nPar,1), mar = c(2, 5, 2, 2), oma = c(5, 4, 4, 0)) + on.exit(par(op)) + + + for (i in 1:length(posteriorDensities)) { + postX <- postXY[[i]][,1] + postY <- postXY[[i]][,2] + + priorX <- if (!is.null(priorXY[[i]])) priorXY[[i]][,1] else NULL + priorY <- if (!is.null(priorXY[[i]])) priorXY[[i]][,2] else NULL + + yrange <- if (is.null(priorX)) range(postY) else range(c(postY, priorY)) + + plot(NULL, NULL, xlim = xrange[,i], ylim = yrange, main = NA, + xlab = NA, ylab = NA, bty = 'n', yaxt = 'n', xaxt = 'n') + axis(1, at = xrange[,i], labels = NA, lwd.ticks=0) + xticks <- axTicks(1) + xticks <- xticks[xticks >= xrange[1,i] & xticks <= xrange[2,i]] + + axis(1, at = xticks) + + mtext(sprintf('%20s', parNames[i]), 2, las = 1, adj = 1.25) + + + polygon(postX, postY, col = col[1], border = 1) + if (!is.null(priorX)) polygon(priorX, priorY, col = col[2], border = 1) + + } + + mtext('Marginal parameter uncertainty', outer = TRUE, cex = 1.5) + + } else { + mfrow <- if (nPar < 16) getPanels(nPar) else c(4,4) + + op <- par(mfrow = mfrow, mar = c(4.5, 4, 5, 3), oma=c(3, 1.5, 2, 0), xpd=TRUE) + on.exit(par(op)) + + for (i in 1:length(posteriorDensities)) { + postX <- postXY[[i]][,1] + postY <- postXY[[i]][,2] + + priorX <- if (!is.null(priorXY[[i]])) priorXY[[i]][,1] else NULL + priorY <- if (!is.null(priorXY[[i]])) priorXY[[i]][,2] else NULL + + yrange <- if (is.null(priorX)) range(postY) else range(c(postY, priorY)) + + plot(NULL, NULL, xlim = xrange[,i], ylim = yrange, main = parNames[i], + xlab = NA, ylab = 'density') + + polygon(postX, postY, col = col[1], border = 1) + if (!is.null(priorX)) polygon(priorX, priorY, col = col[2], border = 1) + + if (i %% 16 == 1) mtext('Marginal parameter uncertainty', outer = TRUE, cex = 1.5) + } + } + + # overlay plot with empty plot to be able to place the legends freely + par(fig = c(0, 1, 0, 1), oma = c(0, 0, 0, 0), mar = c(0, 0, 0, 0), new = TRUE) + plot(0, 0, type = 'n', bty = 'n', xaxt = 'n', yaxt = 'n') + + legend('bottom', if (!is.null(priorX)) c('posterior', 'prior') else 'posterior', xpd = TRUE, horiz = TRUE, inset = c(0, 0), + bty = 'n', pch = 15, col = col, cex = 1.5) +} + + +#' Plot marginals as violin plot +#' @param posteriorMat matrix with samples as rows and parameters as columns +#' @param priorMat matrix (optional) with samples as rows and parameters as columns +#' @param xrange vector or matrix (optional), determining the plotting range, with parameters as columns and min, max as rows +#' @param col vector of colors for posterior and +#' @param singlePanel logical, determining whether the parameter should be plotted in a single panel or each in its own panel +# #' @param ... further options +#' @author Tankred Ott +#' @keywords internal +# TODO: this could be simplified. It is verbose for now to be able to change stuff easily +marginalPlotViolin <- function(posteriorMat, priorMat = NULL, xrange = NULL, col=c('#FC006299','#00BBAA88'), + singlePanel = TRUE, ...) { + + nPar <- ncol(posteriorMat) + parNames <- colnames(posteriorMat) + + if (is.null(xrange)) { + posteriorRanges <- apply(posteriorMat, 2, range) + priorRanges <- if(!is.null(priorMat)) apply(priorMat, 2, range) else NULL + + xrange <- if (is.null(priorRanges)) posteriorRanges else apply(rbind(priorRanges, posteriorRanges), 2, range) + } + + posteriorDensities <- lapply(1:ncol(posteriorMat), + function(i) density(posteriorMat[,i], from = xrange[1,i], to = xrange[2,i], ...)) + priorDensities <- if (!is.null(priorMat)) lapply(1:ncol(priorMat), + function(i) density(priorMat[,i], from = xrange[1,i], to = xrange[2,i], ...)) + else NULL + + + postXY <- lapply(posteriorDensities, function(d) { + xy <- cbind(c(d$x[1], d$x, d$x[length(d$x)]), + c(0, d$y, 0)) + colnames(xy) <- c('x', 'y') + if (is.null(priorDensities)) xy <- rbind(xy, + cbind(rev(xy[,1]), rev(-xy[,2]))) + xy + }) + + priorXY <- if (!is.null(priorDensities)) lapply(priorDensities, function(d) { + xy <- cbind(c(d$x[1], d$x, d$x[length(d$x)]), + -c(0, d$y, 0)) + colnames(xy) <- c('x', 'y') + xy + }) else NULL + + + if (singlePanel) { + nChar <- max(nchar(parNames)) + op <- par(mfrow = c(nPar,1), mar = c(2, min(nChar, 20), 2, 2), oma = c(5, 0, 4, 0)) + on.exit(par(op)) + + for (i in 1:length(posteriorDensities)) { + postX <- postXY[[i]][,1] + postY <- postXY[[i]][,2] + + priorX <- if (!is.null(priorXY[[i]])) priorXY[[i]][,1] else NULL + priorY <- if (!is.null(priorXY[[i]])) priorXY[[i]][,2] else NULL + + yrange <- if (is.null(priorX)) range(postY) else range(c(postY, priorY)) + + plot(NULL, NULL, xlim = xrange[,i], ylim = yrange, main = NA, + xlab = NA, ylab = NA, bty = 'n', yaxt = 'n', xaxt = 'n') + + axis(1, at = xrange[,i], labels = NA, lwd.ticks=0) + xticks <- axTicks(1) + xticks <- xticks[xticks >= xrange[1,i] & xticks <= xrange[2,i]] + + axis(1, at = xticks) + mtext(sprintf('%20s', parNames[i]), 2, las = 1, adj = 1) + + polygon(postX, postY, col = col[1], border = 1) + if (!is.null(priorX)) polygon(priorX, priorY, col = col[2], border = 1) + + } + + mtext('Marginal parameter uncertainty', outer = TRUE, cex = 1.5) + + } else { + mfrow <- if (nPar < 16) getPanels(nPar) else c(4,4) + + op <- par(mfrow = mfrow, mar = c(4.5, 4.5, 5, 3), oma=c(3, 0, 2, 0), xpd=TRUE) + + on.exit(par(op)) + for (i in 1:length(posteriorDensities)) { + postX <- postXY[[i]][,1] + postY <- postXY[[i]][,2] + + priorX <- if (!is.null(priorXY[[i]])) priorXY[[i]][,1] else NULL + priorY <- if (!is.null(priorXY[[i]])) priorXY[[i]][,2] else NULL + + yrange <- if (is.null(priorX)) range(postY) else range(c(postY, priorY)) + + plot(NULL, NULL, xlim = xrange[,i], ylim = yrange, main = parNames[i], + xlab = NA, ylab = 'density', yaxt = 'n') + yticks <- sort(c(0, axTicks(2))) + axis(2, at = yticks, labels = abs(yticks)) + + + polygon(postX, postY, col = col[1], border = 1) + if (!is.null(priorX)) polygon(priorX, priorY, col = col[2], border = 1) + + if (i %% 16 == 1) mtext('Marginal parameter uncertainty', outer = TRUE, cex = 1.5) + } + } + + # overlay plot with empty plot to be able to place the legends freely + par(fig = c(0, 1, 0, 1), oma = c(0, 0, 0, 0), mar = c(0, 0, 0, 0), new = TRUE) + plot(0, 0, type = 'n', bty = 'n', xaxt = 'n', yaxt = 'n') + + legend('bottom', if (!is.null(priorX)) c('posterior', 'prior') else 'posterior', xpd = TRUE, horiz = TRUE, + inset = c(0, 0), bty = 'n', pch = 15, col = col, cex = 1.5) +} + +#' #' @keywords internal +#' marginalPlotHistogram <- function(posteriorMat, priorMat = NULL, xrange = NULL, col=c('#FF5000A0','#4682B4A0'), +#' singlePanel = TRUE, breaks = NULL, ...) { +#' +#' } diff --git a/BayesianTools/R/plotSensitivityOAT.R b/BayesianTools/R/plotSensitivityOAT.R index 1c2b060..fa723e5 100644 --- a/BayesianTools/R/plotSensitivityOAT.R +++ b/BayesianTools/R/plotSensitivityOAT.R @@ -1,57 +1,57 @@ -#' Performs a one-factor-at-a-time sensitivity analysis for the posterior of a given bayesianSetup within the prior range. -#' @author Florian Hartig -#' @param bayesianSetup An object of class BayesianSetup -#' @param selection indices of selected parameters -#' @param equalScale if T, y axis of all plots will have the same scale -#' @note This function can also be used for sensitivity analysis of an arbitrary output - just create a BayesianSetup with this output. -#' @example /inst/examples/plotSensitivityHelp.R -#' @export -plotSensitivity <- function(bayesianSetup, selection = NULL, equalScale = T){ - - if (is.null(selection)) selection = 1:bayesianSetup$numPars - n = length(selection) - - post = list() - lowS = bayesianSetup$prior$lower[selection] - upS = bayesianSetup$prior$upper[selection] - refPar = bayesianSetup$prior$best[selection] - names = bayesianSetup$names[selection] - fullRefPar <- bayesianSetup$prior$best - - minR = Inf - maxR = -Inf - - for (j in 1:n){ - post[[j]] <- data.frame(par = seq(lowS[j], upS[j], len = 20), resp = rep(NA, 20)) - - for (i in 1:20){ - parS <- refPar - parS[j] = post[[j]]$par[i] - parS2 = fullRefPar - parS2[selection] = parS - post[[j]]$resp[i] = bayesianSetup$posterior$density(parS2) - } - minR = min(minR, post[[j]]$resp) - maxR = max(maxR, post[[j]]$resp) - } - - oldPar = par(mfrow = getPanels(n)) - - - for (i in 1:n){ - if(equalScale == T) plot(resp~par, xlab = names[i], type = "l", col = "red", data = post[[i]], ylim = c(minR, maxR), ylab = "Response") - else plot(resp~par, xlab = names[i], type = "l", col = "red", data = post[[i]], ylab = "Response") - - abline(v = refPar[i]) - } - - names(post) = names - post$reference = refPar - - par(oldPar) - return(post) -} - - - - +#' Performs a one-factor-at-a-time sensitivity analysis for the posterior of a given bayesianSetup within the prior range. +#' @author Florian Hartig +#' @param bayesianSetup an object of class BayesianSetup +#' @param selection indices of selected parameters +#' @param equalScale if T, y-axis of all plots will have the same scale +#' @note This function can also be used for sensitivity analysis of an arbitrary output - just create a BayesianSetup with this output. +#' @example /inst/examples/plotSensitivityHelp.R +#' @export +plotSensitivity <- function(bayesianSetup, selection = NULL, equalScale = T){ + + if (is.null(selection)) selection = 1:bayesianSetup$numPars + n = length(selection) + + post = list() + lowS = bayesianSetup$prior$lower[selection] + upS = bayesianSetup$prior$upper[selection] + refPar = bayesianSetup$prior$best[selection] + names = bayesianSetup$names[selection] + fullRefPar <- bayesianSetup$prior$best + + minR = Inf + maxR = -Inf + + for (j in 1:n){ + post[[j]] <- data.frame(par = seq(lowS[j], upS[j], len = 20), resp = rep(NA, 20)) + + for (i in 1:20){ + parS <- refPar + parS[j] = post[[j]]$par[i] + parS2 = fullRefPar + parS2[selection] = parS + post[[j]]$resp[i] = bayesianSetup$posterior$density(parS2) + } + minR = min(minR, post[[j]]$resp) + maxR = max(maxR, post[[j]]$resp) + } + + oldPar = par(mfrow = getPanels(n)) + + + for (i in 1:n){ + if(equalScale == T) plot(resp~par, xlab = names[i], type = "l", col = "red", data = post[[i]], ylim = c(minR, maxR), ylab = "Response") + else plot(resp~par, xlab = names[i], type = "l", col = "red", data = post[[i]], ylab = "Response") + + abline(v = refPar[i]) + } + + names(post) = names + post$reference = refPar + + par(oldPar) + return(post) +} + + + + diff --git a/BayesianTools/R/plotTrace.R b/BayesianTools/R/plotTrace.R index b61a3e2..519a439 100644 --- a/BayesianTools/R/plotTrace.R +++ b/BayesianTools/R/plotTrace.R @@ -1,13 +1,13 @@ -#' Trace plot for MCMC class -#' @param sampler an object of class MCMC sampler -#' @param thin determines the thinning intervall of the chain -#' @param ... additional parameters to pass on to the \code{\link{getSample}}, for example parametersOnly =F, or start = 1000 -#' @export -#' @seealso \code{\link{marginalPlot}} \cr -#' \code{\link{plotTimeSeries}} \cr -#' \code{\link{correlationPlot}} -#' @example /inst/examples/tracePlotHelp.R -tracePlot <- function(sampler, thin = "auto", ...){ - codaChain = getSample(sampler, coda = T, thin = thin, ...) - plot(codaChain) -} +#' Trace plot for MCMC class +#' @param sampler an object of class MCMC sampler +#' @param thin determines the thinning interval of the chain +#' @param ... additional parameters to pass on to the \code{\link{getSample}}, for example parametersOnly = F, or start = 1000 +#' @export +#' @seealso \code{\link{marginalPlot}} \cr +#' \code{\link{plotTimeSeries}} \cr +#' \code{\link{correlationPlot}} +#' @example /inst/examples/tracePlotHelp.R +tracePlot <- function(sampler, thin = "auto", ...){ + codaChain = getSample(sampler, coda = T, thin = thin, ...) + plot(codaChain) +} From 2471527a9316cb61032f5e3ef5dc517408886408 Mon Sep 17 00:00:00 2001 From: TahminaMojumder Date: Wed, 25 Oct 2023 15:52:57 +0200 Subject: [PATCH 07/13] update --- BayesianTools/R/classBayesianSetup.R | 402 +++++++++---------- BayesianTools/man/AdaptpCR.Rd | 4 +- BayesianTools/man/DE.Rd | 18 +- BayesianTools/man/DEzs.Rd | 20 +- BayesianTools/man/DREAM.Rd | 36 +- BayesianTools/man/DREAMzs.Rd | 42 +- BayesianTools/man/M.Rd | 8 +- BayesianTools/man/MAP.Rd | 2 +- BayesianTools/man/Metropolis.Rd | 10 +- BayesianTools/man/Twalk.Rd | 18 +- BayesianTools/man/TwalkMove.Rd | 4 +- BayesianTools/man/combineChains.Rd | 2 +- BayesianTools/man/convertCoda.Rd | 17 +- BayesianTools/man/correlationPlot.Rd | 4 +- BayesianTools/man/createBayesianSetup.Rd | 12 +- BayesianTools/man/createLikelihood.Rd | 10 +- BayesianTools/man/createMcmcSamplerList.Rd | 4 +- BayesianTools/man/createPosterior.Rd | 4 +- BayesianTools/man/createPrior.Rd | 4 +- BayesianTools/man/createSmcSamplerList.Rd | 2 +- BayesianTools/man/generateCRvalues.Rd | 4 +- BayesianTools/man/getBlockSettings.Rd | 2 +- BayesianTools/man/getSample.Rd | 12 +- BayesianTools/man/getVolume.Rd | 6 +- BayesianTools/man/makeObjectClassCodaMCMC.Rd | 6 +- BayesianTools/man/marginalLikelihood.Rd | 6 +- BayesianTools/man/marginalPlot.Rd | 12 +- BayesianTools/man/mcmcMultipleChains.Rd | 2 +- BayesianTools/man/plotDiagnostic.Rd | 8 +- BayesianTools/man/plotSensitivity.Rd | 4 +- BayesianTools/man/runMCMC.Rd | 2 +- BayesianTools/man/tracePlot.Rd | 4 +- BayesianTools/man/updateGroups.Rd | 2 +- 33 files changed, 345 insertions(+), 348 deletions(-) diff --git a/BayesianTools/R/classBayesianSetup.R b/BayesianTools/R/classBayesianSetup.R index 55de969..544d575 100644 --- a/BayesianTools/R/classBayesianSetup.R +++ b/BayesianTools/R/classBayesianSetup.R @@ -1,201 +1,201 @@ -#' Creates a standardized collection of prior, likelihood and posterior functions, including error checks etc. -#' @author Florian Hartig, Tankred Ott -#' @param likelihood log likelihood density function -#' @param prior either a prior class (see \code{\link{createPrior}}) or a log prior density function -#' @param priorSampler if a prior density (and not a prior class) is provided to prior, the optional prior sampling function can be provided here -#' @param lower vector with lower prior limits -#' @param upper vector with upper prior limits -#' @param best vector with best prior values -#' @param names optional vector with parameter names -#' @param parallel parallelization option. Default is F. Other options include T, or "external". See details. -#' @param parallelOptions list containing three lists.\n First, "packages" determines the R packages necessary to run the likelihood function.\n Second, "variables" - the objects in the global environment needed to run the likelihood function and \n third, "dlls" is needed to run the likelihood function (see Details and Examples). -#' @param catchDuplicates logical, determines whether unique parameter combinations should only be evaluated once. Only used when the likelihood accepts a matrix with parameter as columns. -#' @param plotLower vector with lower limits for plotting -#' @param plotUpper vector with upper limits for plotting -#' @param plotBest vector with best values for plotting -#' @details If prior is of class prior (e.g. create with \code{\link{createPrior}}), priorSampler, lower, upper and best will be ignored.\cr If prior is a function (log prior density), priorSampler (custom sampler), or lower/upper (uniform sampler) is required.\cr If prior is NULL, and lower and upper are passed, a uniform prior (see \code{\link{createUniformPrior}}) will be created with boundaries lower and upper. -#' -#' For parallelization, Bayesiantools requires that the likelihood can evaluate multiple parameter vectors (supplied as a matrix) in parallel. -#' -#' * parallel = T attempts to parallelize likelihood via a standard R socket cluster using the \code{\link{generateParallelExecuter}} function. By default, of the N cores detected on the computer, N-1 cores are requested. Alternatively, you can provide a integer number to parallel, specifying the cores reserved for the cluster. When the cluster is created, a copy of your workspace, including DLLs and objects are exported to the cluster workers. As this approach can be highly inefficient, it is recommended to explicitly specify the packages, objects and DLLs to export using parallelOptions. Using parallel = T requires that the function to be parallelized is well encapsulated, i.e. can run in parallel on a shared memory / shared hard disk machine in parallel without interfering with each other. -#' -#' If automatic parallelization is not possible (e.g., because dlls are not thread-safe or write to shared disk), and only in this case, you should specify parallel = "external". In this case, it is assumed that the likelihood is programmed to accept a matrix with parameters as columns and the different model runs as rows. The user can then choose whether and how to parallelize this function. This option provides optimal flexibility for the user, especially regarding complicated parallel architectures or shared memory issues. -#' -#' For more details on parallelization, make sure to read both vignettes, especially the section on likelihood in the main vignette and the section on parallelization in the vignette on interfacing models. -#' -#' @export -#' @seealso \code{\link{checkBayesianSetup}} \cr -#' \code{\link{createLikelihood}} \cr -#' \code{\link{createPrior}} \cr -#' @example /inst/examples/classBayesianSetup.R -#' -#' -#@param model TODO -createBayesianSetup <- function(likelihood, - prior = NULL, - priorSampler = NULL, - parallel = FALSE, - lower= NULL, - upper = NULL, - best = NULL, - names = NULL, - parallelOptions = list(variables = "all", packages = "all", dlls = NULL), - catchDuplicates = FALSE, - plotLower = NULL, - plotUpper = NULL, - plotBest = NULL -){ - - # TODO implement parameter "model" (function that makes predictions from the model) - model <- NULL - - - # INPUTS CHECKS - if(is.null(upper) && is.null(lower) && is.null(prior)) stop("Either boundaries or prior density and prior sampler must be provided.") - # if(!is.null(lower) || !is.null(upper) || !is.null(best)) print("DEPRECATED: lower/upper/best arguments for createBayesianSetup are deprecated and will be removed in a future update. Pass those arguments in the info parameter instead or use createUnformPrior.") - if(("prior" %in% class(prior)) && (!is.null(lower) || !is.null(upper))) warning("Prior object and boundary values provided to createBayesiansetup, the latter will be ignored") - if(("prior" %in% class(prior)) && (!is.null(priorSampler))) warning("Prior object and priorSampler provided to createBayesiansetup, the latter will be ignored") - - if(is.null(parallelOptions)) parallelOptions <- list(variables = "all", packages = "all", dlls = "all") - - - # PRIOR CHECKS - priorClass = NULL - if ("prior" %in% class(prior)) { - priorClass = prior - - } else if (inherits(prior,"bayesianOutput")) { - priorClass = createPriorDensity(prior) - - } else if ("function" %in% class(prior)) { - if ("function" %in% class(priorSampler)) priorClass = createPrior(prior, priorSampler) - else if (!is.null(lower) && !is.null(upper)) priorClass = createPrior(prior, lower=lower, upper=upper, best=best) - else stop("If prior is a function, priorSampler or lower/upper is required") - - } else if (is.null(prior)) { - # TODO: deprecate this - # checks for NULL for lower/upper are already done at begin of function - priorClass = createUniformPrior(lower = lower, upper = upper, best = best) - - } else stop("wrong input for prior") - - - # LIKELIHOOD CHECKS - if ("likelihood" %in% class(likelihood)) { - likelihoodClass = likelihood - } else if ("function" %in% class(likelihood)) { - likelihoodClass = createLikelihood(likelihood, parallel = parallel, parallelOptions = parallelOptions, catchDuplicates = catchDuplicates) - } else { - stop("likelihood must be an object of class likelihood or a function") - } - pwLikelihood = likelihoodClass$pwLikelihood - - # GET NUMBER OF PARAMETERS - numPars = length(priorClass$sampler()) - - # CREATE POSTERIOR - posteriorClass = createPosterior(priorClass,likelihoodClass) - - # CHECK FOR PLOTTING PARAMETERS - if (is.null(plotLower)) plotLower <- priorClass$lower - if (is.null(plotUpper)) plotUpper <- priorClass$upper - if (is.null(plotBest)) plotBest <- priorClass$best - - if (is.null(plotLower) | is.null(plotUpper) | is.null(plotBest)) - print("Info is missing upper/lower/best. This can cause plotting and sensitivity analysis functions to fail. If you want to use those functions provide (plot)upper/lower/best either in createBayesianSetup or prior") - - # CHECK NAMES - if (is.null(names)) { - if (!is.null(priorClass$parNames)) names = priorClass$parNames - else if (!is.null(likelihoodClass$parNames)) names = likelihoodClass$parNames - else if (numPars > 0) names = paste("par", 1:numPars) - } - - # CONSTRUCT OUTPUT - info <- list(priorLower = priorClass$lower, priorUpper = priorClass$upper, priorBest = priorClass$best, - plotLower = plotLower, plotUpper = plotUpper, plotBest = plotBest, - parNames = names, numPars = numPars) - out <- list(prior = priorClass, likelihood = likelihoodClass, posterior = posteriorClass, - names = names, numPars = numPars, model = model, parallel = parallel, pwLikelihood = pwLikelihood, info = info) - class(out) <- "BayesianSetup" - - return(out) -} -# -# #' Generates initial sample TODO -# #' @param n TODO -# #' @param checkInf TODO -# #' @param overdispersed TODO -# #' @param maxIterations TODO -# #' @export -# generateInitialSamples <- function(n, checkInf = T, overdispersed = F, maxIterations = 5){ -# if(is.null(sampler)) stop("sampling not implemented") -# done = F -# -# stop("to implement") -# -# # check infinity of likelihood / create overdispersion -# -# } - -#TODO: FH I wonder if we should keep this function option alive - seems better to me to explicitly do -# this with the createBayesianSetup - -#' Checks if an object is of class 'BayesianSetup' -#' @author Florian Hartig -#' @description Function used to assure that an object is of class 'BayesianSetup'. If you pass a function, it is coverted to an object of class 'BayesianSetup' (using \code{\link{createBayesianSetup}}) before it is returned. -#' @param bayesianSetup either object of class bayesianSetup or a log posterior function -#' @param parallel if bayesianSetup is a function, this will set the parallelization option for the class BayesianSetup that is created internally. If bayesianSetup is already a BayesianSetup, then this will check if parallel = T is requested but not supported by the BayesianSetup. This option is for internal use in the samplers -#' @note The recommended option to use this function in the samplers is to have parallel with default NULL in the samplers, so that checkBayesianSetup with a function will create a bayesianSetup without parallelization, while it will do nothing with an existing BayesianSetup. If the user sets parallelization, it will set the approriate parallelization for a function, and check in case of an existing BayesianSetup. The checkBayesianSetup call in the samplers should then be followed by a check for parallel = NULL in sampler, in which case paralell can be set from the BayesianSetup -#' @seealso \code{\link{createBayesianSetup}} -#' @export -checkBayesianSetup <- function(bayesianSetup, parallel = F){ - - if(inherits(bayesianSetup, "function")){ - if(is.null(parallel)) parallel = F - bayesianSetup = createBayesianSetup(bayesianSetup, parallel = parallel) - } - else if(inherits(bayesianSetup, "BayesianSetup")){ - if(!is.null(parallel)) if(parallel == T & bayesianSetup$parallel == F) stop("parallel = T requested in sampler but BayesianSetup does not support parallelization. See help of BayesianSetup on how to enable parallelization") - } - else stop("bayesianSetup must be class BayesianSetup or a function") - - return(bayesianSetup) -} - - -#' Function to close cluster in BayesianSetup -#' @author Stefan Paul -#' @description Function closes -#' the parallel executer (if available) -#' @param bayesianSetup object of class BayesianSetup -#' @export -stopParallel <- function(bayesianSetup){ - - ## Stop cluster - try(parallel::stopCluster(bayesianSetup$likelihood$cl), silent = TRUE) - - ## Remove object - # pos <- -1 - # if(is.null(envir)) envir <- as.environment(pos) - - # .Internal(remove(deparse(substitute(bayesianSetup)), envir = envir, inherits = FALSE)) - -} - - -#' @author Maximilian Pichler -#' @export - -print.BayesianSetup <- function(x, ...){ - cat('BayesianSetup: \n\n') - - bayesianSetup = x - info = c( "priorLower", "priorUpper", "plotLower", "plotUpper") - parInfo = data.frame(matrix(NA, ncol = 4, nrow = bayesianSetup$info$numPars)) - colnames(parInfo) = info - rownames(parInfo) = bayesianSetup$info$parNames - for(i in 1:4) if(!is.null(bayesianSetup$info[[info[i]]])) parInfo[,i] <- bayesianSetup$info[[info[i]]] - print(parInfo) - -} +#' Creates a standardized collection of prior, likelihood and posterior functions, including error checks etc. +#' @author Florian Hartig, Tankred Ott +#' @param likelihood log likelihood density function +#' @param prior either a prior class (see \code{\link{createPrior}}) or a log prior density function +#' @param priorSampler if a prior density (and not a prior class) is provided to prior, the optional prior sampling function can be provided here +#' @param lower vector with lower prior limits +#' @param upper vector with upper prior limits +#' @param best vector with best prior values +#' @param names optional vector with parameter names +#' @param parallel parallelization option. Default is F. Other options include T, or "external". See details. +#' @param parallelOptions list containing three lists.\itemize{ \item First, "packages" determines the R packages necessary to run the likelihood function.\item Second, "variables" - the objects in the global environment needed to run the likelihood function and \item Third, "dlls" is needed to run the likelihood function (see Details and Examples).} +#' @param catchDuplicates logical, determines whether unique parameter combinations should only be evaluated once. Only used when the likelihood accepts a matrix with parameter as columns. +#' @param plotLower vector with lower limits for plotting +#' @param plotUpper vector with upper limits for plotting +#' @param plotBest vector with best values for plotting +#' @details If prior is of class prior (e.g. create with \code{\link{createPrior}}), priorSampler, lower, upper and best will be ignored.\cr If prior is a function (log prior density), priorSampler (custom sampler), or lower/upper (uniform sampler) is required.\cr If prior is NULL, and lower and upper are passed, a uniform prior (see \code{\link{createUniformPrior}}) will be created with boundaries lower and upper. +#' +#' For parallelization, Bayesiantools requires that the likelihood can evaluate multiple parameter vectors (supplied as a matrix) in parallel. +#' +#' * parallel = T attempts to parallelize likelihood via a standard R socket cluster using the \code{\link{generateParallelExecuter}} function. By default, of the N cores detected on the computer, N-1 cores are requested. Alternatively, you can provide a integer number to parallel, specifying the cores reserved for the cluster. When the cluster is created, a copy of your workspace, including DLLs and objects are exported to the cluster workers. As this approach can be highly inefficient, it is recommended to explicitly specify the packages, objects and DLLs to export using parallelOptions. Using parallel = T requires that the function to be parallelized is well encapsulated, i.e. can run in parallel on a shared memory / shared hard disk machine in parallel without interfering with each other. +#' +#' If automatic parallelization is not possible (e.g., because dlls are not thread-safe or write to shared disk), and only in this case, you should specify parallel = "external". In this case, it is assumed that the likelihood is programmed to accept a matrix with parameters as columns and the different model runs as rows. The user can then choose whether and how to parallelize this function. This option provides optimal flexibility for the user, especially regarding complicated parallel architectures or shared memory issues. +#' +#' For more details on parallelization, make sure to read both vignettes, especially the section on likelihood in the main vignette and the section on parallelization in the vignette on interfacing models. +#' +#' @export +#' @seealso \code{\link{checkBayesianSetup}} \cr +#' \code{\link{createLikelihood}} \cr +#' \code{\link{createPrior}} \cr +#' @example /inst/examples/classBayesianSetup.R +#' +#' +#@param model TODO +createBayesianSetup <- function(likelihood, + prior = NULL, + priorSampler = NULL, + parallel = FALSE, + lower= NULL, + upper = NULL, + best = NULL, + names = NULL, + parallelOptions = list(variables = "all", packages = "all", dlls = NULL), + catchDuplicates = FALSE, + plotLower = NULL, + plotUpper = NULL, + plotBest = NULL +){ + + # TODO implement parameter "model" (function that makes predictions from the model) + model <- NULL + + + # INPUTS CHECKS + if(is.null(upper) && is.null(lower) && is.null(prior)) stop("Either boundaries or prior density and prior sampler must be provided.") + # if(!is.null(lower) || !is.null(upper) || !is.null(best)) print("DEPRECATED: lower/upper/best arguments for createBayesianSetup are deprecated and will be removed in a future update. Pass those arguments in the info parameter instead or use createUnformPrior.") + if(("prior" %in% class(prior)) && (!is.null(lower) || !is.null(upper))) warning("Prior object and boundary values provided to createBayesiansetup, the latter will be ignored") + if(("prior" %in% class(prior)) && (!is.null(priorSampler))) warning("Prior object and priorSampler provided to createBayesiansetup, the latter will be ignored") + + if(is.null(parallelOptions)) parallelOptions <- list(variables = "all", packages = "all", dlls = "all") + + + # PRIOR CHECKS + priorClass = NULL + if ("prior" %in% class(prior)) { + priorClass = prior + + } else if (inherits(prior,"bayesianOutput")) { + priorClass = createPriorDensity(prior) + + } else if ("function" %in% class(prior)) { + if ("function" %in% class(priorSampler)) priorClass = createPrior(prior, priorSampler) + else if (!is.null(lower) && !is.null(upper)) priorClass = createPrior(prior, lower=lower, upper=upper, best=best) + else stop("If prior is a function, priorSampler or lower/upper is required") + + } else if (is.null(prior)) { + # TODO: deprecate this + # checks for NULL for lower/upper are already done at begin of function + priorClass = createUniformPrior(lower = lower, upper = upper, best = best) + + } else stop("wrong input for prior") + + + # LIKELIHOOD CHECKS + if ("likelihood" %in% class(likelihood)) { + likelihoodClass = likelihood + } else if ("function" %in% class(likelihood)) { + likelihoodClass = createLikelihood(likelihood, parallel = parallel, parallelOptions = parallelOptions, catchDuplicates = catchDuplicates) + } else { + stop("likelihood must be an object of class likelihood or a function") + } + pwLikelihood = likelihoodClass$pwLikelihood + + # GET NUMBER OF PARAMETERS + numPars = length(priorClass$sampler()) + + # CREATE POSTERIOR + posteriorClass = createPosterior(priorClass,likelihoodClass) + + # CHECK FOR PLOTTING PARAMETERS + if (is.null(plotLower)) plotLower <- priorClass$lower + if (is.null(plotUpper)) plotUpper <- priorClass$upper + if (is.null(plotBest)) plotBest <- priorClass$best + + if (is.null(plotLower) | is.null(plotUpper) | is.null(plotBest)) + print("Info is missing upper/lower/best. This can cause plotting and sensitivity analysis functions to fail. If you want to use those functions provide (plot)upper/lower/best either in createBayesianSetup or prior") + + # CHECK NAMES + if (is.null(names)) { + if (!is.null(priorClass$parNames)) names = priorClass$parNames + else if (!is.null(likelihoodClass$parNames)) names = likelihoodClass$parNames + else if (numPars > 0) names = paste("par", 1:numPars) + } + + # CONSTRUCT OUTPUT + info <- list(priorLower = priorClass$lower, priorUpper = priorClass$upper, priorBest = priorClass$best, + plotLower = plotLower, plotUpper = plotUpper, plotBest = plotBest, + parNames = names, numPars = numPars) + out <- list(prior = priorClass, likelihood = likelihoodClass, posterior = posteriorClass, + names = names, numPars = numPars, model = model, parallel = parallel, pwLikelihood = pwLikelihood, info = info) + class(out) <- "BayesianSetup" + + return(out) +} +# +# #' Generates initial sample TODO +# #' @param n TODO +# #' @param checkInf TODO +# #' @param overdispersed TODO +# #' @param maxIterations TODO +# #' @export +# generateInitialSamples <- function(n, checkInf = T, overdispersed = F, maxIterations = 5){ +# if(is.null(sampler)) stop("sampling not implemented") +# done = F +# +# stop("to implement") +# +# # check infinity of likelihood / create overdispersion +# +# } + +#TODO: FH I wonder if we should keep this function option alive - seems better to me to explicitly do +# this with the createBayesianSetup + +#' Checks if an object is of class 'BayesianSetup' +#' @author Florian Hartig +#' @description Function used to assure that an object is of class 'BayesianSetup'. If you pass a function, it is coverted to an object of class 'BayesianSetup' (using \code{\link{createBayesianSetup}}) before it is returned. +#' @param bayesianSetup either object of class bayesianSetup or a log posterior function +#' @param parallel if bayesianSetup is a function, this will set the parallelization option for the class BayesianSetup that is created internally. If bayesianSetup is already a BayesianSetup, then this will check if parallel = T is requested but not supported by the BayesianSetup. This option is for internal use in the samplers +#' @note The recommended option to use this function in the samplers is to have parallel with default NULL in the samplers, so that checkBayesianSetup with a function will create a bayesianSetup without parallelization, while it will do nothing with an existing BayesianSetup. If the user sets parallelization, it will set the approriate parallelization for a function, and check in case of an existing BayesianSetup. The checkBayesianSetup call in the samplers should then be followed by a check for parallel = NULL in sampler, in which case paralell can be set from the BayesianSetup +#' @seealso \code{\link{createBayesianSetup}} +#' @export +checkBayesianSetup <- function(bayesianSetup, parallel = F){ + + if(inherits(bayesianSetup, "function")){ + if(is.null(parallel)) parallel = F + bayesianSetup = createBayesianSetup(bayesianSetup, parallel = parallel) + } + else if(inherits(bayesianSetup, "BayesianSetup")){ + if(!is.null(parallel)) if(parallel == T & bayesianSetup$parallel == F) stop("parallel = T requested in sampler but BayesianSetup does not support parallelization. See help of BayesianSetup on how to enable parallelization") + } + else stop("bayesianSetup must be class BayesianSetup or a function") + + return(bayesianSetup) +} + + +#' Function to close cluster in BayesianSetup +#' @author Stefan Paul +#' @description Function closes +#' the parallel executer (if available) +#' @param bayesianSetup object of class BayesianSetup +#' @export +stopParallel <- function(bayesianSetup){ + + ## Stop cluster + try(parallel::stopCluster(bayesianSetup$likelihood$cl), silent = TRUE) + + ## Remove object + # pos <- -1 + # if(is.null(envir)) envir <- as.environment(pos) + + # .Internal(remove(deparse(substitute(bayesianSetup)), envir = envir, inherits = FALSE)) + +} + + +#' @author Maximilian Pichler +#' @export + +print.BayesianSetup <- function(x, ...){ + cat('BayesianSetup: \n\n') + + bayesianSetup = x + info = c( "priorLower", "priorUpper", "plotLower", "plotUpper") + parInfo = data.frame(matrix(NA, ncol = 4, nrow = bayesianSetup$info$numPars)) + colnames(parInfo) = info + rownames(parInfo) = bayesianSetup$info$parNames + for(i in 1:4) if(!is.null(bayesianSetup$info[[info[i]]])) parInfo[,i] <- bayesianSetup$info[[info[i]]] + print(parInfo) + +} diff --git a/BayesianTools/man/AdaptpCR.Rd b/BayesianTools/man/AdaptpCR.Rd index 3a7bfb4..1801699 100644 --- a/BayesianTools/man/AdaptpCR.Rd +++ b/BayesianTools/man/AdaptpCR.Rd @@ -7,13 +7,13 @@ AdaptpCR(CR, delta, lCR, settings, Npop) } \arguments{ -\item{CR}{Vector of crossover probabilities. Needs to be of length nCR.} +\item{CR}{vector of crossover probabilities. Needs to be of length nCR.} \item{delta}{vector with differences} \item{lCR}{values to weight delta} -\item{settings}{settings list} +\item{settings}{list of settings} \item{Npop}{number of chains.} } diff --git a/BayesianTools/man/DE.Rd b/BayesianTools/man/DE.Rd index a55b88f..2fcb7bf 100644 --- a/BayesianTools/man/DE.Rd +++ b/BayesianTools/man/DE.Rd @@ -17,7 +17,7 @@ DE( \item{settings}{list with parameter settings} -\item{startValue}{(optional) eiter a matrix with start population, a number to define the number of chains that are run or a function that samples a starting population.} +\item{startValue}{(optional) either a matrix with start population, a number defining the number of chains to be run or a function that samples a starting population.} \item{iterations}{number of function evaluations.} @@ -31,7 +31,7 @@ DE( \item{blockUpdate}{list determining whether parameters should be updated in blocks. For possible settings see Details.} -\item{message}{logical determines whether the sampler's progress should be printed} +\item{message}{logical, Specifies whether to print the progress of the sampler.} } \description{ Differential-Evolution MCMC @@ -45,18 +45,18 @@ Possible choices are \item{"random"} { random blocking. Using k (see below)} \item{"user"} { user defined groups. Using groups (see below)} } -Further seven parameters can be specified. "k" determnined the number of groups, "h" the strength -of the correlation used to group parameter and "groups" is used for user defined groups. +Further, seven parameters can be specified. "k" defines the number of groups, "h" the strength +of the correlation used to group the parameters and "groups" is used for user defined groups. "groups" is a vector containing the group number for each parameter. E.g. for three parameters with the first two in one group, "groups" would be c(1,1,2). -Further pSel and pGroup can be used to influence the choice of groups. In the sampling process -a number of groups is randomly drawn and updated. pSel is a vector containing relative probabilities -for an update of the respective number of groups. E.g. for always updating only one group pSel = 1. +Moreover, pSel and pGroup can be used to influence the choice of groups. In the sampling process +a number of groups are drawn at random and updated. pSel is a vector containing relative probabilities +for updating the respective number of groups. E.g. To update one group at a time pSel = 1. For updating one or two groups with the same probability pSel = c(1,1). By default all numbers have the same probability. -The same principle is used in pGroup. Here the user can influence the probability of each group +The same principle is used for pGroup. Here the user can influence the probability of each group to be updated. By default all groups have the same probability. -Finally "groupStart" defines the starting point of the groupUpdate and "groupIntervall" the intervall +Finally, "groupStart" defines the starting point of the groupUpdate and "groupIntervall" - the interval in which the groups are evaluated. } \examples{ diff --git a/BayesianTools/man/DEzs.Rd b/BayesianTools/man/DEzs.Rd index df53820..37bc139 100644 --- a/BayesianTools/man/DEzs.Rd +++ b/BayesianTools/man/DEzs.Rd @@ -18,11 +18,11 @@ DEzs( \item{settings}{list with parameter settings} -\item{startValue}{(optional) eiter a matrix with start population, a number to define the number of chains that are run or a function that samples a starting population.} +\item{startValue}{(optional) either a matrix with start population, a number to define the number of chains that are run or a function that samples a starting population.} \item{Z}{starting Z population} -\item{iterations}{iterations to run} +\item{iterations}{number of iterations to run} \item{pSnooker}{probability of Snooker update} @@ -44,13 +44,13 @@ DEzs( \item{blockUpdate}{list determining whether parameters should be updated in blocks. For possible settings see Details.} -\item{message}{logical determines whether the sampler's progress should be printed} +\item{message}{logical, specifies whether to print the progress of the sampler.} } \description{ Differential-Evolution MCMC zs } \details{ -For parallel computing, the likelihood density in the bayesianSetup needs to be parallelized, i.e. needs to be able to operate on a matrix of proposals +For parallel computing, the likelihood density in the bayesianSetup needs to be parallelized, i.e., it needs to be able to operate on a matrix of proposals For blockUpdate the first element in the list determines the type of blocking. Possible choices are @@ -60,18 +60,18 @@ Possible choices are \item{"random"} { random blocking. Using k (see below)} \item{"user"} { user defined groups. Using groups (see below)} } -Further seven parameters can be specified. "k" determnined the number of groups, "h" the strength +Further, seven parameters can be specified. "k" defines the number of groups, "h" the strength of the correlation used to group parameter and "groups" is used for user defined groups. "groups" is a vector containing the group number for each parameter. E.g. for three parameters with the first two in one group, "groups" would be c(1,1,2). -Further pSel and pGroup can be used to influence the choice of groups. In the sampling process -a number of groups is randomly drawn and updated. pSel is a vector containing relative probabilities -for an update of the respective number of groups. E.g. for always updating only one group pSel = 1. +Moreover, pSel and pGroup can be used to influence the choice of groups. In the sampling process +a number of groups is drawn at random and updated. pSel is a vector containing relative probabilities +for updating the respective number of groups. E.g. To update one group at a time pSel = 1. For updating one or two groups with the same probability pSel = c(1,1). By default all numbers have the same probability. -The same principle is used in pGroup. Here the user can influence the probability of each group +The same principle is used in pGroup. Here, the user can influence the probability of each group to be updated. By default all groups have the same probability. -Finally "groupStart" defines the starting point of the groupUpdate and "groupIntervall" the intervall +Finally, "groupStart" defines the starting point of the groupUpdate and "groupIntervall" - the interval in which the groups are evaluated. } \examples{ diff --git a/BayesianTools/man/DREAM.Rd b/BayesianTools/man/DREAM.Rd index e6da437..7146f27 100644 --- a/BayesianTools/man/DREAM.Rd +++ b/BayesianTools/man/DREAM.Rd @@ -13,15 +13,15 @@ DREAM( ) } \arguments{ -\item{bayesianSetup}{Object of class 'bayesianSetup' or 'bayesianOuput'.} +\item{bayesianSetup}{object of class 'bayesianSetup' or 'bayesianOuput'.} \item{settings}{list with parameter values} -\item{iterations}{Number of model evaluations} +\item{iterations}{number of model evaluations} \item{nCR}{parameter determining the number of cross-over proposals. If nCR = 1 all parameters are updated jointly.} -\item{updateInterval}{determining the intervall for the pCR update} +\item{updateInterval}{determines the interval for the pCR update} \item{gamma}{Kurtosis parameter Bayesian Inference Scheme} @@ -29,21 +29,21 @@ DREAM( \item{e}{Ergodicity term} -\item{pCRupdate}{If T, crossover probabilities will be updated} +\item{pCRupdate}{logical, if T, crossover probabilities will be updated} \item{burnin}{number of iterations treated as burn-in. These iterations are not recorded in the chain.} -\item{thin}{thin thinning parameter. Determines the interval in which values are recorded.} +\item{thin}{thinning parameter. Determines the interval in which values are recorded.} -\item{adaptation}{Number or percentage of samples that are used for the adaptation in DREAM (see Details).} +\item{adaptation}{number or percentage of samples that are used for the adaptation in DREAM (see Details).} -\item{DEpairs}{Number of pairs used to generate proposal} +\item{DEpairs}{number of pairs used to generate proposal} -\item{startValue}{eiter a matrix containing the start values (see details), an integer to define the number of chains that are run, a function to sample the start values or NUll, in which case the values are sampled from the prior.} +\item{startValue}{either a matrix containing the start values (see details), an integer to define the number of chains to be run, a function to sample the start values or NUll - in which case the values are sampled from the prior.} -\item{consoleUpdates}{Intervall in which the sampling progress is printed to the console} +\item{consoleUpdates}{interval at which the sampling progress is printed to the console} -\item{message}{logical determines whether the sampler's progress should be printed} +\item{message}{logical, determines whether the sampler's progress should be printed} } \value{ mcmc.object containing the following elements: chains, X, pCR @@ -52,25 +52,25 @@ mcmc.object containing the following elements: chains, X, pCR DREAM } \details{ -Insted of a bayesianSetup, the function can take the output of a previous run to restart the sampler +Instead of a bayesianSetup, the function can take the output of a previous run to restart the sampler from the last iteration. Due to the sampler's internal structure you can only use the output of DREAM. -If you provide a matrix with start values the number of rows determines the number of chains that are run. +If you provide a matrix with start values, the number of rows determines the number of chains that will be run. The number of coloumns must be equivalent to the number of parameters in your bayesianSetup. \cr\cr There are several small differences in the algorithm presented here compared to the original paper by Vrugt et al. (2009). Mainly -the algorithm implemented here does not have an automatic stopping criterion. Hence, it will +The algorithm implemented here does not have an automatic stopping criterion. Hence, it will always run the number of iterations specified by the user. Also, convergence is not monitored and left to the user. This can easily be done with coda::gelman.diag(chain). -Further the proposed delayed rejectio step in Vrugt et al. (2009) is not implemented here.\cr\cr +Furthermore, the delayed rejection step proposed in Vrugt et al. (2009) is not implemented here.\cr\cr During the adaptation phase DREAM is running two mechanisms to enhance the sampler's efficiency. -First the disribution of crossover values is tuned to favor large jumps in the parameter space. +First, the disribution of crossover values is tuned to favor large jumps in the parameter space. The crossover probabilities determine how many parameters are updated simultaneously. -Second outlier chains are replanced as they can largely deteriorate the sampler's performance. +Second, outlier chains are replaced as they can largely deteriorate the sampler's performance. However, these steps destroy the detailed balance of the chain. Consequently these parts of the chain should be discarded when summarizing posterior moments. This can be done automatically during the -sampling process (i.e. burnin > adaptation) or subsequently by the user. We chose to distinguish between -the burnin and adaptation phase to allow the user more flexibility in the sampler's settings. +sampling process (i.e. burn-in > adaptation) or subsequently by the user. We chose to distinguish between +the burn-in and adaptation phase to allow the user more flexibility in the sampler's settings. } \examples{ library(BayesianTools) diff --git a/BayesianTools/man/DREAMzs.Rd b/BayesianTools/man/DREAMzs.Rd index 80f1805..97fc4b6 100644 --- a/BayesianTools/man/DREAMzs.Rd +++ b/BayesianTools/man/DREAMzs.Rd @@ -13,31 +13,31 @@ DREAMzs( ) } \arguments{ -\item{bayesianSetup}{Object of class 'bayesianSetup' or 'bayesianOuput'.} +\item{bayesianSetup}{object of class 'bayesianSetup' or 'bayesianOuput'.} \item{settings}{list with parameter values} -\item{iterations}{Number of model evaluations} +\item{iterations}{number of model evaluations} -\item{nCR}{parameter determining the number of cross-over proposals. If nCR = 1 all parameters are updated jointly.} +\item{nCR}{parameter determining the number of cross-over proposals. If nCR = 1 all parameters are updated jointly.} -\item{updateInterval}{determining the intervall for the pCR (crossover probabilities) update} +\item{updateInterval}{determines the interval for the pCR (crossover probabilities) update} -\item{gamma}{Kurtosis parameter Bayesian Inference Scheme.} +\item{gamma}{kurtosis parameter Bayesian Inference Scheme.} \item{eps}{Ergodicity term} \item{e}{Ergodicity term} -\item{pCRupdate}{Update of crossover probabilities} +\item{pCRupdate}{update of crossover probabilities} \item{burnin}{number of iterations treated as burn-in. These iterations are not recorded in the chain.} -\item{thin}{thin thinning parameter. Determines the interval in which values are recorded.} +\item{thin}{thinning parameter. Determines the interval in which values are recorded.} -\item{adaptation}{Number or percentage of samples that are used for the adaptation in DREAM (see Details)} +\item{adaptation}{number or percentage of samples that are used for the adaptation in DREAM (see Details)} -\item{DEpairs}{Number of pairs used to generate proposal} +\item{DEpairs}{number of pairs used to generate proposal} \item{ZupdateFrequency}{frequency to update Z matrix} @@ -45,11 +45,11 @@ DREAMzs( \item{Z}{starting matrix for Z} -\item{startValue}{eiter a matrix containing the start values (see details), an integer to define the number of chains that are run, a function to sample the start values or NUll, in which case the values are sampled from the prior.} +\item{startValue}{either a matrix containing the start values (see details), an integer to define the number of chains to be run, a function to sample the start values or NUll - in which case the values are sampled from the prior.} -\item{consoleUpdates}{Intervall in which the sampling progress is printed to the console} +\item{consoleUpdates}{interval in which the sampling progress is printed to the console} -\item{message}{logical determines whether the sampler's progress should be printed} +\item{message}{logical, determines whether the sampler's progress should be printed} } \value{ mcmc.object containing the following elements: chains, X, pCR, Z @@ -58,24 +58,24 @@ mcmc.object containing the following elements: chains, X, pCR, Z DREAMzs } \details{ -Insted of a bayesianSetup, the function can take the output of a previous run to restart the sampler +Instead of a bayesianSetup, the function can take the output of a previous run to restart the sampler from the last iteration. Due to the sampler's internal structure you can only use the output of DREAMzs. -If you provide a matrix with start values the number of rows detemines the number of chains that are run. -The number of coloumns must be equivalent to the number of parameters in your bayesianSetup. \cr\cr +If you provide a matrix with start values, the number of rows determines the number of chains that will be run. +The number of columns must be equivalent to the number of parameters in your bayesianSetup. \cr\cr There are several small differences in the algorithm presented here compared to the original paper by Vrugt et al. (2009). Mainly -the algorithm implemented here does not have an automatic stopping criterion. Hence, it will +The algorithm implemented here does not have an automatic stopping criterion. Hence, it will always run the number of iterations specified by the user. Also, convergence is not monitored and left to the user. This can easily be done with coda::gelman.diag(chain). -Further the proposed delayed rejectio step in Vrugt et al. (2009) is not implemented here.\cr\cr +Furthermore, the delayed rejection step proposed in Vrugt et al. (2009) is not implemented here.\cr\cr During the adaptation phase DREAM is running two mechanisms to enhance the sampler's efficiency. -First the disribution of crossover values is tuned to favor large jumps in the parameter space. +First, the distribution of crossover values is tuned to favor large jumps in the parameter space. The crossover probabilities determine how many parameters are updated simultaneously. -Second outlier chains are replanced as they can largely deteriorate the sampler's performance. +Second, outlier chains are replaced as they can largely deteriorate the sampler's performance. However, these steps destroy the detailed balance of the chain. Consequently these parts of the chain should be discarded when summarizing posterior moments. This can be done automatically during the -sampling process (i.e. burnin > adaptation) or subsequently by the user. We chose to distinguish between -the burnin and adaptation phase to allow the user more flexibility in the sampler's settings. +sampling process (i.e. burn-in > adaptation) or subsequently by the user. We chose to distinguish between +the burn-in and adaptation phase to allow the user more flexibility in the sampler's settings. } \examples{ library(BayesianTools) diff --git a/BayesianTools/man/M.Rd b/BayesianTools/man/M.Rd index d365647..d138c9e 100644 --- a/BayesianTools/man/M.Rd +++ b/BayesianTools/man/M.Rd @@ -16,11 +16,11 @@ M( ) } \arguments{ -\item{startValue}{vector with the start values for the algorithm. Can be NULL if FUN is of class BayesianSetup. In this case startValues are sampled from the prior.} +\item{startValue}{vector with the start values for the algorithm. Can be NULL if FUN is of class BayesianSetup. In this case, startValues are sampled from the prior.} -\item{iterations}{iterations to run} +\item{iterations}{number of iterations to run} -\item{nBI}{number of burnin} +\item{nBI}{number of burn-in} \item{parmin}{minimum values for the parameter vector or NULL if FUN is of class BayesianSetup} @@ -30,7 +30,7 @@ M( \item{FUN}{function to be sampled from or object of class bayesianSetup} -\item{consoleUpdates}{interger, determines the frequency with which sampler progress is printed to the console} +\item{consoleUpdates}{integer, determines the frequency with which sampler progress is printed to the console} } \description{ The Metropolis Algorithm (Metropolis et al. 1953) diff --git a/BayesianTools/man/MAP.Rd b/BayesianTools/man/MAP.Rd index ce4490a..113de9b 100644 --- a/BayesianTools/man/MAP.Rd +++ b/BayesianTools/man/MAP.Rd @@ -15,7 +15,7 @@ MAP(bayesianOutput, ...) calculates the Maxiumum APosteriori value (MAP) } \details{ -Currently, this function simply returns the parameter combination with the highest posterior in the chain. A more refined option would be to take the MCMC sample and do additional calculations, e.g. use an optimizer, a kerne delnsity estimator, or some other tool to search / interpolate around the best value in the chain +Currently, this function simply returns the parameter combination with the highest posterior in the chain. A more refined option would be to take the MCMC sample and do additional calculations, e.g. use an optimizer, a kernel density estimator, or some other tool to search / interpolate around the best value in the chain. } \seealso{ \code{\link{WAIC}}, \code{\link{DIC}}, \code{\link{marginalLikelihood}} diff --git a/BayesianTools/man/Metropolis.Rd b/BayesianTools/man/Metropolis.Rd index d17408d..cff88af 100644 --- a/BayesianTools/man/Metropolis.Rd +++ b/BayesianTools/man/Metropolis.Rd @@ -16,13 +16,13 @@ Metropolis( \arguments{ \item{bayesianSetup}{either an object of class bayesianSetup created by \code{\link{createBayesianSetup}} (recommended), or a log target function} -\item{settings}{a list of settings - possible options follow below} +\item{settings}{a list of settings - possible options follow} \item{startValue}{startValue for the MCMC and optimization (if optimize = T). If not provided, the sampler will attempt to obtain the startValue from the bayesianSetup} \item{optimize}{logical, determines whether an optimization for start values and proposal function should be run before starting the sampling} -\item{proposalGenerator}{optional proposalgenerator object (see \code{\link{createProposalGenerator}})} +\item{proposalGenerator}{optional, proposalgenerator object (see \code{\link{createProposalGenerator}})} \item{proposalScaling}{additional scaling parameter for the proposals that controls the different scales of the proposals after delayed rejection (typical, after a rejection, one would want to try a smaller scale). Needs to be as long as DRlevels. Defaults to 0.5^(- 0:(mcmcSampler$settings$DRlevels -1)} @@ -32,7 +32,7 @@ Metropolis( \item{consoleUpdates}{integer, determines the frequency with which sampler progress is printed to the console} -\item{adapt}{logical, determines wheter an adaptive algorithm should be implemented. Default is TRUE.} +\item{adapt}{logical, determines whether an adaptive algorithm should be implemented. Default is TRUE.} \item{adaptationInterval}{integer, determines the interval of the adaption if adapt = TRUE.} @@ -42,9 +42,9 @@ Metropolis( \item{temperingFunction}{function to implement simulated tempering in the algorithm. The function describes how the acceptance rate will be influenced in the course of the iterations.} -\item{gibbsProbabilities}{vector that defines the relative probabilities of the number of parameters to be changes simultaniously.} +\item{gibbsProbabilities}{vector that defines the relative probabilities of the number of parameters to be changed simultaneously.} -\item{message}{logical determines whether the sampler's progress should be printed} +\item{message}{logical, determines whether the sampler's progress should be printed} } \description{ Creates a Metropolis-type MCMC with options for covariance adaptatin, delayed rejection, Metropolis-within-Gibbs, and tempering diff --git a/BayesianTools/man/Twalk.Rd b/BayesianTools/man/Twalk.Rd index c32caf6..098c150 100644 --- a/BayesianTools/man/Twalk.Rd +++ b/BayesianTools/man/Twalk.Rd @@ -12,33 +12,33 @@ Twalk( ) } \arguments{ -\item{bayesianSetup}{Object of class 'bayesianSetup' or 'bayesianOuput'.} +\item{bayesianSetup}{object of class 'bayesianSetup' or 'bayesianOuput'.} \item{settings}{list with parameter values.} -\item{iterations}{Number of model evaluations} +\item{iterations}{number of model evaluations} \item{at}{"traverse" move proposal parameter. Default to 6} \item{aw}{"walk" move proposal parameter. Default to 1.5} -\item{pn1}{Probability determining the number of parameters that are changed} +\item{pn1}{probability determining the number of parameters that are changed} -\item{Ptrav}{Move probability of "traverse" moves, default to 0.4918} +\item{Ptrav}{move probability of "traverse" moves, default to 0.4918} -\item{Pwalk}{Move probability of "walk" moves, default to 0.4918} +\item{Pwalk}{move probability of "walk" moves, default to 0.4918} -\item{Pblow}{Move probability of "traverse" moves, default to 0.0082} +\item{Pblow}{move probability of "traverse" moves, default to 0.0082} \item{burnin}{number of iterations treated as burn-in. These iterations are not recorded in the chain.} \item{thin}{thinning parameter. Determines the interval in which values are recorded.} -\item{startValue}{Matrix with start values} +\item{startValue}{matrix with start values} -\item{consoleUpdates}{Intervall in which the sampling progress is printed to the console} +\item{consoleUpdates}{intervall in which the sampling progress is printed to the console} -\item{message}{logical determines whether the sampler's progress should be printed} +\item{message}{logical, determines whether the sampler's progress should be printed} } \value{ Object of class bayesianOutput. diff --git a/BayesianTools/man/TwalkMove.Rd b/BayesianTools/man/TwalkMove.Rd index 8639ad0..06ffc78 100644 --- a/BayesianTools/man/TwalkMove.Rd +++ b/BayesianTools/man/TwalkMove.Rd @@ -21,9 +21,9 @@ TwalkMove( ) } \arguments{ -\item{Npar}{Number of parameters} +\item{Npar}{number of parameters} -\item{FUN}{Log posterior density} +\item{FUN}{log posterior density} \item{x}{parameter vector of chain 1} diff --git a/BayesianTools/man/combineChains.Rd b/BayesianTools/man/combineChains.Rd index 85fcedb..600523c 100644 --- a/BayesianTools/man/combineChains.Rd +++ b/BayesianTools/man/combineChains.Rd @@ -9,7 +9,7 @@ combineChains(x, merge = T) \arguments{ \item{x}{a list of MCMC chains} -\item{merge}{logical determines whether chains should be merged} +\item{merge}{should chains be merged? (T or F)} } \value{ combined chains diff --git a/BayesianTools/man/convertCoda.Rd b/BayesianTools/man/convertCoda.Rd index 6009f3b..e4213b0 100644 --- a/BayesianTools/man/convertCoda.Rd +++ b/BayesianTools/man/convertCoda.Rd @@ -7,22 +7,19 @@ convertCoda(sampler, names = NULL, info = NULL, likelihood = NULL) } \arguments{ -\item{sampler}{An object of class mcmc or mcmc.list} +\item{sampler}{an object of class mcmc or mcmc.list} -\item{names}{vector giving the parameter names (optional)} +\item{names}{a vector with parameter names (optional)} -\item{info}{matrix (or list with matrices for mcmc.list objects) with three coloumns containing log posterior, log likelihood and log prior of the sampler for each time step (optional; but see Details)} +\item{info}{a matrix (or list with matrices for mcmc.list objects) with three columns containing log posterior, log likelihood and log prior of the sampler for each time step (optional; but see Details)} -\item{likelihood}{likelihood function used in the sampling (see Details)} +\item{likelihood}{likelihood function used for sampling (see Details)} } \description{ -Function is used to make the plot and diagnostic functions -available for coda::mcmc objects +Function to support plotting and diagnostic functions for coda::mcmc objects. } \details{ -The parameter 'likelihood' is optional for most functions but can be needed e.g for -using the \code{\link{DIC}} function. +The parameter 'likelihood' is optional for most functions but can be needed e.g for \code{\link{DIC}} function. -Also the parameter info is optional for most uses. However for some functions (e.g. \code{\link{MAP}}) -the matrix or single coloumns (e.g. log posterior) are necessary for the diagnostics. +Also, the parameter information is typically optional for most uses. However, for certain functions (e.g. \code{\link{MAP}}), the matrix or single columns (e.g. log posterior) are necessary for diagnostics. } diff --git a/BayesianTools/man/correlationPlot.Rd b/BayesianTools/man/correlationPlot.Rd index 11d51b4..40add9b 100644 --- a/BayesianTools/man/correlationPlot.Rd +++ b/BayesianTools/man/correlationPlot.Rd @@ -25,9 +25,9 @@ correlationPlot( \item{whichParameters}{indices of parameters that should be plotted} -\item{scaleCorText}{should the text to display correlation be scaled to the strength of the correlation} +\item{scaleCorText}{should the text to display correlation be scaled to the strength of the correlation?} -\item{...}{additional parameters to pass on to the \code{\link{getSample}}, for example parametersOnly =F, or start = 1000} +\item{...}{additional parameters to pass on to the \code{\link{getSample}}, for example parametersOnly = F, or start = 1000} } \description{ Flexible function to create correlation density plots diff --git a/BayesianTools/man/createBayesianSetup.Rd b/BayesianTools/man/createBayesianSetup.Rd index 3225342..c87b551 100644 --- a/BayesianTools/man/createBayesianSetup.Rd +++ b/BayesianTools/man/createBayesianSetup.Rd @@ -37,9 +37,9 @@ createBayesianSetup( \item{names}{optional vector with parameter names} -\item{parallelOptions}{list containing three lists. First "packages" determines the R packages necessary to run the likelihood function. Second "variables" the objects in the global environment needed to run the likelihood function and third "dlls" the DLLs needed to run the likelihood function (see Details and Examples).} +\item{parallelOptions}{list containing three lists.\itemize{ \item First, "packages" determines the R packages necessary to run the likelihood function.\item Second, "variables" - the objects in the global environment needed to run the likelihood function and \item Third, "dlls" is needed to run the likelihood function (see Details and Examples).}} -\item{catchDuplicates}{Logical, determines whether unique parameter combinations should only be evaluated once. Only used when the likelihood accepts a matrix with parameter as columns.} +\item{catchDuplicates}{logical, determines whether unique parameter combinations should only be evaluated once. Only used when the likelihood accepts a matrix with parameter as columns.} \item{plotLower}{vector with lower limits for plotting} @@ -53,14 +53,14 @@ Creates a standardized collection of prior, likelihood and posterior functions, \details{ If prior is of class prior (e.g. create with \code{\link{createPrior}}), priorSampler, lower, upper and best will be ignored.\cr If prior is a function (log prior density), priorSampler (custom sampler), or lower/upper (uniform sampler) is required.\cr If prior is NULL, and lower and upper are passed, a uniform prior (see \code{\link{createUniformPrior}}) will be created with boundaries lower and upper. -For parallelization, Bayesiantools requies that the likelihood can evaluate several parameter vectors (supplied as a matrix) in parallel. +For parallelization, Bayesiantools requires that the likelihood can evaluate multiple parameter vectors (supplied as a matrix) in parallel. \itemize{ -\item parallel = T means that an automatic parallelization of the likelihood via a standard R socket cluster is attempted, using the function \code{\link{generateParallelExecuter}}. By default, of the N cores detected on the computer, N-1 cores are requested. Alternatively, you can provide a integer number to parallel, specifying the cores reserved for the cluster. When the cluster is cluster is created, a copy of your workspace, including DLLs and objects are exported to the cluster workers. Because this can be very inefficient, you can explicitly specify the packages, objects and DLLs that are to be exported via parallelOptions. Using parallel = T requires that the function to be parallelized is well encapsulate, i.e. can run on a shared memory / shared hard disk machine in parallel without interfering with each other. +\item parallel = T attempts to parallelize likelihood via a standard R socket cluster using the \code{\link{generateParallelExecuter}} function. By default, of the N cores detected on the computer, N-1 cores are requested. Alternatively, you can provide a integer number to parallel, specifying the cores reserved for the cluster. When the cluster is created, a copy of your workspace, including DLLs and objects are exported to the cluster workers. As this approach can be highly inefficient, it is recommended to explicitly specify the packages, objects and DLLs to export using parallelOptions. Using parallel = T requires that the function to be parallelized is well encapsulated, i.e. can run in parallel on a shared memory / shared hard disk machine in parallel without interfering with each other. } -If automatic parallelization cannot be done (e.g. because dlls are not thread-safe or write to shared disk), and only in this case, you should specify parallel = "external". In this case, it is assumed that the likelihood is programmed such that it accepts a matrix with parameters as columns and the different model runs as rows. It is then up to the user if and how to parallelize this function. This option gives most flexibility to the user, in particular for complicated parallel architecture or shared memory problems. +If automatic parallelization is not possible (e.g., because dlls are not thread-safe or write to shared disk), and only in this case, you should specify parallel = "external". In this case, it is assumed that the likelihood is programmed to accept a matrix with parameters as columns and the different model runs as rows. The user can then choose whether and how to parallelize this function. This option provides optimal flexibility for the user, especially regarding complicated parallel architectures or shared memory issues. -For more details on parallelization, make sure to read both vignettes, in particular the section on the likelihood in the main vignette, and the section on parallelization in the vignette on interfacing models. +For more details on parallelization, make sure to read both vignettes, especially the section on likelihood in the main vignette and the section on parallelization in the vignette on interfacing models. } \examples{ ll <- function(x) sum(dnorm(x, log = TRUE)) diff --git a/BayesianTools/man/createLikelihood.Rd b/BayesianTools/man/createLikelihood.Rd index 9b9d33b..b9ad678 100644 --- a/BayesianTools/man/createLikelihood.Rd +++ b/BayesianTools/man/createLikelihood.Rd @@ -14,17 +14,17 @@ createLikelihood( ) } \arguments{ -\item{likelihood}{Log likelihood density} +\item{likelihood}{log likelihood density} -\item{names}{Parameter names (optional)} +\item{names}{parameter names (optional)} -\item{parallel}{parallelization , either i) no parallelization --> F, ii) native R parallelization --> T / "auto" will select n-1 of your available cores, or provide a number for how many cores to use, or iii) external parallelization --> "external". External means that the likelihood is already able to execute parallel runs in form of a matrix with} +\item{parallel}{parallelization , either i) no parallelization --> F, ii) native R parallelization --> T / "auto" will select n-1 of your available cores, or provide a number for how many cores to use, or iii) external parallelization --> "external". External means that the likelihood is already able to execute parallel runs in the form of a matrix.} -\item{catchDuplicates}{Logical, determines whether unique parameter combinations should only be evaluated once. Only used when the likelihood accepts a matrix with parameter as columns.} +\item{catchDuplicates}{logical, determines whether unique parameter combinations should only be evaluated once. This is only applicable when the likelihood accepts a matrix with parameters as columns.} \item{sampler}{sampler} -\item{parallelOptions}{list containing two lists. First "packages" determines the R packages necessary to run the likelihood function. Second "objects" the objects in the global envirnment needed to run the likelihood function (for details see \code{\link{createBayesianSetup}}).} +\item{parallelOptions}{a list containing two lists. First, "packages" specifies the R packages necessary to run the likelihood function. Second, "objects" contains the objects in the global environment needed to run the likelihood function (for details see \code{\link{createBayesianSetup}}).} } \description{ Creates a standardized likelihood class#' diff --git a/BayesianTools/man/createMcmcSamplerList.Rd b/BayesianTools/man/createMcmcSamplerList.Rd index a81dc76..5f3ebde 100644 --- a/BayesianTools/man/createMcmcSamplerList.Rd +++ b/BayesianTools/man/createMcmcSamplerList.Rd @@ -7,10 +7,10 @@ createMcmcSamplerList(mcmcList) } \arguments{ -\item{mcmcList}{a list with each object being an mcmcSampler} +\item{mcmcList}{list of objects, each of which is an mcmcSampler} } \value{ -Object of class "mcmcSamplerList" +object of class "mcmcSamplerList" } \description{ Convenience function to create an object of class mcmcSamplerList from a list of mcmc samplers diff --git a/BayesianTools/man/createPosterior.Rd b/BayesianTools/man/createPosterior.Rd index d197c47..7686af3 100644 --- a/BayesianTools/man/createPosterior.Rd +++ b/BayesianTools/man/createPosterior.Rd @@ -9,13 +9,13 @@ createPosterior(prior, likelihood) \arguments{ \item{prior}{prior class} -\item{likelihood}{Log likelihood density} +\item{likelihood}{log likelihood density} } \description{ Creates a standardized posterior class } \details{ -Function is internally used in \code{\link{createBayesianSetup}} to create a standarized posterior class. +Function is internally used in \code{\link{createBayesianSetup}} to create a standardized posterior class. } \author{ Florian Hartig diff --git a/BayesianTools/man/createPrior.Rd b/BayesianTools/man/createPrior.Rd index 666dd9b..4718810 100644 --- a/BayesianTools/man/createPrior.Rd +++ b/BayesianTools/man/createPrior.Rd @@ -13,7 +13,7 @@ createPrior( ) } \arguments{ -\item{density}{Prior density} +\item{density}{prior density} \item{sampler}{Sampling function for density (optional)} @@ -27,7 +27,7 @@ createPrior( Creates a standardized prior class } \details{ -This is the general prior generator. It is highly recommended to not only implement the density, but also the sampler function. If this is not done, the user will have to provide explicit starting values for many of the MCMC samplers. Note the existing, more specialized prior function. If your prior can be created by those, they are preferred. Note also that priors can be created from an existing MCMC output from BT, or another MCMC sample, via \code{\link{createPriorDensity}}. +This is the general prior generator. It is highly recommended to implement both the density and sampler function. If not, the user will have to provide explicit starting values for many of the MCMC samplers. Note the existing, more specialized prior functions. It is recommended to use those specialized prior functions, if possible. Also note that priors can be created from an existing MCMC output from BT, or another MCMC sample, via \code{\link{createPriorDensity}}. } \note{ min and max truncate, but not re-normalize the prior density (so, if a pdf that integrated to one is truncated, the integral will in general be smaller than one). For MCMC sampling, this doesn't make a difference, but if absolute values of the prior density are a concern, one should provide a truncated density function for the prior. diff --git a/BayesianTools/man/createSmcSamplerList.Rd b/BayesianTools/man/createSmcSamplerList.Rd index 11208b2..735ce36 100644 --- a/BayesianTools/man/createSmcSamplerList.Rd +++ b/BayesianTools/man/createSmcSamplerList.Rd @@ -10,7 +10,7 @@ createSmcSamplerList(...) \item{...}{a list of MCMC samplers} } \value{ -a list of class smcSamplerList with each object being an smcSampler +a list of class smcSamplerList with objects of smcSampler } \description{ Convenience function to create an object of class SMCSamplerList from a list of mcmc samplers diff --git a/BayesianTools/man/generateCRvalues.Rd b/BayesianTools/man/generateCRvalues.Rd index 41e6302..6f0a81c 100644 --- a/BayesianTools/man/generateCRvalues.Rd +++ b/BayesianTools/man/generateCRvalues.Rd @@ -7,9 +7,9 @@ generateCRvalues(pCR, settings, Npop) } \arguments{ -\item{pCR}{Vector of crossover probabilities. Needs to be of length nCR.} +\item{pCR}{vector of crossover probabilities. Needs to be of length nCR.} -\item{settings}{settings list} +\item{settings}{list of settings} \item{Npop}{number of chains} } diff --git a/BayesianTools/man/getBlockSettings.Rd b/BayesianTools/man/getBlockSettings.Rd index 6c29a25..a0bd314 100644 --- a/BayesianTools/man/getBlockSettings.Rd +++ b/BayesianTools/man/getBlockSettings.Rd @@ -13,6 +13,6 @@ getBlockSettings(blockUpdate) list with block settings } \description{ -Transforms the original settings in settings used in the model runs +Transforms the original settings to settings used in the model runs } \keyword{internal} diff --git a/BayesianTools/man/getSample.Rd b/BayesianTools/man/getSample.Rd index 900847f..d72d774 100644 --- a/BayesianTools/man/getSample.Rd +++ b/BayesianTools/man/getSample.Rd @@ -148,15 +148,15 @@ getSample( \item{parametersOnly}{for a BT output, if F, likelihood, posterior and prior values are also provided in the output} -\item{coda}{works only for mcmc classes - provides output as a coda object. Note: if mcmcSamplerList contains mcmc samplers such as DE that have several chains, the internal chains will be collapsed. This may not be the desired behavior for all applications.} +\item{coda}{works only for mcmc classes - returns output as a coda object. Note: if mcmcSamplerList contains mcmc samplers such as DE that have several chains, the internal chains will be collapsed. This may not be desired for all applications.} -\item{start}{for mcmc samplers start value in the chain. For SMC samplers, start particle} +\item{start}{for mcmc samplers, start value in the chain. For SMC samplers, start particle} \item{end}{for mcmc samplers end value in the chain. For SMC samplers, end particle} -\item{thin}{thinning parameter. Either an integer determining the thinning intervall (default is 1) or "auto" for automatic thinning.} +\item{thin}{thinning parameter. Either an integer determining the thinning interval (default is 1) or "auto" for automatic thinning.} -\item{numSamples}{sample size (only used if thin = 1). If you want to use numSamples set thin to 1.} +\item{numSamples}{sample size (only used if thin = 1). If you want to use numSamples, set thin to 1.} \item{whichParameters}{possibility to select parameters by index} @@ -168,9 +168,9 @@ getSample( Extracts the sample from a bayesianOutput } \details{ -If thin is greater than the total number of samples in the sampler object the first and the last element (of each chain if a sampler with multiples chains is used) are sampled. If numSamples is greater than the total number of samples all samples are selected. In both cases a warning is displayed. +If thin is greater than the total number of samples in the sampler object, the first and the last element (of each chain if a sampler with multiples chains is used) are sampled. If numSamples is greater than the total number of samples all samples are selected. A warning will be displayed in both cases. -If thin and numSamples is passed, the function will use the thin argument if it is valid and greater than 1, else numSamples will be used. +If both thin and numSamples are provided, the function will use thin only if it is valid and greater than 1; otherwise, numSamples will be used. } \examples{ ll = function(x) sum(dnorm(x, log = TRUE)) diff --git a/BayesianTools/man/getVolume.Rd b/BayesianTools/man/getVolume.Rd index 9d63ed9..55e4659 100644 --- a/BayesianTools/man/getVolume.Rd +++ b/BayesianTools/man/getVolume.Rd @@ -7,9 +7,9 @@ getVolume(sampler, prior = F, method = "MVN", ...) } \arguments{ -\item{sampler}{an object of superclass bayesianOutput or any other class that has the getSample function implemented (e.g. Matrix)} +\item{sampler}{an object of superclass bayesianOutput or any other class that has implemented the getSample function (e.g. Matrix)} -\item{prior}{schould also prior volume be calculated} +\item{prior}{logical, should prior volume be calculated?} \item{method}{method for volume estimation. Currently, the only option is "MVN"} @@ -19,7 +19,7 @@ getVolume(sampler, prior = F, method = "MVN", ...) Calculate posterior volume } \details{ -The idea of this function is to provide an estimate of the "posterior volume", i.e. how "broad" the posterior is. One potential application is to the overall reduction of parametric uncertainty between different data types, or between prior and posterior. +The idea of this function is to provide an estimate of the "posterior volume", i.e. how "broad" the posterior is. One potential application is the overall reduction of parametric uncertainty between different data types, or between prior and posterior. Implemented methods for volume estimation: diff --git a/BayesianTools/man/makeObjectClassCodaMCMC.Rd b/BayesianTools/man/makeObjectClassCodaMCMC.Rd index ccabf2c..d442a60 100644 --- a/BayesianTools/man/makeObjectClassCodaMCMC.Rd +++ b/BayesianTools/man/makeObjectClassCodaMCMC.Rd @@ -9,14 +9,14 @@ makeObjectClassCodaMCMC(chain, start = 1, end = numeric(0), thin = 1) \arguments{ \item{chain}{mcmc Chain} -\item{start}{for mcmc samplers start value in the chain. For SMC samplers, start particle} +\item{start}{For MCMC samplers, the initial value in the chain. For SMC samplers, initial particle} -\item{end}{for mcmc samplers end value in the chain. For SMC samplers, end particle} +\item{end}{For MCMC samplers, the end value in the chain. For SMC samplers, end particle.} \item{thin}{thinning parameter} } \value{ -object of class coda::mcmc +object an object of class coda::mcmc } \description{ Helper function to change an object to a coda mcmc class, diff --git a/BayesianTools/man/marginalLikelihood.Rd b/BayesianTools/man/marginalLikelihood.Rd index dabc68e..7efabf0 100644 --- a/BayesianTools/man/marginalLikelihood.Rd +++ b/BayesianTools/man/marginalLikelihood.Rd @@ -16,7 +16,7 @@ marginalLikelihood(sampler, numSamples = 1000, method = "Chib", ...) \item{...}{further arguments passed to \code{\link{getSample}}} } \value{ -A list with log of the marginal likelihood, as well as other diagnostics depending on the chose method +A list with log of the marginal likelihood, as well as other diagnostics depending on the chosen method } \description{ Calcluated the marginal likelihood from a set of MCMC samples @@ -32,11 +32,11 @@ Given that MLs are calculated for each model, you can get posterior weights (for In BT, we return the log ML, so you will have to exp all values for this formula. -It is well-known that the ML is VERY dependent on the prior, and in particular the choice of the width of uninformative priors may have major impacts on the relative weights of the models. It has therefore been suggested to not use the ML for model averaging / selection on uninformative priors. If you have no informative priors, and option is to split the data into two parts, use one part to generate informative priors for the model, and the second part for the model selection. See help for an example. +It is well-known that the ML is strongly dependent on the prior, and in particular the choice of the width of uninformative priors may have major impacts on the relative weights of the models. It has therefore been suggested to not use the ML for model averaging / selection on uninformative priors. If you have no informative priors, and option is to split the data into two parts, use one part to generate informative priors for the model, and the second part for the model selection. See help for an example. The marginalLikelihood function currently implements four ways to calculate the marginal likelihood. Be aware that marginal likelihood calculations are notoriously prone to numerical stability issues. Especially in high-dimensional parameter spaces, there is no guarantee that any of the implemented algorithms will converge reasonably fast. The recommended (and default) method is the method "Chib" (Chib and Jeliazkov, 2001), which is based on MCMC samples, with a limited number of additional calculations. Despite being the current recommendation, note there are some numeric issues with this algorithm that may limit reliability for larger dimensions. -The harmonic mean approximation, is implemented only for comparison. Note that the method is numerically unrealiable and usually should not be used. +The harmonic mean approximation, is implemented only for comparison. Note that the method is numerically unreliable and usually should not be used. The third method is simply sampling from the prior. While in principle unbiased, it will only converge for a large number of samples, and is therefore numerically inefficient. diff --git a/BayesianTools/man/marginalPlot.Rd b/BayesianTools/man/marginalPlot.Rd index 3c35ef3..5d7d762 100644 --- a/BayesianTools/man/marginalPlot.Rd +++ b/BayesianTools/man/marginalPlot.Rd @@ -16,17 +16,17 @@ marginalPlot( ) } \arguments{ -\item{x}{bayesianOutput, or matrix or data.frame containing with samples as rows and parameters as columns} +\item{x}{bayesianOutput, or matrix or data.frame with samples as rows and parameters as columns} -\item{prior}{if x is a bayesianOutput, T/F will determine if the prior is drawn (default = T). If x is matrix oder data.frame, a prior can be drawn if a matrix of prior draws with values as rows and parameters as columns can be provided here.} +\item{prior}{if x is a bayesianOutput, T/F will determines whether the prior is drawn (default = T). If x is matrix or data.frame, a prior can be drawn if a matrix of prior draws with values as rows and parameters as columns can be provided here.} -\item{xrange}{vector or matrix of plotting ranges for the x axis. If matrix, the rows must be parameters and the columns min and max values.} +\item{xrange}{vector or matrix of plot ranges for the x-axis. If matrix, the rows must be parameters and the columns must be min and max values.} -\item{type}{character determining the plot type. Either 'd' for density plot, or 'v' for violin plot} +\item{type}{character, determes the plot type. Either 'd' for density plot, or 'v' for violin plot} -\item{singlePanel}{logical, determining whether the parameter should be plotted in a single panel or each in its own panel} +\item{singlePanel}{logical, determines whether the parameter should be plotted in a single panel or each in its own panel} -\item{settings}{optional list of additional settings for \code{\link{marginalPlotDensity}}, and \code{\link{marginalPlotViolin}}, respectively} +\item{settings}{optional, list of additional settings for \code{\link{marginalPlotDensity}}, and \code{\link{marginalPlotViolin}}, respectively} \item{nPriorDraws}{number of draws from the prior, if x is bayesianOutput} diff --git a/BayesianTools/man/mcmcMultipleChains.Rd b/BayesianTools/man/mcmcMultipleChains.Rd index 8cbdcec..d6ad683 100644 --- a/BayesianTools/man/mcmcMultipleChains.Rd +++ b/BayesianTools/man/mcmcMultipleChains.Rd @@ -7,7 +7,7 @@ mcmcMultipleChains(bayesianSetup, settings, sampler) } \arguments{ -\item{bayesianSetup}{Object of class "BayesianSetup"} +\item{bayesianSetup}{object of class "BayesianSetup"} \item{settings}{list with settings for sampler} diff --git a/BayesianTools/man/plotDiagnostic.Rd b/BayesianTools/man/plotDiagnostic.Rd index a2394e6..471fcd8 100644 --- a/BayesianTools/man/plotDiagnostic.Rd +++ b/BayesianTools/man/plotDiagnostic.Rd @@ -26,13 +26,13 @@ plotDiagnostic( \item{window}{plot range to show, vector of percents or only one value as start value for the window} -\item{plotWAIC}{whether to calculate WAIC or not, default = T} +\item{plotWAIC}{logical, whether to calculate WAIC or not, default = T} -\item{plotPSRF}{calculate and plot mPSRF/PSRF or not, default = T} +\item{plotPSRF}{logical, whether to calculate and plot mPSRF/PSRF or not, default = T} -\item{plotDIC}{calculate and plot DICor not, default = T} +\item{plotDIC}{logical, whether to calculate and plot DIC or not, default = T} -\item{plotTrace}{show trace plots or not, default = T} +\item{plotTrace}{logical, whether to show trace plots or not, default = T} \item{graphicParameters}{graphic parameters as list for plot function} diff --git a/BayesianTools/man/plotSensitivity.Rd b/BayesianTools/man/plotSensitivity.Rd index 4546ed4..53830e9 100644 --- a/BayesianTools/man/plotSensitivity.Rd +++ b/BayesianTools/man/plotSensitivity.Rd @@ -7,11 +7,11 @@ plotSensitivity(bayesianSetup, selection = NULL, equalScale = T) } \arguments{ -\item{bayesianSetup}{An object of class BayesianSetup} +\item{bayesianSetup}{an object of class BayesianSetup} \item{selection}{indices of selected parameters} -\item{equalScale}{if T, y axis of all plots will have the same scale} +\item{equalScale}{if T, y-axis of all plots will have the same scale} } \description{ Performs a one-factor-at-a-time sensitivity analysis for the posterior of a given bayesianSetup within the prior range. diff --git a/BayesianTools/man/runMCMC.Rd b/BayesianTools/man/runMCMC.Rd index 6c5506d..20b6687 100644 --- a/BayesianTools/man/runMCMC.Rd +++ b/BayesianTools/man/runMCMC.Rd @@ -44,7 +44,7 @@ The MCMC samplers will have a number of additional settings, which are described Note that even if you specify parallel = T, this will only turn on internal parallelization of the samplers. The independent samplers controlled by nrChains are not evaluated in parallel, so if time is an issue it will be better to run the MCMCs individually and then combine them via \code{\link{createMcmcSamplerList}} into one joint object. -Note that DE and DREAM variants as well as SMC and T-walk require a population to start, which should be provided as a matrix. Default (NULL) sets the population size for DE to 3 x dimensions of parameters, for DREAM to 2 x dimensions of parameters and for DEzs and DREAMzs to three, sampled from the prior. Note also that the zs variants of DE and DREAM require two populations, the current population and the z matrix (a kind of memory) - if you want to set both, provide a list with startvalue$X and startvalue$Z. +Note that, DE and DREAM variants as well as SMC and T-walk require a population to start, which should be provided as a matrix. Default (NULL) sets the population size for DE to 3 x dimensions of parameters, for DREAM to 2 x dimensions of parameters and for DEzs and DREAMzs to three, sampled from the prior. Note also that the zs variants of DE and DREAM require two populations, the current population and the z matrix (a kind of memory) - if you want to set both, provide a list with startvalue$X and startvalue$Z. setting startValue for sampling with nrChains > 1 : if you want to provide different start values for the different chains, provide them as a list } diff --git a/BayesianTools/man/tracePlot.Rd b/BayesianTools/man/tracePlot.Rd index 50afc14..c4d0eb4 100644 --- a/BayesianTools/man/tracePlot.Rd +++ b/BayesianTools/man/tracePlot.Rd @@ -9,9 +9,9 @@ tracePlot(sampler, thin = "auto", ...) \arguments{ \item{sampler}{an object of class MCMC sampler} -\item{thin}{determines the thinning intervall of the chain} +\item{thin}{determines the thinning interval of the chain} -\item{...}{additional parameters to pass on to the \code{\link{getSample}}, for example parametersOnly =F, or start = 1000} +\item{...}{additional parameters to pass on to the \code{\link{getSample}}, for example parametersOnly = F, or start = 1000} } \description{ Trace plot for MCMC class diff --git a/BayesianTools/man/updateGroups.Rd b/BayesianTools/man/updateGroups.Rd index 2067ea3..b41d85c 100644 --- a/BayesianTools/man/updateGroups.Rd +++ b/BayesianTools/man/updateGroups.Rd @@ -9,7 +9,7 @@ updateGroups(chain, blockSettings) \arguments{ \item{chain}{MCMC chain including only the parameters (not logP,ll, logP)} -\item{blockSettings}{list with settings} +\item{blockSettings}{a list with settings} } \value{ groups From 919d0c601e8d31fe25075db592c40b83b8d57d43 Mon Sep 17 00:00:00 2001 From: TahminaMojumder Date: Fri, 27 Oct 2023 11:34:01 +0200 Subject: [PATCH 08/13] update --- BayesianTools/R/blockUpdate.R | 180 +++++++++++++++++----------------- 1 file changed, 90 insertions(+), 90 deletions(-) diff --git a/BayesianTools/R/blockUpdate.R b/BayesianTools/R/blockUpdate.R index ec3d9f3..9bd796f 100644 --- a/BayesianTools/R/blockUpdate.R +++ b/BayesianTools/R/blockUpdate.R @@ -1,90 +1,90 @@ -#' Determine the groups of correlated parameters -#' @author Stefan Paul -#' @param chain MCMC chain including only the parameters (not logP,ll, logP) -#' @param blockSettings a list with settings -#' @return groups -#' @keywords internal -updateGroups <- function(chain,blockSettings){ - - settings <- getBlockSettings(blockSettings) - blockUpdateType <- settings$blockUpdateType - - switch(blockUpdateType, - "correlation" = { - ## (Pair wise) Correlation in the parameters - cormat <- abs(cor(chain[,1:(ncol(chain)-3),sample(1:dim(chain)[3],1)])) - diag(cormat) <- 0 - # Correct for NA and Inf values as this could cause error in as.dist() - cormat[c(which(is.na(cormat)),which(cormat == Inf),which(cormat == -Inf)) ] <- 0 - tree <- hclust(as.dist(1-cormat)) # get tree based on distance(dissimilarity = 1-cor). - cT <- cutree(tree, k = settings$k, h = settings$h) # get groups. With h we can manipulate the strength of the interaction. - }, - "user" = { - cT <- settings$groups - }, - "random" = { - pool <- c(1:settings$k, sample(1:settings$k, (ncol(chain)-3-settings$k))) - cT <- sample(pool) - } - ) - - pSel <- settings$pSel - if(is.null(pSel) && is.null(settings$pGroup)) pSel = rep(1,ncol(chain)-3) - return(list(cT = cT, pGroup = settings$pGroup, pSel = pSel)) -} - - -#' Determine the parameters in the block update -#' @param blockSettings settings for block update -#' @return vector containing the parameter to be updated -#' @keywords internal -getBlock <- function(blockSettings){ - groups <- blockSettings$cT - pGroup <- blockSettings$pGroup - pSel <- blockSettings$pSel - - - nGroups = max(groups) - if(nGroups == 1) return(1:length(groups)) - if (is.null(pGroup)) pGroup = rep(1,nGroups) - if(length(pSel) > nGroups) pSel <- pSel[1:nGroups] - pSel = c(pSel, rep(0,nGroups - length(pSel))) - groupsToSample = sample.int(nGroups, 1, prob = pSel) - - selectedGroups = sample.int(nGroups,groupsToSample, prob = pGroup[1:nGroups]) - GroupMember <- which(is.element(groups,selectedGroups)) - return(GroupMember) - -} - - -#' getblockSettings -#' @description Transforms the original settings to settings used in the model runs -#' @param blockUpdate input settings -#' @return list with block settings -#' @keywords internal -getBlockSettings <- function(blockUpdate){ - - h <- k <- pSel <- pGroup <- groups <- NULL - blockUpdateType <- blockUpdate[[1]] - - switch(blockUpdateType, - "correlation" = { - h <- blockUpdate$h - k <- blockUpdate$k - pSel <- blockUpdate$pSel - pGroup <- blockUpdate$pGroup - }, - "random"={ - k <- blockUpdate$k - }, - "user"= { - groups <- blockUpdate$groups - pSel <- blockUpdate$pSel - pGroup <- blockUpdate$pGroup - }) - - return(list(blockUpdateType = blockUpdateType, h = h, k = k, pSel = pSel, - pGroup = pGroup, groups = groups)) - } - +#' Determine the groups of correlated parameters +#' @author Stefan Paul +#' @param chain MCMC chain including only the parameters (not logP, ll, logP) +#' @param blockSettings a list with settings +#' @return groups +#' @keywords internal +updateGroups <- function(chain,blockSettings){ + + settings <- getBlockSettings(blockSettings) + blockUpdateType <- settings$blockUpdateType + + switch(blockUpdateType, + "correlation" = { + ## (Pair wise) Correlation in the parameters + cormat <- abs(cor(chain[,1:(ncol(chain)-3),sample(1:dim(chain)[3],1)])) + diag(cormat) <- 0 + # Correct for NA and Inf values as this could cause error in as.dist() + cormat[c(which(is.na(cormat)),which(cormat == Inf),which(cormat == -Inf)) ] <- 0 + tree <- hclust(as.dist(1-cormat)) # get tree based on distance(dissimilarity = 1-cor). + cT <- cutree(tree, k = settings$k, h = settings$h) # get groups. With h we can manipulate the strength of the interaction. + }, + "user" = { + cT <- settings$groups + }, + "random" = { + pool <- c(1:settings$k, sample(1:settings$k, (ncol(chain)-3-settings$k))) + cT <- sample(pool) + } + ) + + pSel <- settings$pSel + if(is.null(pSel) && is.null(settings$pGroup)) pSel = rep(1,ncol(chain)-3) + return(list(cT = cT, pGroup = settings$pGroup, pSel = pSel)) +} + + +#' Determine the parameters in the block update +#' @param blockSettings settings for block update +#' @return vector containing the parameter to be updated +#' @keywords internal +getBlock <- function(blockSettings){ + groups <- blockSettings$cT + pGroup <- blockSettings$pGroup + pSel <- blockSettings$pSel + + + nGroups = max(groups) + if(nGroups == 1) return(1:length(groups)) + if (is.null(pGroup)) pGroup = rep(1,nGroups) + if(length(pSel) > nGroups) pSel <- pSel[1:nGroups] + pSel = c(pSel, rep(0,nGroups - length(pSel))) + groupsToSample = sample.int(nGroups, 1, prob = pSel) + + selectedGroups = sample.int(nGroups,groupsToSample, prob = pGroup[1:nGroups]) + GroupMember <- which(is.element(groups,selectedGroups)) + return(GroupMember) + +} + + +#' getblockSettings +#' @description Transforms the original settings to settings used in the model runs +#' @param blockUpdate input settings +#' @return list with block settings +#' @keywords internal +getBlockSettings <- function(blockUpdate){ + + h <- k <- pSel <- pGroup <- groups <- NULL + blockUpdateType <- blockUpdate[[1]] + + switch(blockUpdateType, + "correlation" = { + h <- blockUpdate$h + k <- blockUpdate$k + pSel <- blockUpdate$pSel + pGroup <- blockUpdate$pGroup + }, + "random"={ + k <- blockUpdate$k + }, + "user"= { + groups <- blockUpdate$groups + pSel <- blockUpdate$pSel + pGroup <- blockUpdate$pGroup + }) + + return(list(blockUpdateType = blockUpdateType, h = h, k = k, pSel = pSel, + pGroup = pGroup, groups = groups)) + } + From 0653ed775ec6041e314b9d8550d5d43a30228278 Mon Sep 17 00:00:00 2001 From: TahminaMojumder Date: Fri, 27 Oct 2023 12:14:55 +0200 Subject: [PATCH 09/13] removing white space --- BayesianTools/R/classBayesianOutput.R | 500 +++++++++++++------------- BayesianTools/R/classLikelihood.R | 331 +++++++++-------- BayesianTools/R/classMcmcSampler.R | 1 - BayesianTools/R/classPosterior.R | 113 +++--- 4 files changed, 469 insertions(+), 476 deletions(-) diff --git a/BayesianTools/R/classBayesianOutput.R b/BayesianTools/R/classBayesianOutput.R index 96c0583..3739fe0 100644 --- a/BayesianTools/R/classBayesianOutput.R +++ b/BayesianTools/R/classBayesianOutput.R @@ -1,252 +1,248 @@ -# NOTE: The functions in this class are just templates that are to be implemented for all subclasses of BayesianOutput. They are not functional. - - -#' Extracts the sample from a bayesianOutput -#' @author Florian Hartig -#' @param sampler an object of class mcmcSampler, mcmcSamplerList, smcSampler, smcSamplerList, mcmc, mcmc.list, double, numeric -#' @param parametersOnly for a BT output, if F, likelihood, posterior and prior values are also provided in the output -#' @param coda works only for mcmc classes - returns output as a coda object. Note: if mcmcSamplerList contains mcmc samplers such as DE that have several chains, the internal chains will be collapsed. This may not be desired for all applications. -#' @param start for mcmc samplers, start value in the chain. For SMC samplers, start particle -#' @param end for mcmc samplers end value in the chain. For SMC samplers, end particle -#' @param thin thinning parameter. Either an integer determining the thinning interval (default is 1) or "auto" for automatic thinning. -#' @param numSamples sample size (only used if thin = 1). If you want to use numSamples, set thin to 1. -#' @param whichParameters possibility to select parameters by index -#' @param reportDiagnostics logical, determines whether settings should be included in the output -#' @param ... further arguments -#' @example /inst/examples/getSampleHelp.R -#' @details If thin is greater than the total number of samples in the sampler object, the first and the last element (of each chain if a sampler with multiples chains is used) are sampled. If numSamples is greater than the total number of samples all samples are selected. A warning will be displayed in both cases. -#' @details If both thin and numSamples are provided, the function will use thin only if it is valid and greater than 1; otherwise, numSamples will be used. -#' @export -getSample <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = 1, numSamples = NULL, whichParameters = NULL, reportDiagnostics = FALSE, ...) UseMethod("getSample") - - - -#' @rdname getSample -#' @author Florian Hartig -#' @export -getSample.matrix <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ - - if(is.null(end)) end = nrow(sampler) - - out = sampler[start:end,, drop=F] - - ######################## - # THINNING - nTotalSamples <- nrow(out) - thin <- correctThin(nTotalSamples, thin = thin) - - if (thin == 1 && !is.null(numSamples)) { - out <- sampleEquallySpaced(out, numSamples) - } else { - sel = seq(1, nTotalSamples, by = thin) - out = out[sel,, drop=F] - } - - if (!is.null(whichParameters)) out = out[,whichParameters, drop = FALSE] - if(coda == T) out = makeObjectClassCodaMCMC(out, start = start, end = end, thin = thin) - - if(reportDiagnostics == T){ - return(list(chain = out, start = start, end = end, thin = thin)) - } else return(out) -} - - -#' @rdname getSample -#' @author Tankred Ott -#' @export -# TODO: This is right now only a helper function for getSample.mcmc. It is needed to return a vector istead of a matrix, if -# the mcmc object passed to getSample.mcmc contains a vector. -getSample.double <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ - if(is.null(end)) end = length(sampler) - out <- sampler[start:end] - - nTotalSamples <- length(out) - - thin = correctThin(nTotalSamples, thin) - - if (thin == 1 && !is.null(numSamples)) { - out <- sampleEquallySpaced(out, numSamples) - } else { - sel = seq(1, nTotalSamples, by = thin) - out = out[sel] - } - - return(out) -} - - -#' @rdname getSample -#' @author Tankred Ott -#' @export -# TODO: This is right now only a helper function for getSample.mcmc. It is needed to return a vector instead of a matrix, if -# the mcmc object passed to getSample.mcmc contains a vector. -getSample.integer <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ - if(is.null(end)) end = length(sampler) - out <- sampler[start:end] - - nTotalSamples <- length(out) - - thin = correctThin(nTotalSamples, thin) - - if (thin == 1 && !is.null(numSamples)) { - out <- sampleEquallySpaced(out, numSamples) - } else { - sel = seq(1, nTotalSamples, by = thin) - out = out[sel] - } - - return(out) -} - -#' @rdname getSample -#' @author Tankred Ott -#' @export -getSample.data.frame <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ - getSample(as.matrix(sampler), parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, whichParameters = whichParameters, reportDiagnostics = reportDiagnostics) -} - -#' @rdname getSample -#' @author Tankred Ott -#' @export -getSample.list <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ - - if(!is.null(numSamples)) numSamples = ceiling(numSamples/length(sampler)) - - if(coda == F){ - # out = NULL - out <- rep(list(NA), length(sampler)) - for (i in 1:length(sampler)){ - # out = rbind(out, getSample(sampler[[i]], parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics= F)) - out[[i]] <- getSample(sampler[[i]], parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics= F) - } - out <- combineChains(out) - } - - if(coda == T){ - - out = list() - - for (i in 1:length(sampler)){ - - out[[i]] = getSample(sampler[[i]], parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics= F) - } - - if(inherits(out[[1]], "mcmc.list")) out = unlist(out, recursive = F) - class(out) = "mcmc.list" - out = out - } - - return(out) -} - -# The following two S3 implementations make getSample compatible with coda::mcmc and coda::mcmc.list - -#' @rdname getSample -#' @author Tankred Ott -#' @export -getSample.mcmc <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ - - if(coda == T){ - # mcmc objects can contain matrices or vectors - if (is.matrix(sampler)) { - nTotalSamples <- nrow(sampler) - } else { - nTotalSamples <- length(sampler) - } - - if (is.null(end)) end = nTotalSamples - - # check/correct thin - thin <- correctThin(nTotalSamples, thin) - - # see http://svitsrv25.epfl.ch/R-doc/library/coda/html/window.mcmc.html - # for coda's window implementation - return(window(sampler, start = start, end = end, thin = thin)) - - } else if(coda == F){ - # mcmc objects can contain matrices or vectors - # TODO: do vector case as 1-d matrix? - if (is.matrix(sampler)) { - out <- getSample(as.matrix(sampler), parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics = reportDiagnostics) - } else { - out <- getSample(as.vector(sampler), parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics = reportDiagnostics) - } - return(out) - } -} - - -#' @author Tankred Ott -#' @rdname getSample -#' @export -getSample.mcmc.list <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ - - # TODO: implement handling of wrong inputs? - - if(coda == T){ - - if (is.matrix(sampler[[1]])) { - nTotalSamples <- nrow(sampler[[1]]) - } else { - nTotalSamples <- length(sampler[[1]]) - } - - if (is.null(end)) end = nTotalSamples - - # check/correct thin - thin <- correctThin(nTotalSamples, thin) - - # see http://svitsrv25.epfl.ch/R-doc/library/coda/html/window.mcmc.html - # for coda's window implementation - return(window(sampler, start = start, end = end, thin = thin)) - - } else if(coda == F){ - if(is.matrix(sampler[[1]])) { - return(getSample(combineChains(sampler), parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics = reportDiagnostics)) - } else { - return(as.vector(getSample(combineChains(sampler), parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics = reportDiagnostics))) - } - } -} - - -# getSample implementation for nimble objects of class MCMC - -#' @rdname getSample -#' @author Tankred Ott -#' @export -getSample.MCMC <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ - return(getSample(as.matrix(sampler$mvSamples), parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics = reportDiagnostics)) -} - -#' @rdname getSample -#' @author Tankred Ott -#' @export -getSample.MCMC_refClass <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ - return(getSample(as.matrix(sampler$mvSamples), parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics = reportDiagnostics)) -} - - -#' Merge Chains -#' -#' Merge a list of outputs from MCMC / SMC samplers -#' -#' The function merges a list of outputs from MCMC / SMC samplers into a single matrix. Requirement is that the list contains classes for which the \code{\link{getSample}} function works -#' -#' @param l a list with objects that can be accessed with \code{\link{getSample}} -#' @param ... arguments to be passed on to \code{\link{getSample}} -#' -#' @return a matrix -#' -#' @author Florian Hartig -#' -#' @export -mergeChains <- function(l, ...){ - - x = getSample(l[[1]], ...) - - for(i in 2:length(l)){ - x = rbind(x, getSample(l[[i]], ...)) - } - return(x) -} +# NOTE: The functions in this class are just templates that are to be implemented for all subclasses of BayesianOutput. They are not functional. + +#' Extracts the sample from a bayesianOutput +#' @author Florian Hartig +#' @param sampler an object of class mcmcSampler, mcmcSamplerList, smcSampler, smcSamplerList, mcmc, mcmc.list, double, numeric +#' @param parametersOnly for a BT output, if F, likelihood, posterior and prior values are also provided in the output +#' @param coda works only for mcmc classes - returns output as a coda object. Note: if mcmcSamplerList contains mcmc samplers such as DE that have several chains, the internal chains will be collapsed. This may not be desired for all applications. +#' @param start for mcmc samplers, start value in the chain. For SMC samplers, start particle +#' @param end for mcmc samplers end value in the chain. For SMC samplers, end particle +#' @param thin thinning parameter. Either an integer determining the thinning interval (default is 1) or "auto" for automatic thinning. +#' @param numSamples sample size (only used if thin = 1). If you want to use numSamples, set thin to 1. +#' @param whichParameters possibility to select parameters by index +#' @param reportDiagnostics logical, determines whether settings should be included in the output +#' @param ... further arguments +#' @example /inst/examples/getSampleHelp.R +#' @details If thin is greater than the total number of samples in the sampler object, the first and the last element (of each chain if a sampler with multiples chains is used) are sampled. If numSamples is greater than the total number of samples all samples are selected. A warning will be displayed in both cases. +#' @details If both thin and numSamples are provided, the function will use thin only if it is valid and greater than 1; otherwise, numSamples will be used. +#' @export +getSample <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = 1, numSamples = NULL, whichParameters = NULL, reportDiagnostics = FALSE, ...) UseMethod("getSample") + + + +#' @rdname getSample +#' @author Florian Hartig +#' @export +getSample.matrix <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ + + if(is.null(end)) end = nrow(sampler) + + out = sampler[start:end,, drop=F] + + ######################## + # THINNING + nTotalSamples <- nrow(out) + thin <- correctThin(nTotalSamples, thin = thin) + + if (thin == 1 && !is.null(numSamples)) { + out <- sampleEquallySpaced(out, numSamples) + } else { + sel = seq(1, nTotalSamples, by = thin) + out = out[sel,, drop=F] + } + + if (!is.null(whichParameters)) out = out[,whichParameters, drop = FALSE] + if(coda == T) out = makeObjectClassCodaMCMC(out, start = start, end = end, thin = thin) + + if(reportDiagnostics == T){ + return(list(chain = out, start = start, end = end, thin = thin)) + } else return(out) +} + + +#' @rdname getSample +#' @author Tankred Ott +#' @export +# TODO: This is right now only a helper function for getSample.mcmc. It is needed to return a vector istead of a matrix, if +# the mcmc object passed to getSample.mcmc contains a vector. +getSample.double <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ + if(is.null(end)) end = length(sampler) + out <- sampler[start:end] + + nTotalSamples <- length(out) + + thin = correctThin(nTotalSamples, thin) + + if (thin == 1 && !is.null(numSamples)) { + out <- sampleEquallySpaced(out, numSamples) + } else { + sel = seq(1, nTotalSamples, by = thin) + out = out[sel] + } + + return(out) +} + + +#' @rdname getSample +#' @author Tankred Ott +#' @export +# TODO: This is right now only a helper function for getSample.mcmc. It is needed to return a vector instead of a matrix, if +# the mcmc object passed to getSample.mcmc contains a vector. +getSample.integer <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ + if(is.null(end)) end = length(sampler) + out <- sampler[start:end] + + nTotalSamples <- length(out) + + thin = correctThin(nTotalSamples, thin) + + if (thin == 1 && !is.null(numSamples)) { + out <- sampleEquallySpaced(out, numSamples) + } else { + sel = seq(1, nTotalSamples, by = thin) + out = out[sel] + } + + return(out) +} + +#' @rdname getSample +#' @author Tankred Ott +#' @export +getSample.data.frame <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ + getSample(as.matrix(sampler), parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, whichParameters = whichParameters, reportDiagnostics = reportDiagnostics) +} + +#' @rdname getSample +#' @author Tankred Ott +#' @export +getSample.list <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ + + if(!is.null(numSamples)) numSamples = ceiling(numSamples/length(sampler)) + + if(coda == F){ + # out = NULL + out <- rep(list(NA), length(sampler)) + for (i in 1:length(sampler)){ + # out = rbind(out, getSample(sampler[[i]], parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics= F)) + out[[i]] <- getSample(sampler[[i]], parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics= F) + } + out <- combineChains(out) + } + + if(coda == T){ + + out = list() + + for (i in 1:length(sampler)){ + + out[[i]] = getSample(sampler[[i]], parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics= F) + } + + if(inherits(out[[1]], "mcmc.list")) out = unlist(out, recursive = F) + class(out) = "mcmc.list" + out = out + } + + return(out) +} + +# The following two S3 implementations make getSample compatible with coda::mcmc and coda::mcmc.list + +#' @rdname getSample +#' @author Tankred Ott +#' @export +getSample.mcmc <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ + + if(coda == T){ + # mcmc objects can contain matrices or vectors + if (is.matrix(sampler)) { + nTotalSamples <- nrow(sampler) + } else { + nTotalSamples <- length(sampler) + } + + if (is.null(end)) end = nTotalSamples + + # check/correct thin + thin <- correctThin(nTotalSamples, thin) + + # see http://svitsrv25.epfl.ch/R-doc/library/coda/html/window.mcmc.html + # for coda's window implementation + return(window(sampler, start = start, end = end, thin = thin)) + + } else if(coda == F){ + # mcmc objects can contain matrices or vectors + # TODO: do vector case as 1-d matrix? + if (is.matrix(sampler)) { + out <- getSample(as.matrix(sampler), parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics = reportDiagnostics) + } else { + out <- getSample(as.vector(sampler), parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics = reportDiagnostics) + } + return(out) + } +} + + +#' @author Tankred Ott +#' @rdname getSample +#' @export +getSample.mcmc.list <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ + + # TODO: implement handling of wrong inputs? + + if(coda == T){ + + if (is.matrix(sampler[[1]])) { + nTotalSamples <- nrow(sampler[[1]]) + } else { + nTotalSamples <- length(sampler[[1]]) + } + + if (is.null(end)) end = nTotalSamples + + # check/correct thin + thin <- correctThin(nTotalSamples, thin) + + # see http://svitsrv25.epfl.ch/R-doc/library/coda/html/window.mcmc.html + # for coda's window implementation + return(window(sampler, start = start, end = end, thin = thin)) + + } else if(coda == F){ + if(is.matrix(sampler[[1]])) { + return(getSample(combineChains(sampler), parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics = reportDiagnostics)) + } else { + return(as.vector(getSample(combineChains(sampler), parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics = reportDiagnostics))) + } + } +} + + +# getSample implementation for nimble objects of class MCMC + +#' @rdname getSample +#' @author Tankred Ott +#' @export +getSample.MCMC <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ + return(getSample(as.matrix(sampler$mvSamples), parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics = reportDiagnostics)) +} + +#' @rdname getSample +#' @author Tankred Ott +#' @export +getSample.MCMC_refClass <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = "auto", numSamples = NULL, whichParameters = NULL, reportDiagnostics = F, ...){ + return(getSample(as.matrix(sampler$mvSamples), parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics = reportDiagnostics)) +} + + +#' Merge Chains +#' +#' Merge a list of outputs from MCMC / SMC samplers +#' +#' The function merges a list of outputs from MCMC / SMC samplers into a single matrix. Requirement is that the list contains classes for which the \code{\link{getSample}} function works +#' +#' @param l a list with objects that can be accessed with \code{\link{getSample}} +#' @param ... arguments to be passed on to \code{\link{getSample}} +#' @return a matrix +#' @author Florian Hartig +#' @export +mergeChains <- function(l, ...){ + + x = getSample(l[[1]], ...) + + for(i in 2:length(l)){ + x = rbind(x, getSample(l[[i]], ...)) + } + return(x) +} diff --git a/BayesianTools/R/classLikelihood.R b/BayesianTools/R/classLikelihood.R index a85ebff..d07769b 100644 --- a/BayesianTools/R/classLikelihood.R +++ b/BayesianTools/R/classLikelihood.R @@ -1,166 +1,165 @@ -#' Creates a standardized likelihood class#' -#' @author Florian Hartig -#' @param likelihood log likelihood density -#' @param names parameter names (optional) -#' @param parallel parallelization , either i) no parallelization --> F, ii) native R parallelization --> T / "auto" will select n-1 of your available cores, or provide a number for how many cores to use, or iii) external parallelization --> "external". External means that the likelihood is already able to execute parallel runs in the form of a matrix. -#' @param catchDuplicates logical, determines whether unique parameter combinations should only be evaluated once. This is only applicable when the likelihood accepts a matrix with parameters as columns. -#' @param parallelOptions a list containing two lists. First, "packages" specifies the R packages necessary to run the likelihood function. Second, "objects" contains the objects in the global environment needed to run the likelihood function (for details see \code{\link{createBayesianSetup}}). -#' @param sampler sampler -#' @seealso \code{\link{likelihoodIidNormal}} \cr -#' \code{\link{likelihoodAR1}} \cr -#' @export -createLikelihood <- function(likelihood, names = NULL, parallel = F, catchDuplicates=T, - sampler = NULL, parallelOptions = NULL){ - - # check if point-wise likelihood available - pwLikelihood = if ("sum" %in% names(as.list(args(likelihood)))) TRUE else FALSE - - catchingLikelihood <- function(x, ...){ - out <- tryCatch( - { - y = likelihood(x, ...) - if (any(y == Inf | is.nan(y) | is.na(y) | !is.numeric(y))){ - message(paste("BayesianTools warning: positive Inf or NA / nan values, or non-numeric values occured in the likelihood. Setting likelihood to -Inf.\n Original value was", y, "for parameters", x, "\n\n ")) - y[is.infinite(y) | is.nan(y) | is.na(y) | !is.numeric(y)] = -Inf - } - y - }, - error=function(cond){ - cat(c("Parameter values ", x, "\n")) - message("Problem encountered in the calculation of the likelihood with parameter ", x, "\n Error message was", cond, "\n set result of the parameter evaluation to -Inf ", "ParameterValues ") - return(-Inf) - } - ) - return(out) - } - - # initalize cl - cl <- NULL - - if (parallel == T | parallel == "auto" | is.numeric(parallel)) { - tmp <- generateParallelExecuter(likelihood, parallel, parallelOptions) - parallelLikelihood <- tmp$parallelFun - cl <- tmp$cl - parallel = T - } - - - parallelDensity<- function(x, ...){ - if (is.vector(x)) return(catchingLikelihood(x, ...)) - else if(is.matrix(x)){ - if(catchDuplicates == TRUE){ - # Check for the rows that are not duplicated - wn <- which(!duplicated(x)) - if(length(wn) <2) { - return(parallelLikelihood(x, ...)) } - else { - # Define a output vector - out1 <- rep(0,length=nrow(x)) - - # Run the likelihood function for unique values - if (parallel == "external"){ - out1[wn]<-likelihood(x[wn,], ...) - } - else{ - if (parallel == T){ - out1[wn]<-parallelLikelihood(x[wn,], ...) - } - else{ - out1[wn]<-apply(x[wn,], 1, likelihood, ...) - } - } - # Copy the values for the duplicates - for(i in 1:length(out1)){ - if(out1[i] != 0) next - else{ - same <- numeric() - for(k in 1:length(out1)){ - if(all(x[k,]== x[i,])){ - same <- c(same,k) - } - } - out1[same[-1]] <- out1[same[1]] - } - } - - return(out1) - }} - - else{ - if (parallel == "external") return(likelihood(x, ...)) - else if (parallel == T){ - return(parallelLikelihood(x, ...))} - else return(apply(x, 1, likelihood, ...)) - - } - } - else stop("parameter must be vector or matrix") - } - out<- list(density = parallelDensity, sampler = sampler, cl = cl, pwLikelihood = pwLikelihood, parNames = names) - class(out) <- "likelihood" - return(out) -} - - - -#library(mvtnorm) -#library(sparseMVN) - -#' Normal / Gaussian Likelihood function -#' @author Florian Hartig -#' @param predicted vector of predicted values -#' @param observed vector of observed values -#' @param sd standard deviation of the i.i.d. normal likelihood -#' @export -likelihoodIidNormal <- function(predicted, observed, sd){ - notNAvalues = !is.na(observed) - if (sd <= 0) return (-Inf) - else return(sum(dnorm(predicted[notNAvalues], mean = observed[notNAvalues], sd = sd, log = T))) -} - -# TODO - gibbs sample out the error terms - -#' AR1 type likelihood function -#' @author Florian Hartig -#' @param predicted vector of predicted values -#' @param observed vector of observed values -#' @param sd standard deviation of the iid normal likelihood -#' @param a temporal correlation in the AR1 model -#' @note The AR1 model considers the process: \cr y(t) = a y(t-1) + E \cr e = i.i.d. N(0,sd) \cr |a| < 1 \cr At the moment, no NAs are allowed in the time series. -#' @export -likelihoodAR1 <- function(predicted, observed, sd, a){ - if (any(is.na(observed))) stop("AR1 likelihood cannot work with NAs included, split up the likelihood") - if (sd <= 0) return (-Inf) - if (abs(a) >= 1) return (-Inf) - - n = length(observed) - - res = predicted - observed - - # this calculates the unconditiona LL for this data, see e.g. http://stat.unicas.it/downloadStatUnicas/seminari/2008/Julliard0708_1.pdf - - ll = 0.5 * ( - n * log(2*pi) - - n * log(sd^2) - + log( 1- a^2 ) - - (1- a^2) / sd^2 * res[1]^2 - - 1 / sd^2 * sum( (res[2:n] - a * res[1:(n-1)])^2) - ) - return(ll) -} -# Tests -# library(stats) -# data<-arima.sim(n=1000,model = list(ar=0.9)) -# x <- ar(data, aic = F, order.max = 1) -# opt <- function(par){ -# -likelihoodAR1(data, rep(0,1000), sd = par[1], a = par[2] ) -# } -# optim(c(1.1,0.7), opt ) - - - - - - - - - +#' Creates a standardized likelihood class#' +#' @author Florian Hartig +#' @param likelihood log likelihood density +#' @param names parameter names (optional) +#' @param parallel parallelization , either i) no parallelization --> F, ii) native R parallelization --> T / "auto" will select n-1 of your available cores, or provide a number for how many cores to use, or iii) external parallelization --> "external". External means that the likelihood is already able to execute parallel runs in the form of a matrix. +#' @param catchDuplicates logical, determines whether unique parameter combinations should only be evaluated once. This is only applicable when the likelihood accepts a matrix with parameters as columns. +#' @param parallelOptions a list containing two lists. First, "packages" specifies the R packages necessary to run the likelihood function. Second, "objects" contains the objects in the global environment needed to run the likelihood function (for details see \code{\link{createBayesianSetup}}). +#' @param sampler sampler +#' @seealso \code{\link{likelihoodIidNormal}} \cr +#' \code{\link{likelihoodAR1}} \cr +#' @export +createLikelihood <- function(likelihood, names = NULL, parallel = F, catchDuplicates=T, + sampler = NULL, parallelOptions = NULL){ + + # check if point-wise likelihood available + pwLikelihood = if ("sum" %in% names(as.list(args(likelihood)))) TRUE else FALSE + + catchingLikelihood <- function(x, ...){ + out <- tryCatch( + { + y = likelihood(x, ...) + if (any(y == Inf | is.nan(y) | is.na(y) | !is.numeric(y))){ + message(paste("BayesianTools warning: positive Inf or NA / nan values, or non-numeric values occured in the likelihood. Setting likelihood to -Inf.\n Original value was", y, "for parameters", x, "\n\n ")) + y[is.infinite(y) | is.nan(y) | is.na(y) | !is.numeric(y)] = -Inf + } + y + }, + error=function(cond){ + cat(c("Parameter values ", x, "\n")) + message("Problem encountered in the calculation of the likelihood with parameter ", x, "\n Error message was", cond, "\n set result of the parameter evaluation to -Inf ", "ParameterValues ") + return(-Inf) + } + ) + return(out) + } + + # initalize cl + cl <- NULL + + if (parallel == T | parallel == "auto" | is.numeric(parallel)) { + tmp <- generateParallelExecuter(likelihood, parallel, parallelOptions) + parallelLikelihood <- tmp$parallelFun + cl <- tmp$cl + parallel = T + } + + + parallelDensity<- function(x, ...){ + if (is.vector(x)) return(catchingLikelihood(x, ...)) + else if(is.matrix(x)){ + if(catchDuplicates == TRUE){ + # Check for the rows that are not duplicated + wn <- which(!duplicated(x)) + if(length(wn) <2) { + return(parallelLikelihood(x, ...)) } + else { + # Define a output vector + out1 <- rep(0,length=nrow(x)) + + # Run the likelihood function for unique values + if (parallel == "external"){ + out1[wn]<-likelihood(x[wn,], ...) + } + else{ + if (parallel == T){ + out1[wn]<-parallelLikelihood(x[wn,], ...) + } + else{ + out1[wn]<-apply(x[wn,], 1, likelihood, ...) + } + } + # Copy the values for the duplicates + for(i in 1:length(out1)){ + if(out1[i] != 0) next + else{ + same <- numeric() + for(k in 1:length(out1)){ + if(all(x[k,]== x[i,])){ + same <- c(same,k) + } + } + out1[same[-1]] <- out1[same[1]] + } + } + + return(out1) + }} + + else{ + if (parallel == "external") return(likelihood(x, ...)) + else if (parallel == T){ + return(parallelLikelihood(x, ...))} + else return(apply(x, 1, likelihood, ...)) + + } + } + else stop("parameter must be vector or matrix") + } + out<- list(density = parallelDensity, sampler = sampler, cl = cl, pwLikelihood = pwLikelihood, parNames = names) + class(out) <- "likelihood" + return(out) +} + + + +#library(mvtnorm) +#library(sparseMVN) +#' Normal / Gaussian Likelihood function +#' @author Florian Hartig +#' @param predicted vector of predicted values +#' @param observed vector of observed values +#' @param sd standard deviation of the i.i.d. normal likelihood +#' @export +likelihoodIidNormal <- function(predicted, observed, sd){ + notNAvalues = !is.na(observed) + if (sd <= 0) return (-Inf) + else return(sum(dnorm(predicted[notNAvalues], mean = observed[notNAvalues], sd = sd, log = T))) +} + +# TODO - gibbs sample out the error terms + +#' AR1 type likelihood function +#' @author Florian Hartig +#' @param predicted vector of predicted values +#' @param observed vector of observed values +#' @param sd standard deviation of the iid normal likelihood +#' @param a temporal correlation in the AR1 model +#' @note The AR1 model considers the process: \cr y(t) = a y(t-1) + E \cr e = i.i.d. N(0,sd) \cr |a| < 1 \cr At the moment, no NAs are allowed in the time series. +#' @export +likelihoodAR1 <- function(predicted, observed, sd, a){ + if (any(is.na(observed))) stop("AR1 likelihood cannot work with NAs included, split up the likelihood") + if (sd <= 0) return (-Inf) + if (abs(a) >= 1) return (-Inf) + + n = length(observed) + + res = predicted - observed + + # this calculates the unconditiona LL for this data, see e.g. http://stat.unicas.it/downloadStatUnicas/seminari/2008/Julliard0708_1.pdf + + ll = 0.5 * ( - n * log(2*pi) + - n * log(sd^2) + + log( 1- a^2 ) + - (1- a^2) / sd^2 * res[1]^2 + - 1 / sd^2 * sum( (res[2:n] - a * res[1:(n-1)])^2) + ) + return(ll) +} +# Tests +# library(stats) +# data<-arima.sim(n=1000,model = list(ar=0.9)) +# x <- ar(data, aic = F, order.max = 1) +# opt <- function(par){ +# -likelihoodAR1(data, rep(0,1000), sd = par[1], a = par[2] ) +# } +# optim(c(1.1,0.7), opt ) + + + + + + + + + diff --git a/BayesianTools/R/classMcmcSampler.R b/BayesianTools/R/classMcmcSampler.R index 1f34d7e..ee827d7 100644 --- a/BayesianTools/R/classMcmcSampler.R +++ b/BayesianTools/R/classMcmcSampler.R @@ -1,5 +1,4 @@ # Functions for class mcmcSamper - #' @author Florian Hartig #' @export getSample.mcmcSampler <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = 1, numSamples = NULL, whichParameters = NULL, reportDiagnostics= F, ...){ diff --git a/BayesianTools/R/classPosterior.R b/BayesianTools/R/classPosterior.R index 591b112..e083b3c 100644 --- a/BayesianTools/R/classPosterior.R +++ b/BayesianTools/R/classPosterior.R @@ -1,57 +1,56 @@ -#' Creates a standardized posterior class -#' @author Florian Hartig -#' @param prior prior class -#' @param likelihood log likelihood density -#' @details Function is internally used in \code{\link{createBayesianSetup}} to create a standardized posterior class. -#' @export -createPosterior <- function(prior, likelihood){ - - posterior <- function(x, returnAll = F){ - - if (is.vector(x)){ - priorResult = prior$density(x) # Checking if outside prior to save calculation time - if (! (priorResult == -Inf)) ll = likelihood$density(x) - else ll = -Inf - if (returnAll == F) return(ll + priorResult) - else return(c(ll + priorResult, ll, priorResult)) - - } else if(is.matrix(x)){ - - priorResult = prior$density(x) # Checking first if outside the prior to save calculation time - feasible <- (! priorResult == -Inf) - if (dim(x)[2] == 1) llResult <- likelihood$density(matrix(x[feasible, ], ncol = 1)) - else{ - if(TRUE %in% feasible) llResult <- likelihood$density(x[feasible, ]) - else llResult <- -Inf - } - post = priorResult - ll = priorResult - ll[!feasible] = NA - ll[feasible] = llResult - post[feasible] = post[feasible] + llResult - post[!feasible] = -Inf - if (returnAll == F) return(post) - else{ - out <- cbind(post, ll, priorResult) - colnames(out) = c("posterior", "likelihood", "prior") - return(out) - } - } - else stop("parameter must be vector or matrix") - } - - out<- list(density = posterior) - class(out) <- "posterior" - return(out) -} - -# likelihood <- function(x)stop("a") -# prior <- createPrior(function(x) sum(dunif(x, log = T))) -# -# x = createPosterior(prior, likelihood) -# -# x$density(c(0.2,0.2)) -# prior$density(c(2,2)) -# -# -# x = c(0.2,0.2) +#' Creates a standardized posterior class +#' @author Florian Hartig +#' @param prior prior class +#' @param likelihood log likelihood density +#' @details Function is internally used in \code{\link{createBayesianSetup}} to create a standardized posterior class. +#' @export +createPosterior <- function(prior, likelihood){ + + posterior <- function(x, returnAll = F){ + + if (is.vector(x)){ + priorResult = prior$density(x) # Checking if outside prior to save calculation time + if (! (priorResult == -Inf)) ll = likelihood$density(x) + else ll = -Inf + if (returnAll == F) return(ll + priorResult) + else return(c(ll + priorResult, ll, priorResult)) + + } else if(is.matrix(x)){ + + priorResult = prior$density(x) # Checking first if outside the prior to save calculation time + feasible <- (! priorResult == -Inf) + if (dim(x)[2] == 1) llResult <- likelihood$density(matrix(x[feasible, ], ncol = 1)) + else{ + if(TRUE %in% feasible) llResult <- likelihood$density(x[feasible, ]) + else llResult <- -Inf + } + post = priorResult + ll = priorResult + ll[!feasible] = NA + ll[feasible] = llResult + post[feasible] = post[feasible] + llResult + post[!feasible] = -Inf + if (returnAll == F) return(post) + else{ + out <- cbind(post, ll, priorResult) + colnames(out) = c("posterior", "likelihood", "prior") + return(out) + } + } + else stop("parameter must be vector or matrix") + } + + out<- list(density = posterior) + class(out) <- "posterior" + return(out) +} + +# likelihood <- function(x)stop("a") +# prior <- createPrior(function(x) sum(dunif(x, log = T))) +# +# x = createPosterior(prior, likelihood) +# +# x$density(c(0.2,0.2)) +# prior$density(c(2,2)) +# +# x = c(0.2,0.2) From 21e122d26465287843f43506d1752bc2c8b73458 Mon Sep 17 00:00:00 2001 From: TahminaMojumder Date: Fri, 27 Oct 2023 12:33:36 +0200 Subject: [PATCH 10/13] Removed white space --- BayesianTools/R/classMcmcSampler.R | 1 - BayesianTools/R/classPrior.R | 529 +++++----- BayesianTools/R/codaFunctions.R | 117 +-- BayesianTools/R/convertCoda.R | 101 +- BayesianTools/R/getVolume.R | 71 +- BayesianTools/R/marginalLikelihood.R | 377 ++++--- BayesianTools/R/mcmcDE.R | 469 +++++---- BayesianTools/R/mcmcDEzs.R | 795 +++++++------- BayesianTools/R/mcmcDREAM.R | 705 +++++++------ BayesianTools/R/mcmcDREAM_helperFunctions.R | 145 ++- BayesianTools/R/mcmcDREAMzs.R | 977 ++++++++--------- BayesianTools/R/mcmcFrancesco.R | 699 ++++++------- BayesianTools/R/mcmcMetropolis.R | 391 +++---- BayesianTools/R/mcmcMultipleChains.R | 79 +- BayesianTools/R/mcmcRun.R | 1045 ++++++++++--------- BayesianTools/R/mcmcTwalk.R | 309 +++--- BayesianTools/R/mcmcTwalk_helperFunctions.R | 599 +++++------ BayesianTools/R/plotCorrelationDensity.r | 179 ++-- BayesianTools/R/plotDiagnostic.R | 499 +++++---- BayesianTools/R/plotMarginals.R | 649 ++++++------ BayesianTools/R/plotSensitivityOAT.R | 115 +- BayesianTools/R/plotTrace.R | 27 +- BayesianTools/man/updateGroups.Rd | 2 +- 23 files changed, 4439 insertions(+), 4441 deletions(-) diff --git a/BayesianTools/R/classMcmcSampler.R b/BayesianTools/R/classMcmcSampler.R index ee827d7..84df749 100644 --- a/BayesianTools/R/classMcmcSampler.R +++ b/BayesianTools/R/classMcmcSampler.R @@ -111,7 +111,6 @@ getSample.mcmcSampler <- function(sampler, parametersOnly = T, coda = F, start = } - #' @method summary mcmcSampler #' @author Stefan Paul #' @export diff --git a/BayesianTools/R/classPrior.R b/BayesianTools/R/classPrior.R index 3e47a5a..786f110 100644 --- a/BayesianTools/R/classPrior.R +++ b/BayesianTools/R/classPrior.R @@ -1,266 +1,263 @@ -#' Creates a standardized prior class -#' @author Florian Hartig -#' @param density prior density -#' @param sampler Sampling function for density (optional) -#' @param lower vector with lower bounds of parameters -#' @param upper vector with upper bounds of parameter -#' @param best vector with "best" parameter values -#' @details This is the general prior generator. It is highly recommended to implement both the density and sampler function. If not, the user will have to provide explicit starting values for many of the MCMC samplers. Note the existing, more specialized prior functions. It is recommended to use those specialized prior functions, if possible. Also note that priors can be created from an existing MCMC output from BT, or another MCMC sample, via \code{\link{createPriorDensity}}. -#' @note min and max truncate, but not re-normalize the prior density (so, if a pdf that integrated to one is truncated, the integral will in general be smaller than one). For MCMC sampling, this doesn't make a difference, but if absolute values of the prior density are a concern, one should provide a truncated density function for the prior. -#' @export -#' @seealso \code{\link{createPriorDensity}} \cr -#' \code{\link{createBetaPrior}} \cr -#' \code{\link{createUniformPrior}} \cr -#' \code{\link{createTruncatedNormalPrior}}\cr -#' \code{\link{createBayesianSetup}}\cr -#' @example /inst/examples/createPrior.R -createPrior <- function(density = NULL, sampler = NULL, lower = NULL, upper = NULL, best = NULL){ - - # case density is a Bayesian Posterior - if(inherits(density,"bayesianOutput")) return(createPriorDensity(density, lower = lower, upper = upper, best = best)) - - if(! is.null(lower) & ! is.null(upper)) if(any(lower > upper)) stop("prior with lower values > upper") - - if(is.null(best) & ! is.null(lower) & ! is.null(upper)) best = (upper + lower) / 2 - - # if no density is provided - if (is.null(density)){ - density <- function(x){ - return(0) - } - } - - catchingPrior <- function(x){ - - # check if bounds are respected - if(!is.null(lower)){ - if (any(x < lower)) return(-Inf) - } - if(!is.null(upper)){ - if (any(x > upper)) return(-Inf) - } - - # calculate prior density within try-catch statement - out <- tryCatch( - { - density(x) - }, - error=function(cond) { - warning("Problem in the prior", cond) - return(-Inf) - } - ) - # extra check - if (out == Inf) stop("Inf encountered in prior") - - return(out) - } - - parallelDensity<- function(x){ - if (is.vector(x)) return(catchingPrior(x)) - else if(is.matrix(x)) return(apply(x, 1, catchingPrior)) - else stop("parameter must be vector or matrix") - } - - # Check and parallelize the sampler - # if no sampler is passed, but lower and upper, generate uniform sampler - if (is.null(sampler) && !is.null(lower) && !is.null(upper)) { - sampler <- function(n = 1) { - runif(n, lower, upper) - } - } - - if(!is.null(sampler)){ - npar <- length(sampler()) - parallelSampler <- function(n=NULL){ - if(is.null(n)) out = sampler() - else{ - if (npar == 1) out = matrix(replicate(n, sampler())) - else if (npar >1) out = t(replicate(n, sampler(), simplify = T)) - else stop("sampler provided doesn't work") - } - return(out) - } - } else parallelSampler = function(n = NULL){ - stop("Attept to call the sampling function of the prior, although this function has not been provided in the Bayesian setup. A likely cause of this error is that you use a function or sampling algorithm that tries to sample from the prior. Either change the settings of your function, or provide a sampling function in your BayesianSetup (see ?createBayesianSetup, and ?createPrior)") - } - - checkPrior <- function(x = NULL, z = FALSE){ - if(is.null(x)) x <- parallelSampler(1000) - if(is.function(x)) x <- x() - if(!is.matrix(x)) x <- parallelSampler(1000) - check <- parallelDensity(x) - if(any(is.infinite(check))) { - if(z) warning("Z matrix values outside prior range", call. = FALSE) - else warning("Start values outside prior range", call. = FALSE) - } - } - - - - out<- list(density = parallelDensity, sampler = parallelSampler, lower = lower, upper = upper, best = best, originalDensity = density, checkStart = checkPrior) - class(out) <- "prior" - return(out) -} - - -#' Convenience function to create a simple uniform prior distribution -#' @author Florian Hartig -#' @param lower vector of lower prior range for all parameters -#' @param upper vector of upper prior range for all parameters -#' @param best vector with "best" values for all parameters -#' @note for details see \code{\link{createPrior}} -#' @seealso \code{\link{createPriorDensity}}, \code{\link{createPrior}}, \code{\link{createBetaPrior}}, \code{\link{createTruncatedNormalPrior}}, \code{\link{createBayesianSetup}} -#' @example /inst/examples/createPrior.R -#' @export -createUniformPrior<- function(lower, upper, best = NULL){ - len = length(lower) - density <- function(x){ - if (length(x) != len) stop("parameter vector does not match prior") - else return(sum(dunif(x, min = lower, max = upper, log = T))) - } - sampler <- function() runif(len, lower, upper) - - out <- createPrior(density = density, sampler = sampler, lower = lower, upper = upper, best = best) - return(out) -} - - -#' Convenience function to create a truncated normal prior -#' @author Florian Hartig -#' @param mean best estimate for each parameter -#' @param sd sdandard deviation -#' @param lower vector of lower prior range for all parameters -#' @param upper vector of upper prior range for all parameters -#' @note for details see \code{\link{createPrior}} -#' @seealso \code{\link{createPriorDensity}} \cr -#' \code{\link{createPrior}} \cr -#' \code{\link{createBetaPrior}} \cr -#' \code{\link{createUniformPrior}} \cr -#' \code{\link{createBayesianSetup}} \cr -#' @export -#' @example /inst/examples/createPrior.R -createTruncatedNormalPrior<- function(mean, sd, lower, upper){ - len = length(mean) - density <- function(x){ - if (length(x) != len) stop("parameter vector does not match prior") - else return(sum(msm::dtnorm(x, mean = mean, sd = sd, lower = lower, upper = upper, log = T))) - } - sampler <- function(){ - msm::rtnorm(n = length(mean), mean = mean, sd = sd, lower = lower, upper = upper) - } - out <- createPrior(density = density, sampler = sampler, lower = lower, upper = upper) - return(out) -} - - -#' Convenience function to create a beta prior -#' @author Florian Hartig -#' @param a shape1 of the beta distribution -#' @param b shape2 of the beta distribution -#' @param upper upper values for the parameters -#' @param lower lower values for the parameters -#' @note for details see \code{\link{createPrior}} -#' @details This creates a beta prior, assuming that lower / upper values for parameters are are fixed. The beta is the calculated relative to this lower / upper space. -#' @seealso \code{\link{createPriorDensity}} \cr -#' \code{\link{createPrior}} \cr -#' \code{\link{createTruncatedNormalPrior}} \cr -#' \code{\link{createUniformPrior}} \cr -#' \code{\link{createBayesianSetup}} \cr -#' @example /inst/examples/createPrior.R -#' @export -createBetaPrior<- function(a, b, lower=0, upper=1){ - len = length(lower) - if (! any(upper > lower)) stop("wrong values in beta prior") - range = upper - lower - density <- function(x){ - x = (x - lower) / range - if (length(x) != len) stop("parameter vector does not match prior") - else return(sum( dbeta(x, shape1 = a, shape2 = b, log=T) )) - } - sampler <- function(){ - out = rbeta(n = len, shape1 = a, shape2 = b) - out = (out * range) + lower - return(out) - } - out <- createPrior(density = density, sampler = sampler, lower = lower, upper = upper) - return(out) -} - - -#' Fits a density function to a multivariate sample -#' -#' @author Florian Hartig -#' @export -#' @param sampler an object of class BayesianOutput or a matrix -#' @param method method to generate prior - default and currently only option is multivariate -#' @param eps numerical precision to avoid singularity -#' @param lower vector with lower bounds of parameter for the new prior, independent of the input sample -#' @param upper vector with upper bounds of parameter for the new prior, independent of the input sample -#' @param best vector with "best" values of parameter for the new prior, independent of the input sample -#' @param scaling optional scaling factor for the covariance. If scaling > 1 will create a prior wider than the posterior, < 1 a prior more narrow than the posterior. Scaling is linear to the posterior width, i.e. scaling = 2 will create a prior that with 2x the sd of the original posterior. -#' @param ... parameters to pass on to the getSample function -#' -#' @details This function fits a density estimator to a multivariate (typically a posterior) sample. The main purpose is to summarize a posterior sample as a pdf, in order to include it as a prior in a new analysis, for example when new data becomes available, or to calculate a fractional Bayes factor (see \code{\link{marginalLikelihood}}). -#' -#' The limitation of this function is that we currently only implement a multivariate normal density estimator, so you will have a loss of information if your posterior is not approximately multivariate normal, which is likely the case if you have weak data. Extending the function to include more flexible density estimators (e.g. gaussian processes) is on our todo list, but it's quite tricky to get this stable, so I'm not sure when we will have this working. In general, creating reliable empirical density estimates in high-dimensional parameter spaces is extremely tricky, regardless of the software you are using. -#' -#' For that reason, it is usually recommended to not update the posterior with this option, but rather: -#' -#' 1. If the full dataset is available, to make a single, or infrequent updates, recompute the entire model with the full / updated data -#' -#' 2. For frequent updates, consider using SMC instead of MCMC sampling. SMC sampling doesn't require an analytical summary of the posterior. -#' -#' @seealso \code{\link{createPrior}} \cr -#' \code{\link{createBetaPrior}} \cr -#' \code{\link{createTruncatedNormalPrior}} \cr -#' \code{\link{createUniformPrior}} \cr -#' \code{\link{createBayesianSetup}} \cr -#' @example /inst/examples/createPrior.R -createPriorDensity <- function(sampler, method = "multivariate", eps = 1e-10, lower = NULL, upper = NULL, best = NULL, scaling = 1, ...){ - - x = getSample(sampler, ...) - - if(method == "multivariate"){ - nPars = ncol(x) - covar = cov(x) * scaling^2 - mean = apply(x, 2, mean) - if(is.null(lower)) lower = rep(-Inf, length = length(mean)) - if(is.null(upper)) upper = rep(Inf, length = length(mean)) - - density = function(par){ - dens = tmvtnorm::dtmvnorm(x = par, mean = mean, sigma = covar + eps, log = T, lower = lower, upper = upper) - return(dens) - } - - sampler = function(n=1){ - par <- tmvtnorm::rtmvnorm(n = n, mean = mean, sigma = covar + eps, lower = lower, upper = upper, algorithm = "rejection") - if (n == 1) par = as.vector(par) - return(par) - } - - out <- createPrior(density = density, sampler = sampler, lower = lower, upper = upper, best = best) - return(out) - } -} - - - -#' @author Maximilian Pichler - -#' @export - -print.prior <- function(x, ...){ - cat('Prior: \n\n') - - prior = x - info = c( "lower", "upper","best") - maxPar = max(length(prior$lower),length(prior$lupper)) - if(maxPar == 0) maxPar = ncol(prior$sampler()) - priorInfo = data.frame(matrix(NA, ncol = 3, nrow = maxPar)) - colnames(priorInfo) = info - for(i in 1:3) if(!is.null(prior[[info[i]]])) priorInfo[,i] <- prior[[info[i]]] - rownames(priorInfo) <- sapply(1:maxPar, FUN = function(x) return(paste("par",x))) - print(priorInfo) - -} +#' Creates a standardized prior class +#' @author Florian Hartig +#' @param density prior density +#' @param sampler Sampling function for density (optional) +#' @param lower vector with lower bounds of parameters +#' @param upper vector with upper bounds of parameter +#' @param best vector with "best" parameter values +#' @details This is the general prior generator. It is highly recommended to implement both the density and sampler function. If not, the user will have to provide explicit starting values for many of the MCMC samplers. Note the existing, more specialized prior functions. It is recommended to use those specialized prior functions, if possible. Also note that priors can be created from an existing MCMC output from BT, or another MCMC sample, via \code{\link{createPriorDensity}}. +#' @note min and max truncate, but not re-normalize the prior density (so, if a pdf that integrated to one is truncated, the integral will in general be smaller than one). For MCMC sampling, this doesn't make a difference, but if absolute values of the prior density are a concern, one should provide a truncated density function for the prior. +#' @export +#' @seealso \code{\link{createPriorDensity}} \cr +#' \code{\link{createBetaPrior}} \cr +#' \code{\link{createUniformPrior}} \cr +#' \code{\link{createTruncatedNormalPrior}}\cr +#' \code{\link{createBayesianSetup}}\cr +#' @example /inst/examples/createPrior.R +createPrior <- function(density = NULL, sampler = NULL, lower = NULL, upper = NULL, best = NULL){ + + # case density is a Bayesian Posterior + if(inherits(density,"bayesianOutput")) return(createPriorDensity(density, lower = lower, upper = upper, best = best)) + + if(! is.null(lower) & ! is.null(upper)) if(any(lower > upper)) stop("prior with lower values > upper") + + if(is.null(best) & ! is.null(lower) & ! is.null(upper)) best = (upper + lower) / 2 + + # if no density is provided + if (is.null(density)){ + density <- function(x){ + return(0) + } + } + + catchingPrior <- function(x){ + + # check if bounds are respected + if(!is.null(lower)){ + if (any(x < lower)) return(-Inf) + } + if(!is.null(upper)){ + if (any(x > upper)) return(-Inf) + } + + # calculate prior density within try-catch statement + out <- tryCatch( + { + density(x) + }, + error=function(cond) { + warning("Problem in the prior", cond) + return(-Inf) + } + ) + # extra check + if (out == Inf) stop("Inf encountered in prior") + + return(out) + } + + parallelDensity<- function(x){ + if (is.vector(x)) return(catchingPrior(x)) + else if(is.matrix(x)) return(apply(x, 1, catchingPrior)) + else stop("parameter must be vector or matrix") + } + + # Check and parallelize the sampler + # if no sampler is passed, but lower and upper, generate uniform sampler + if (is.null(sampler) && !is.null(lower) && !is.null(upper)) { + sampler <- function(n = 1) { + runif(n, lower, upper) + } + } + + if(!is.null(sampler)){ + npar <- length(sampler()) + parallelSampler <- function(n=NULL){ + if(is.null(n)) out = sampler() + else{ + if (npar == 1) out = matrix(replicate(n, sampler())) + else if (npar >1) out = t(replicate(n, sampler(), simplify = T)) + else stop("sampler provided doesn't work") + } + return(out) + } + } else parallelSampler = function(n = NULL){ + stop("Attept to call the sampling function of the prior, although this function has not been provided in the Bayesian setup. A likely cause of this error is that you use a function or sampling algorithm that tries to sample from the prior. Either change the settings of your function, or provide a sampling function in your BayesianSetup (see ?createBayesianSetup, and ?createPrior)") + } + + checkPrior <- function(x = NULL, z = FALSE){ + if(is.null(x)) x <- parallelSampler(1000) + if(is.function(x)) x <- x() + if(!is.matrix(x)) x <- parallelSampler(1000) + check <- parallelDensity(x) + if(any(is.infinite(check))) { + if(z) warning("Z matrix values outside prior range", call. = FALSE) + else warning("Start values outside prior range", call. = FALSE) + } + } + + + + out<- list(density = parallelDensity, sampler = parallelSampler, lower = lower, upper = upper, best = best, originalDensity = density, checkStart = checkPrior) + class(out) <- "prior" + return(out) +} + + +#' Convenience function to create a simple uniform prior distribution +#' @author Florian Hartig +#' @param lower vector of lower prior range for all parameters +#' @param upper vector of upper prior range for all parameters +#' @param best vector with "best" values for all parameters +#' @note for details see \code{\link{createPrior}} +#' @seealso \code{\link{createPriorDensity}}, \code{\link{createPrior}}, \code{\link{createBetaPrior}}, \code{\link{createTruncatedNormalPrior}}, \code{\link{createBayesianSetup}} +#' @example /inst/examples/createPrior.R +#' @export +createUniformPrior<- function(lower, upper, best = NULL){ + len = length(lower) + density <- function(x){ + if (length(x) != len) stop("parameter vector does not match prior") + else return(sum(dunif(x, min = lower, max = upper, log = T))) + } + sampler <- function() runif(len, lower, upper) + + out <- createPrior(density = density, sampler = sampler, lower = lower, upper = upper, best = best) + return(out) +} + + +#' Convenience function to create a truncated normal prior +#' @author Florian Hartig +#' @param mean best estimate for each parameter +#' @param sd sdandard deviation +#' @param lower vector of lower prior range for all parameters +#' @param upper vector of upper prior range for all parameters +#' @note for details see \code{\link{createPrior}} +#' @seealso \code{\link{createPriorDensity}} \cr +#' \code{\link{createPrior}} \cr +#' \code{\link{createBetaPrior}} \cr +#' \code{\link{createUniformPrior}} \cr +#' \code{\link{createBayesianSetup}} \cr +#' @export +#' @example /inst/examples/createPrior.R +createTruncatedNormalPrior<- function(mean, sd, lower, upper){ + len = length(mean) + density <- function(x){ + if (length(x) != len) stop("parameter vector does not match prior") + else return(sum(msm::dtnorm(x, mean = mean, sd = sd, lower = lower, upper = upper, log = T))) + } + sampler <- function(){ + msm::rtnorm(n = length(mean), mean = mean, sd = sd, lower = lower, upper = upper) + } + out <- createPrior(density = density, sampler = sampler, lower = lower, upper = upper) + return(out) +} + + +#' Convenience function to create a beta prior +#' @author Florian Hartig +#' @param a shape1 of the beta distribution +#' @param b shape2 of the beta distribution +#' @param upper upper values for the parameters +#' @param lower lower values for the parameters +#' @note for details see \code{\link{createPrior}} +#' @details This creates a beta prior, assuming that lower / upper values for parameters are are fixed. The beta is the calculated relative to this lower / upper space. +#' @seealso \code{\link{createPriorDensity}} \cr +#' \code{\link{createPrior}} \cr +#' \code{\link{createTruncatedNormalPrior}} \cr +#' \code{\link{createUniformPrior}} \cr +#' \code{\link{createBayesianSetup}} \cr +#' @example /inst/examples/createPrior.R +#' @export +createBetaPrior<- function(a, b, lower=0, upper=1){ + len = length(lower) + if (! any(upper > lower)) stop("wrong values in beta prior") + range = upper - lower + density <- function(x){ + x = (x - lower) / range + if (length(x) != len) stop("parameter vector does not match prior") + else return(sum( dbeta(x, shape1 = a, shape2 = b, log=T) )) + } + sampler <- function(){ + out = rbeta(n = len, shape1 = a, shape2 = b) + out = (out * range) + lower + return(out) + } + out <- createPrior(density = density, sampler = sampler, lower = lower, upper = upper) + return(out) +} + + +#' Fits a density function to a multivariate sample +#' +#' @author Florian Hartig +#' @export +#' @param sampler an object of class BayesianOutput or a matrix +#' @param method method to generate prior - default and currently only option is multivariate +#' @param eps numerical precision to avoid singularity +#' @param lower vector with lower bounds of parameter for the new prior, independent of the input sample +#' @param upper vector with upper bounds of parameter for the new prior, independent of the input sample +#' @param best vector with "best" values of parameter for the new prior, independent of the input sample +#' @param scaling optional scaling factor for the covariance. If scaling > 1 will create a prior wider than the posterior, < 1 a prior more narrow than the posterior. Scaling is linear to the posterior width, i.e. scaling = 2 will create a prior that with 2x the sd of the original posterior. +#' @param ... parameters to pass on to the getSample function +#' +#' @details This function fits a density estimator to a multivariate (typically a posterior) sample. The main purpose is to summarize a posterior sample as a pdf, in order to include it as a prior in a new analysis, for example when new data becomes available, or to calculate a fractional Bayes factor (see \code{\link{marginalLikelihood}}). +#' +#' The limitation of this function is that we currently only implement a multivariate normal density estimator, so you will have a loss of information if your posterior is not approximately multivariate normal, which is likely the case if you have weak data. Extending the function to include more flexible density estimators (e.g. gaussian processes) is on our todo list, but it's quite tricky to get this stable, so I'm not sure when we will have this working. In general, creating reliable empirical density estimates in high-dimensional parameter spaces is extremely tricky, regardless of the software you are using. +#' +#' For that reason, it is usually recommended to not update the posterior with this option, but rather: +#' +#' 1. If the full dataset is available, to make a single, or infrequent updates, recompute the entire model with the full / updated data +#' +#' 2. For frequent updates, consider using SMC instead of MCMC sampling. SMC sampling doesn't require an analytical summary of the posterior. +#' +#' @seealso \code{\link{createPrior}} \cr +#' \code{\link{createBetaPrior}} \cr +#' \code{\link{createTruncatedNormalPrior}} \cr +#' \code{\link{createUniformPrior}} \cr +#' \code{\link{createBayesianSetup}} \cr +#' @example /inst/examples/createPrior.R +createPriorDensity <- function(sampler, method = "multivariate", eps = 1e-10, lower = NULL, upper = NULL, best = NULL, scaling = 1, ...){ + + x = getSample(sampler, ...) + + if(method == "multivariate"){ + nPars = ncol(x) + covar = cov(x) * scaling^2 + mean = apply(x, 2, mean) + if(is.null(lower)) lower = rep(-Inf, length = length(mean)) + if(is.null(upper)) upper = rep(Inf, length = length(mean)) + + density = function(par){ + dens = tmvtnorm::dtmvnorm(x = par, mean = mean, sigma = covar + eps, log = T, lower = lower, upper = upper) + return(dens) + } + + sampler = function(n=1){ + par <- tmvtnorm::rtmvnorm(n = n, mean = mean, sigma = covar + eps, lower = lower, upper = upper, algorithm = "rejection") + if (n == 1) par = as.vector(par) + return(par) + } + + out <- createPrior(density = density, sampler = sampler, lower = lower, upper = upper, best = best) + return(out) + } +} + + +#' @author Maximilian Pichler +#' @export +print.prior <- function(x, ...){ + cat('Prior: \n\n') + + prior = x + info = c( "lower", "upper","best") + maxPar = max(length(prior$lower),length(prior$lupper)) + if(maxPar == 0) maxPar = ncol(prior$sampler()) + priorInfo = data.frame(matrix(NA, ncol = 3, nrow = maxPar)) + colnames(priorInfo) = info + for(i in 1:3) if(!is.null(prior[[info[i]]])) priorInfo[,i] <- prior[[info[i]]] + rownames(priorInfo) <- sapply(1:maxPar, FUN = function(x) return(paste("par",x))) + print(priorInfo) + +} diff --git a/BayesianTools/R/codaFunctions.R b/BayesianTools/R/codaFunctions.R index 234dcfb..f0dc6aa 100644 --- a/BayesianTools/R/codaFunctions.R +++ b/BayesianTools/R/codaFunctions.R @@ -1,59 +1,58 @@ -#' Function to combine chains -#' -#' @param x a list of MCMC chains -#' @param merge should chains be merged? (T or F) -#' @return combined chains -#' -#' @note to combine several chains to a single McmcSamplerList, see \code{\link{createMcmcSamplerList}} -#' -#' @keywords internal -combineChains <- function(x, merge = T){ - - if(merge == T){ - temp1 = as.matrix(x[[1]]) - - names = colnames(temp1) - - sel = seq(1, by = length(x), len = nrow(temp1) ) - - out = matrix(NA, nrow = length(x) * nrow(temp1), ncol = ncol(temp1)) - out[sel, ] = temp1 - if (length(x) > 1){ - for (i in 2:length(x)){ - out[sel+i-1, ] = as.matrix(x[[i]]) - } - } - - colnames(out) = names - - } else{ - - out = as.matrix(x[[1]]) - if (length(x) > 1){ - for (i in 2:length(x)){ - out = rbind(out, as.matrix(x[[i]])) - } - } - } - - return(out) -} - - - -#' Helper function to change an object to a coda mcmc class, -#' -#' @param chain mcmc Chain -#' @param start For MCMC samplers, the initial value in the chain. For SMC samplers, initial particle -#' @param end For MCMC samplers, the end value in the chain. For SMC samplers, end particle. -#' @param thin thinning parameter -#' @return object an object of class coda::mcmc -#' @details Very similar to coda::mcmc but with less overhead -#' @keywords internal -makeObjectClassCodaMCMC <- function (chain, start = 1, end = numeric(0), thin = 1){ - attr(chain, "mcpar") <- c(start, end, thin) - attr(chain, "class") <- "mcmc" - chain -} - - +#' Function to combine chains +#' @param x a list of MCMC chains +#' @param merge should chains be merged? (T or F) +#' @return combined chains +#' +#' @note to combine several chains to a single McmcSamplerList, see \code{\link{createMcmcSamplerList}} +#' +#' @keywords internal +combineChains <- function(x, merge = T){ + + if(merge == T){ + temp1 = as.matrix(x[[1]]) + + names = colnames(temp1) + + sel = seq(1, by = length(x), len = nrow(temp1) ) + + out = matrix(NA, nrow = length(x) * nrow(temp1), ncol = ncol(temp1)) + out[sel, ] = temp1 + if (length(x) > 1){ + for (i in 2:length(x)){ + out[sel+i-1, ] = as.matrix(x[[i]]) + } + } + + colnames(out) = names + + } else{ + + out = as.matrix(x[[1]]) + if (length(x) > 1){ + for (i in 2:length(x)){ + out = rbind(out, as.matrix(x[[i]])) + } + } + } + + return(out) +} + + + +#' Helper function to change an object to a coda mcmc class, +#' +#' @param chain mcmc Chain +#' @param start For MCMC samplers, the initial value in the chain. For SMC samplers, initial particle +#' @param end For MCMC samplers, the end value in the chain. For SMC samplers, end particle. +#' @param thin thinning parameter +#' @return object an object of class coda::mcmc +#' @details Very similar to coda::mcmc but with less overhead +#' @keywords internal +makeObjectClassCodaMCMC <- function (chain, start = 1, end = numeric(0), thin = 1){ + attr(chain, "mcpar") <- c(start, end, thin) + attr(chain, "class") <- "mcmc" + chain +} + + diff --git a/BayesianTools/R/convertCoda.R b/BayesianTools/R/convertCoda.R index 5aa453a..c269ac0 100644 --- a/BayesianTools/R/convertCoda.R +++ b/BayesianTools/R/convertCoda.R @@ -1,52 +1,51 @@ - -#' Convert coda::mcmc objects to BayesianTools::mcmcSampler -#' @description Function to support plotting and diagnostic functions for coda::mcmc objects. -#' @param sampler an object of class mcmc or mcmc.list -#' @param names a vector with parameter names (optional) -#' @param info a matrix (or list with matrices for mcmc.list objects) with three columns containing log posterior, log likelihood and log prior of the sampler for each time step (optional; but see Details) -#' @param likelihood likelihood function used for sampling (see Details) -#' @details The parameter 'likelihood' is optional for most functions but can be needed e.g for \code{\link{DIC}} function. -#' -#' Also, the parameter information is typically optional for most uses. However, for certain functions (e.g. \code{\link{MAP}}), the matrix or single columns (e.g. log posterior) are necessary for diagnostics. -#' @export - -convertCoda <- function(sampler, names = NULL, info = NULL, likelihood = NULL){ - - likelihood <- list(density = likelihood) - - if(inherits(sampler, "mcmc")){ - - if(is.null(names)){ - names <- paste("Par",1:ncol(sampler)) - } - setup <- list(names = names, numPars = ncol(sampler), likelihood = likelihood) - - if(is.null(info)) info <- matrix(NA, nrow = nrow(sampler), ncol = 3) - out <- list(chain = cbind(sampler,info), setup = setup) - class(out) = c("mcmcSampler", "bayesianOutput") - - - }else{ if(inherits(sampler, "mcmc.list")){ - - if(is.null(names)){ - names <- paste("Par",1:ncol(sampler[[1]])) - } - setup <- list(names = names, numPars = ncol(sampler[[1]]), likelihood = likelihood) - - if(is.null(info)){ - info <- list() - for(i in 1:length(sampler)) info[[i]] <- matrix(NA, nrow = nrow(sampler[[1]]), ncol = 3) - } - - chain <- list() - for(i in 1:length(sampler)){ - chain[[i]] <- cbind(sampler[[i]], info[[i]]) - } - class(chain) = "mcmc.list" - out <- list(chain = chain, setup = setup) - class(out) = c("mcmcSampler", "bayesianOutput") - }else stop("sampler must be of class 'coda::mcmc' or 'coda::mcmc.list'") - } - return(out) - +#' Convert coda::mcmc objects to BayesianTools::mcmcSampler +#' @description Function to support plotting and diagnostic functions for coda::mcmc objects. +#' @param sampler an object of class mcmc or mcmc.list +#' @param names a vector with parameter names (optional) +#' @param info a matrix (or list with matrices for mcmc.list objects) with three columns containing log posterior, log likelihood and log prior of the sampler for each time step (optional; but see Details) +#' @param likelihood likelihood function used for sampling (see Details) +#' @details The parameter 'likelihood' is optional for most functions but can be needed e.g for \code{\link{DIC}} function. +#' +#' Also, the parameter information is typically optional for most uses. However, for certain functions (e.g. \code{\link{MAP}}), the matrix or single columns (e.g. log posterior) are necessary for diagnostics. +#' @export + +convertCoda <- function(sampler, names = NULL, info = NULL, likelihood = NULL){ + + likelihood <- list(density = likelihood) + + if(inherits(sampler, "mcmc")){ + + if(is.null(names)){ + names <- paste("Par",1:ncol(sampler)) + } + setup <- list(names = names, numPars = ncol(sampler), likelihood = likelihood) + + if(is.null(info)) info <- matrix(NA, nrow = nrow(sampler), ncol = 3) + out <- list(chain = cbind(sampler,info), setup = setup) + class(out) = c("mcmcSampler", "bayesianOutput") + + + }else{ if(inherits(sampler, "mcmc.list")){ + + if(is.null(names)){ + names <- paste("Par",1:ncol(sampler[[1]])) + } + setup <- list(names = names, numPars = ncol(sampler[[1]]), likelihood = likelihood) + + if(is.null(info)){ + info <- list() + for(i in 1:length(sampler)) info[[i]] <- matrix(NA, nrow = nrow(sampler[[1]]), ncol = 3) + } + + chain <- list() + for(i in 1:length(sampler)){ + chain[[i]] <- cbind(sampler[[i]], info[[i]]) + } + class(chain) = "mcmc.list" + out <- list(chain = chain, setup = setup) + class(out) = c("mcmcSampler", "bayesianOutput") + }else stop("sampler must be of class 'coda::mcmc' or 'coda::mcmc.list'") + } + return(out) + } \ No newline at end of file diff --git a/BayesianTools/R/getVolume.R b/BayesianTools/R/getVolume.R index a37f4c5..c84a439 100644 --- a/BayesianTools/R/getVolume.R +++ b/BayesianTools/R/getVolume.R @@ -1,35 +1,36 @@ -#' Calculate posterior volume -#' @author Florian Hartig -#' @param sampler an object of superclass bayesianOutput or any other class that has implemented the getSample function (e.g. Matrix) -#' @param prior logical, should prior volume be calculated? -#' @param method method for volume estimation. Currently, the only option is "MVN" -#' @param ... additional parameters to pass on to the \code{\link{getSample}} -#' @details The idea of this function is to provide an estimate of the "posterior volume", i.e. how "broad" the posterior is. One potential application is the overall reduction of parametric uncertainty between different data types, or between prior and posterior. -#' -#' Implemented methods for volume estimation: -#' -#' Option "MVN" - in this option, the volume is calculated as the determinant of the covariance matrix of the prior / posterior sample. -#' -#' @example /inst/examples/getVolume.R -#' @export -getVolume <- function(sampler, prior = F, method = "MVN", ...){ - - x = getSample(sampler, ...) - - if(method == "MVN"){ - nPars = ncol(x) - postVol = det(cov(x)) - }else stop("BayesianTools: unknown method argument in getVolume") - - if(prior == T){ - x = sampler$setup$prior$sampler(5000) - - if(method == "MVN"){ - nPars = ncol(x) - priorVol = det(cov(x)) - }else stop("BayesianTools: unknown method argument in getVolume") - return(list(priorVol = priorVol, postVol = postVol)) - }else return(postVol) -} - - + +#' Calculate posterior volume +#' @author Florian Hartig +#' @param sampler an object of superclass bayesianOutput or any other class that has implemented the getSample function (e.g. Matrix) +#' @param prior logical, should prior volume be calculated? +#' @param method method for volume estimation. Currently, the only option is "MVN" +#' @param ... additional parameters to pass on to the \code{\link{getSample}} +#' @details The idea of this function is to provide an estimate of the "posterior volume", i.e. how "broad" the posterior is. One potential application is the overall reduction of parametric uncertainty between different data types, or between prior and posterior. +#' +#' Implemented methods for volume estimation: +#' +#' Option "MVN" - in this option, the volume is calculated as the determinant of the covariance matrix of the prior / posterior sample. +#' +#' @example /inst/examples/getVolume.R +#' @export +getVolume <- function(sampler, prior = F, method = "MVN", ...){ + + x = getSample(sampler, ...) + + if(method == "MVN"){ + nPars = ncol(x) + postVol = det(cov(x)) + }else stop("BayesianTools: unknown method argument in getVolume") + + if(prior == T){ + x = sampler$setup$prior$sampler(5000) + + if(method == "MVN"){ + nPars = ncol(x) + priorVol = det(cov(x)) + }else stop("BayesianTools: unknown method argument in getVolume") + return(list(priorVol = priorVol, postVol = postVol)) + }else return(postVol) +} + + diff --git a/BayesianTools/R/marginalLikelihood.R b/BayesianTools/R/marginalLikelihood.R index 940c55d..9d78bba 100644 --- a/BayesianTools/R/marginalLikelihood.R +++ b/BayesianTools/R/marginalLikelihood.R @@ -1,189 +1,188 @@ - -# Motivation for this functions from -# https://radfordneal.wordpress.com/2008/08/17/the-harmonic-mean-of-the-likelihood-worst-monte-carlo-method-ever/ -# https://gist.github.com/gaberoo/4619102 - - -# ' @export -#marginalLikelihood <- function(x,lik,V,sampler$setup$likelihood$density,sampler$setup$prior$density,..., num.samples=1000,log=TRUE) UseMethod("marginalLikelihood") - -#' Calcluated the marginal likelihood from a set of MCMC samples -#' @export -#' @author Florian Hartig -#' @param sampler an MCMC or SMC sampler or list, or for method "Prior" also a BayesianSetup -#' @param numSamples number of samples to use. How this works, and if it requires recalculating the likelihood, depends on the method -#' @param method method to choose. Currently available are "Chib" (default), the harmonic mean "HM", sampling from the prior "Prior", and bridge sampling "Bridge". See details -#' @param ... further arguments passed to \code{\link{getSample}} -#' @details The marginal likelihood is the average likelihood across the prior space. It is used, for example, for Bayesian model selection and model averaging. -#' -#' It is defined as \deqn{ML = \int L(\Theta) p(\Theta) d\Theta} -#' -#' Given that MLs are calculated for each model, you can get posterior weights (for model selection and/or model averaging) on the model by -#' -#' \deqn{P(M_i|D) = ML_i * p(M_i) / (\sum_i ML_i * p(M_i) )} -#' -#' In BT, we return the log ML, so you will have to exp all values for this formula. -#' -#' It is well-known that the ML is strongly dependent on the prior, and in particular the choice of the width of uninformative priors may have major impacts on the relative weights of the models. It has therefore been suggested to not use the ML for model averaging / selection on uninformative priors. If you have no informative priors, and option is to split the data into two parts, use one part to generate informative priors for the model, and the second part for the model selection. See help for an example. -#' -#' The marginalLikelihood function currently implements four ways to calculate the marginal likelihood. Be aware that marginal likelihood calculations are notoriously prone to numerical stability issues. Especially in high-dimensional parameter spaces, there is no guarantee that any of the implemented algorithms will converge reasonably fast. The recommended (and default) method is the method "Chib" (Chib and Jeliazkov, 2001), which is based on MCMC samples, with a limited number of additional calculations. Despite being the current recommendation, note there are some numeric issues with this algorithm that may limit reliability for larger dimensions. -#' -#' The harmonic mean approximation, is implemented only for comparison. Note that the method is numerically unreliable and usually should not be used. -#' -#' The third method is simply sampling from the prior. While in principle unbiased, it will only converge for a large number of samples, and is therefore numerically inefficient. -#' -#' The Bridge method uses bridge sampling as implemented in the R package "bridgesampling". It is potentially more exact than the Chib method, but might require more computation time. However, this may be very dependent on the sampler. -#' -#' @return A list with log of the marginal likelihood, as well as other diagnostics depending on the chosen method -#' -#' @example /inst/examples/marginalLikelihoodHelp.R -#' @references -#' -#' Chib, Siddhartha, and Ivan Jeliazkov. "Marginal likelihood from the Metropolis-Hastings output." Journal of the American Statistical Association 96.453 (2001): 270-281. -#' -#' Dormann et al. 2018. Model averaging in ecology: a review of Bayesian, information-theoretic, and tactical approaches for predictive inference. Ecological Monographs -#' -#' @seealso \code{\link{WAIC}}, \code{\link{DIC}}, \code{\link{MAP}} -marginalLikelihood <- function(sampler, numSamples = 1000, method = "Chib", ...){ - - - if ((class(sampler)[1] %in% c("mcmcSamplerList", "smcSamplerList"))) { - setup <- sampler[[1]]$setup - posterior = sampler[[1]]$setup$posterior$density - } else if ((class(sampler)[1] %in% c("mcmcSampler", "smcSampler"))) { - setup <- sampler$setup - posterior = sampler$setup$posterior$density - } else if ((class(sampler)[1] %in% c("BayesianSetup"))) { - setup <- sampler - posterior = sampler$posterior$density - } else stop("sampler must be a sampler or a BayesianSetup") - - - if (method == "Chib"){ - - chain <- getSample(sampler = sampler, parametersOnly = F, ...) - - if(class(sampler)[1] %in% c("mcmcSamplerList", "smcSamplerList")) sampler <- sampler[[1]] - - x <- chain[,1:sampler$setup$numPars,drop=F] - - lik <- chain[,sampler$setup$numPars + 2] - MAPindex <- which.max(chain[,sampler$setup$numPars + 1]) - - #propGen = createProposalGenerator(covariance = cov(x)) - - V <- cov(x) - - # calculate reference parameter - - theta.star <- x[MAPindex,,drop=F] - lik.star <- lik[MAPindex] - - # get samples from posterior - - g <- sample.int(nrow(x), numSamples, replace=TRUE) # should replace really be true? - q.g <- mvtnorm::dmvnorm(x[g,,drop=F], mean = theta.star, sigma = V, log = FALSE) - lik.g <- lik[g] - alpha.g <- sapply(lik.g, function(l) min(1, exp(lik.star - l))) # Metropolis Ratio - - #lik.g <- apply(theta.g,1,sampler$setup$likelihood$density,...) - - - # get samples from proposal - theta.j <- mvtnorm::rmvnorm(numSamples, mean = theta.star, sigma = V) - lik.j <- apply(theta.j, 1, sampler$setup$likelihood$density) - alpha.j <- sapply(lik.j, function(l) min(1, exp(l - lik.star))) # Metropolis Ratio - - # Prior - pi.hat <- mean(alpha.g * q.g) / mean(alpha.j) - pi.star <- 0 - - if (!is.null(sampler$setup$prior$density)) pi.star <- sampler$setup$prior$density(theta.star) - ln.m <- lik.star + pi.star - log(pi.hat) - - out <- list(ln.ML = ln.m, ln.lik.star = lik.star, ln.pi.star = pi.star, ln.pi.hat = log(pi.hat), method = "Chib") - - } else if (method == "HM"){ - - warning("The Harmonic Mean estimator is notoriously unstable. It's only implemented for comparison. We strongly advice against using it for research!") - - chain <- getSample(sampler = sampler, parametersOnly = F, ...) - lik <- chain[, setup$numPars + 2] - ml <- log(1 / mean(1 / exp(lik))) - # ml = 1 / logSumExp(-lik, mean = T) function needs to be adjusted - out <- list(ln.ML=ml, method ="HM") - - } else if (method == "Prior"){ - - samples <- setup$prior$sampler(numSamples) - likelihoods <- setup$likelihood$density(samples) - - ml <- logSumExp(likelihoods, mean = T) - out <- list(ln.ML=ml, method ="Prior") - - } else if (method == "Bridge") { - - chain <- getSample(sampler = sampler, parametersOnly = F, numSamples = numSamples, ...) - - nParams <- setup$numPars - lower <- setup$prior$lower - upper <- setup$prior$upper - - - out <- list(ln.ML = bridgesample(chain ,nParams, lower, upper, posterior)$logml, method ="Bridge") - - } else if ("NN") { - - # TODO: implement nearest neighbour method: - # https://arxiv.org/abs/1704.03472 - stop("Not yet implemented") - - } else { - stop(paste(c("\"", method, "\" is not a valid method parameter!"), sep = " ", collapse = "")) - } - - return(out) -} - - -#' Calculates the marginal likelihood of a chain via bridge sampling -#' @export -#' @author Tankred Ott -#' @param chain a single mcmc chain with samples as rows and parameters and posterior density as columns. -#' @param nParams number of parameters -#' @param lower optional - lower bounds of the prior -#' @param upper optional - upper bounds of the prior -#' @param posterior posterior density function -#' @param ... arguments passed to bridge_sampler -#' @details This function uses "bridge_sampler" from the package "bridgesampling". -#' @example /inst/examples/bridgesampleHelp.R -#' @seealso \code{\link{marginalLikelihood}} -#' @keywords internal -bridgesample <- function (chain, nParams, lower = NULL, upper = NULL, posterior, ...) { - # TODO: implement this without bridgesampling package - # https://github.com/quentingronau/bridgesampling - if (is.null(lower)) lower <- rep(-Inf, nParams) - if (is.null(upper)) upper <- rep(Inf, nParams) - - names(lower) <- names(upper) <- colnames(chain[, 1:nParams]) - - log_posterior = function(x, data){ - return(posterior(x)) - } - - out <- bridgesampling::bridge_sampler( - samples = chain[, 1:nParams], - log_posterior = log_posterior, - data = chain, - lb = lower, - ub = upper, - ... - ) - - return(out) -} - - - - - +# Motivation for this functions from +# https://radfordneal.wordpress.com/2008/08/17/the-harmonic-mean-of-the-likelihood-worst-monte-carlo-method-ever/ +# https://gist.github.com/gaberoo/4619102 + + +# ' @export +#marginalLikelihood <- function(x,lik,V,sampler$setup$likelihood$density,sampler$setup$prior$density,..., num.samples=1000,log=TRUE) UseMethod("marginalLikelihood") + +#' Calcluated the marginal likelihood from a set of MCMC samples +#' @export +#' @author Florian Hartig +#' @param sampler an MCMC or SMC sampler or list, or for method "Prior" also a BayesianSetup +#' @param numSamples number of samples to use. How this works, and if it requires recalculating the likelihood, depends on the method +#' @param method method to choose. Currently available are "Chib" (default), the harmonic mean "HM", sampling from the prior "Prior", and bridge sampling "Bridge". See details +#' @param ... further arguments passed to \code{\link{getSample}} +#' @details The marginal likelihood is the average likelihood across the prior space. It is used, for example, for Bayesian model selection and model averaging. +#' +#' It is defined as \deqn{ML = \int L(\Theta) p(\Theta) d\Theta} +#' +#' Given that MLs are calculated for each model, you can get posterior weights (for model selection and/or model averaging) on the model by +#' +#' \deqn{P(M_i|D) = ML_i * p(M_i) / (\sum_i ML_i * p(M_i) )} +#' +#' In BT, we return the log ML, so you will have to exp all values for this formula. +#' +#' It is well-known that the ML is strongly dependent on the prior, and in particular the choice of the width of uninformative priors may have major impacts on the relative weights of the models. It has therefore been suggested to not use the ML for model averaging / selection on uninformative priors. If you have no informative priors, and option is to split the data into two parts, use one part to generate informative priors for the model, and the second part for the model selection. See help for an example. +#' +#' The marginalLikelihood function currently implements four ways to calculate the marginal likelihood. Be aware that marginal likelihood calculations are notoriously prone to numerical stability issues. Especially in high-dimensional parameter spaces, there is no guarantee that any of the implemented algorithms will converge reasonably fast. The recommended (and default) method is the method "Chib" (Chib and Jeliazkov, 2001), which is based on MCMC samples, with a limited number of additional calculations. Despite being the current recommendation, note there are some numeric issues with this algorithm that may limit reliability for larger dimensions. +#' +#' The harmonic mean approximation, is implemented only for comparison. Note that the method is numerically unreliable and usually should not be used. +#' +#' The third method is simply sampling from the prior. While in principle unbiased, it will only converge for a large number of samples, and is therefore numerically inefficient. +#' +#' The Bridge method uses bridge sampling as implemented in the R package "bridgesampling". It is potentially more exact than the Chib method, but might require more computation time. However, this may be very dependent on the sampler. +#' +#' @return A list with log of the marginal likelihood, as well as other diagnostics depending on the chosen method +#' +#' @example /inst/examples/marginalLikelihoodHelp.R +#' @references +#' +#' Chib, Siddhartha, and Ivan Jeliazkov. "Marginal likelihood from the Metropolis-Hastings output." Journal of the American Statistical Association 96.453 (2001): 270-281. +#' +#' Dormann et al. 2018. Model averaging in ecology: a review of Bayesian, information-theoretic, and tactical approaches for predictive inference. Ecological Monographs +#' +#' @seealso \code{\link{WAIC}}, \code{\link{DIC}}, \code{\link{MAP}} +marginalLikelihood <- function(sampler, numSamples = 1000, method = "Chib", ...){ + + + if ((class(sampler)[1] %in% c("mcmcSamplerList", "smcSamplerList"))) { + setup <- sampler[[1]]$setup + posterior = sampler[[1]]$setup$posterior$density + } else if ((class(sampler)[1] %in% c("mcmcSampler", "smcSampler"))) { + setup <- sampler$setup + posterior = sampler$setup$posterior$density + } else if ((class(sampler)[1] %in% c("BayesianSetup"))) { + setup <- sampler + posterior = sampler$posterior$density + } else stop("sampler must be a sampler or a BayesianSetup") + + + if (method == "Chib"){ + + chain <- getSample(sampler = sampler, parametersOnly = F, ...) + + if(class(sampler)[1] %in% c("mcmcSamplerList", "smcSamplerList")) sampler <- sampler[[1]] + + x <- chain[,1:sampler$setup$numPars,drop=F] + + lik <- chain[,sampler$setup$numPars + 2] + MAPindex <- which.max(chain[,sampler$setup$numPars + 1]) + + #propGen = createProposalGenerator(covariance = cov(x)) + + V <- cov(x) + + # calculate reference parameter + + theta.star <- x[MAPindex,,drop=F] + lik.star <- lik[MAPindex] + + # get samples from posterior + + g <- sample.int(nrow(x), numSamples, replace=TRUE) # should replace really be true? + q.g <- mvtnorm::dmvnorm(x[g,,drop=F], mean = theta.star, sigma = V, log = FALSE) + lik.g <- lik[g] + alpha.g <- sapply(lik.g, function(l) min(1, exp(lik.star - l))) # Metropolis Ratio + + #lik.g <- apply(theta.g,1,sampler$setup$likelihood$density,...) + + + # get samples from proposal + theta.j <- mvtnorm::rmvnorm(numSamples, mean = theta.star, sigma = V) + lik.j <- apply(theta.j, 1, sampler$setup$likelihood$density) + alpha.j <- sapply(lik.j, function(l) min(1, exp(l - lik.star))) # Metropolis Ratio + + # Prior + pi.hat <- mean(alpha.g * q.g) / mean(alpha.j) + pi.star <- 0 + + if (!is.null(sampler$setup$prior$density)) pi.star <- sampler$setup$prior$density(theta.star) + ln.m <- lik.star + pi.star - log(pi.hat) + + out <- list(ln.ML = ln.m, ln.lik.star = lik.star, ln.pi.star = pi.star, ln.pi.hat = log(pi.hat), method = "Chib") + + } else if (method == "HM"){ + + warning("The Harmonic Mean estimator is notoriously unstable. It's only implemented for comparison. We strongly advice against using it for research!") + + chain <- getSample(sampler = sampler, parametersOnly = F, ...) + lik <- chain[, setup$numPars + 2] + ml <- log(1 / mean(1 / exp(lik))) + # ml = 1 / logSumExp(-lik, mean = T) function needs to be adjusted + out <- list(ln.ML=ml, method ="HM") + + } else if (method == "Prior"){ + + samples <- setup$prior$sampler(numSamples) + likelihoods <- setup$likelihood$density(samples) + + ml <- logSumExp(likelihoods, mean = T) + out <- list(ln.ML=ml, method ="Prior") + + } else if (method == "Bridge") { + + chain <- getSample(sampler = sampler, parametersOnly = F, numSamples = numSamples, ...) + + nParams <- setup$numPars + lower <- setup$prior$lower + upper <- setup$prior$upper + + + out <- list(ln.ML = bridgesample(chain ,nParams, lower, upper, posterior)$logml, method ="Bridge") + + } else if ("NN") { + + # TODO: implement nearest neighbour method: + # https://arxiv.org/abs/1704.03472 + stop("Not yet implemented") + + } else { + stop(paste(c("\"", method, "\" is not a valid method parameter!"), sep = " ", collapse = "")) + } + + return(out) +} + + +#' Calculates the marginal likelihood of a chain via bridge sampling +#' @export +#' @author Tankred Ott +#' @param chain a single mcmc chain with samples as rows and parameters and posterior density as columns. +#' @param nParams number of parameters +#' @param lower optional - lower bounds of the prior +#' @param upper optional - upper bounds of the prior +#' @param posterior posterior density function +#' @param ... arguments passed to bridge_sampler +#' @details This function uses "bridge_sampler" from the package "bridgesampling". +#' @example /inst/examples/bridgesampleHelp.R +#' @seealso \code{\link{marginalLikelihood}} +#' @keywords internal +bridgesample <- function (chain, nParams, lower = NULL, upper = NULL, posterior, ...) { + # TODO: implement this without bridgesampling package + # https://github.com/quentingronau/bridgesampling + if (is.null(lower)) lower <- rep(-Inf, nParams) + if (is.null(upper)) upper <- rep(Inf, nParams) + + names(lower) <- names(upper) <- colnames(chain[, 1:nParams]) + + log_posterior = function(x, data){ + return(posterior(x)) + } + + out <- bridgesampling::bridge_sampler( + samples = chain[, 1:nParams], + log_posterior = log_posterior, + data = chain, + lb = lower, + ub = upper, + ... + ) + + return(out) +} + + + + + diff --git a/BayesianTools/R/mcmcDE.R b/BayesianTools/R/mcmcDE.R index 1589079..7f677c2 100644 --- a/BayesianTools/R/mcmcDE.R +++ b/BayesianTools/R/mcmcDE.R @@ -1,235 +1,234 @@ -#' Differential-Evolution MCMC -#' @author Francesco Minunno and Stefan Paul -#' @param bayesianSetup a BayesianSetup with the posterior density function to be sampled from -#' @param settings list with parameter settings -#' @param startValue (optional) either a matrix with start population, a number defining the number of chains to be run or a function that samples a starting population. -#' @param iterations number of function evaluations. -#' @param burnin number of iterations treated as burn-in. These iterations are not recorded in the chain. -#' @param thin thinning parameter. Determines the interval in which values are recorded. -#' @param f scaling factor gamma -#' @param eps small number to avoid singularity -#' @param blockUpdate list determining whether parameters should be updated in blocks. For possible settings see Details. -#' @param message logical, Specifies whether to print the progress of the sampler. -#' @references Braak, Cajo JF Ter. "A Markov Chain Monte Carlo version of the genetic algorithm Differential Evolution: easy Bayesian computing for real parameter spaces." Statistics and Computing 16.3 (2006): 239-249. -#' @export -#' @example /inst/examples/DEfamilyHelp.R -#' @seealso \code{\link{DEzs}} -#' @details For blockUpdate the first element in the list determines the type of blocking. -#' Possible choices are -#' \itemize{ -#' \item{"none"}{ (default), no blocking of parameters} -#' \item{"correlation"} { blocking based on correlation of parameters. Using h or k (see below)} -#' \item{"random"} { random blocking. Using k (see below)} -#' \item{"user"} { user defined groups. Using groups (see below)} -#' } -#' Further, seven parameters can be specified. "k" defines the number of groups, "h" the strength -#' of the correlation used to group the parameters and "groups" is used for user defined groups. -#' "groups" is a vector containing the group number for each parameter. E.g. for three parameters -#' with the first two in one group, "groups" would be c(1,1,2). -#' Moreover, pSel and pGroup can be used to influence the choice of groups. In the sampling process -#' a number of groups are drawn at random and updated. pSel is a vector containing relative probabilities -#' for updating the respective number of groups. E.g. To update one group at a time pSel = 1. -#' For updating one or two groups with the same probability pSel = c(1,1). By default all numbers -#' have the same probability. -#' The same principle is used for pGroup. Here the user can influence the probability of each group -#' to be updated. By default all groups have the same probability. -#' Finally, "groupStart" defines the starting point of the groupUpdate and "groupIntervall" - the interval -#' in which the groups are evaluated. - -DE <- function(bayesianSetup, - settings = list( - startValue = NULL, - iterations = 10000, - f = -2.38, - burnin = 0, - thin = 1, - eps = 0, - consoleUpdates = 100, - blockUpdate = list("none", k = NULL, h = NULL, pSel = NULL, pGroup = NULL, - groupStart = 1000, groupIntervall = 1000), - currentChain = 1, - message = TRUE - ) - ){ - - if("bayesianOutput" %in% class(bayesianSetup)){ - restart <- TRUE - } else restart <- FALSE - - - if(restart){ - if(is.null(settings)) settings <- bayesianSetup$settings - else settings <- applySettingsDefault(settings = settings, sampler = "DE") - - }else{ - # If nothing provided use default settings - settings <- applySettingsDefault(settings = settings, sampler = "DE") - } - - if(!restart){ - setup <- bayesianSetup - }else{ - setup <- bayesianSetup$setup - } - - - setup <- checkBayesianSetup(setup, parallel = settings$parallel) # calling parallel will check if requested parallelization in settings is provided by the BayesianSetup - if(is.null(settings$parallel)) settings$parallel = setup$parallel # checking back - if no parallelization is provided, we use the parallelization in the BayesianSetup. We could also set parallel = F, but I feel it makes more sense to use the Bayesiansetup as default - - if(!restart){ - if(is.null(settings$startValue)){ - parLen = length(bayesianSetup$prior$sampler(1)) - X = bayesianSetup$prior$sampler(3 * parLen) - } - if(is.function(settings$startValue)){ - X = settings$startValue() - } - if(class(settings$startValue)[1] == "numeric"){ - X = bayesianSetup$prior$sampler(settings$startValue) - } - if(is.matrix(settings$startValue)) X <- settings$startValue - }else{ - X <- bayesianSetup$X - } - - # X = startValue - if (!is.matrix(X)) stop("wrong starting values") - - FUN = setup$posterior$density - - ## Initialize blockUpdate parameters and settings - blockdefault <- list("none", k = NULL, h = NULL, pSel = NULL, pGroup = NULL, - groupStart = 1000, groupIntervall = 1000) - - if(!is.null(settings$blockUpdate)){ - blockUpdate <- modifyList(blockdefault, settings$blockUpdate) - blockUpdate[[1]] <- settings$blockUpdate[[1]] # to catch first argument - if(blockUpdate[[1]] == "none"){ - blockUpdateType <- "none" - blocks = FALSE - BlockStart = FALSE - }else{ - groupStart <- blockUpdate$groupStart - groupIntervall <- blockUpdate$groupIntervall - blockUpdateType = blockUpdate[[1]] - blocks = TRUE - ## Initialize BlockStart - BlockStart = FALSE - Bcount = 0 - } - }else{ - blockUpdateType <- "none" - blocks = FALSE - BlockStart = FALSE - } - - - - Npar <- ncol(X) - Npop <- nrow(X) - burnin <- settings$burnin/Npop - n.iter <- ceiling(settings$iterations/Npop) - - if (n.iter < 2) stop ("The total number of iterations must be greater than the number of parameters to fit times 3.") - - lChain <- ceiling((n.iter - burnin)/settings$thin)+1 - #pChain <- array(NA, dim=c(n.iter*Npop, Npar+3)) - - pChain <- array(NA, dim=c(lChain, Npar+3, Npop)) - - - colnames(pChain) <- c(setup$names, "LP", "LL", "LPr") - - counter <- 1 - iseq <- 1:Npop - - - F2 = abs(settings$f)/sqrt(2*Npar) - if (settings$f>0) F1 = F2 else F1 = 0.98 - - logfitness_X <- FUN(X, returnAll = T) - - # Write first values in chain - pChain[1,,] <- t(cbind(X,logfitness_X)) - - # Print adjusted iterations - # cat("Iterations adjusted to", n.iter*Npop,"to fit settings", "\n") - - #### - eps <- settings$eps - currentChain <- settings$currentChain - iterations <- settings$iterations - - for (iter in 2:n.iter) { - - if (iter%%10) F_cur = F2 else F_cur = F1 - - - if(blocks){ - ### Update the groups. - if(iter == groupStart+ Bcount*groupIntervall){ - blockSettings <- updateGroups(chain = pChain[1:counter,, ], blockUpdate) - BlockStart <- TRUE - Bcount <- Bcount + 1 - } - } - #### - - for (i in iseq){ - # select to random different individuals (and different from i) in rr, a 2-vector - - rr <- sample(iseq[-i], 2, replace = FALSE) - x_prop <- X[i,] + F_cur * (X[rr[1],]-X[rr[2],]) + eps * rnorm(Npar,0,1) - - if(BlockStart){ - # Get the current group and update the proposal accordingly - Member <- getBlock(blockSettings) - x_prop[-Member] <- X[i,-Member] - #### - } - - logfitness_x_prop <- FUN(x_prop, returnAll = T) - if(!is.na(logfitness_x_prop[1] - logfitness_X[i,1])){ # To catch possible error - if ((logfitness_x_prop[1] - logfitness_X[i,1] ) > log(runif(1))){ - X[i,] <- x_prop - logfitness_X[i,] <- logfitness_x_prop - } - } - } #iseq - if ((iter > burnin) && (iter %% settings$thin == 0) ) { # retain sample - counter <- counter+1 - pChain[counter,,] <- t(cbind(X,logfitness_X)) - - } - - if(settings$message){ - if( (iter %% settings$consoleUpdates == 0) | (iter == n.iter)) cat("\r","Running DE-MCMC, chain ", currentChain, - "iteration" ,iter*Npop,"of",n.iter*Npop,". Current logp ", - logfitness_X[,1], - "Please wait!","\r") - flush.console() - } - - } # n.iter - iterationsOld <- 0 - - pChain <- pChain[1:counter,,] - - if(restart){ # Combine chains - newchains <- array(NA, dim = c((counter+nrow(bayesianSetup$chain[[1]])), (Npar+3), Npop)) - - for(i in 1:Npop){ - for(k in 1:(Npar+3)){ - newchains[,k,i] <- c(bayesianSetup$chain[[i]][,k],pChain[,k,i]) - } - } - pChain <- newchains - } - - - - pChain<- coda::as.mcmc.list(lapply(1:Npop,function(i) coda::as.mcmc(pChain[,1:(Npar+3),i]))) - - - list(Draws = pChain, X = as.matrix(X[,1:Npar])) - } +#' Differential-Evolution MCMC +#' @author Francesco Minunno and Stefan Paul +#' @param bayesianSetup a BayesianSetup with the posterior density function to be sampled from +#' @param settings list with parameter settings +#' @param startValue (optional) either a matrix with start population, a number defining the number of chains to be run or a function that samples a starting population. +#' @param iterations number of function evaluations. +#' @param burnin number of iterations treated as burn-in. These iterations are not recorded in the chain. +#' @param thin thinning parameter. Determines the interval in which values are recorded. +#' @param f scaling factor gamma +#' @param eps small number to avoid singularity +#' @param blockUpdate list determining whether parameters should be updated in blocks. For possible settings see Details. +#' @param message logical, Specifies whether to print the progress of the sampler. +#' @references Braak, Cajo JF Ter. "A Markov Chain Monte Carlo version of the genetic algorithm Differential Evolution: easy Bayesian computing for real parameter spaces." Statistics and Computing 16.3 (2006): 239-249. +#' @export +#' @example /inst/examples/DEfamilyHelp.R +#' @seealso \code{\link{DEzs}} +#' @details For blockUpdate the first element in the list determines the type of blocking. +#' Possible choices are +#' \itemize{ +#' \item{"none"}{ (default), no blocking of parameters} +#' \item{"correlation"} { blocking based on correlation of parameters. Using h or k (see below)} +#' \item{"random"} { random blocking. Using k (see below)} +#' \item{"user"} { user defined groups. Using groups (see below)} +#' } +#' Further, seven parameters can be specified. "k" defines the number of groups, "h" the strength +#' of the correlation used to group the parameters and "groups" is used for user defined groups. +#' "groups" is a vector containing the group number for each parameter. E.g. for three parameters +#' with the first two in one group, "groups" would be c(1,1,2). +#' Moreover, pSel and pGroup can be used to influence the choice of groups. In the sampling process +#' a number of groups are drawn at random and updated. pSel is a vector containing relative probabilities +#' for updating the respective number of groups. E.g. To update one group at a time pSel = 1. +#' For updating one or two groups with the same probability pSel = c(1,1). By default all numbers +#' have the same probability. +#' The same principle is used for pGroup. Here the user can influence the probability of each group +#' to be updated. By default all groups have the same probability. +#' Finally, "groupStart" defines the starting point of the groupUpdate and "groupIntervall" - the interval +#' in which the groups are evaluated. +DE <- function(bayesianSetup, + settings = list( + startValue = NULL, + iterations = 10000, + f = -2.38, + burnin = 0, + thin = 1, + eps = 0, + consoleUpdates = 100, + blockUpdate = list("none", k = NULL, h = NULL, pSel = NULL, pGroup = NULL, + groupStart = 1000, groupIntervall = 1000), + currentChain = 1, + message = TRUE + ) + ){ + + if("bayesianOutput" %in% class(bayesianSetup)){ + restart <- TRUE + } else restart <- FALSE + + + if(restart){ + if(is.null(settings)) settings <- bayesianSetup$settings + else settings <- applySettingsDefault(settings = settings, sampler = "DE") + + }else{ + # If nothing provided use default settings + settings <- applySettingsDefault(settings = settings, sampler = "DE") + } + + if(!restart){ + setup <- bayesianSetup + }else{ + setup <- bayesianSetup$setup + } + + + setup <- checkBayesianSetup(setup, parallel = settings$parallel) # calling parallel will check if requested parallelization in settings is provided by the BayesianSetup + if(is.null(settings$parallel)) settings$parallel = setup$parallel # checking back - if no parallelization is provided, we use the parallelization in the BayesianSetup. We could also set parallel = F, but I feel it makes more sense to use the Bayesiansetup as default + + if(!restart){ + if(is.null(settings$startValue)){ + parLen = length(bayesianSetup$prior$sampler(1)) + X = bayesianSetup$prior$sampler(3 * parLen) + } + if(is.function(settings$startValue)){ + X = settings$startValue() + } + if(class(settings$startValue)[1] == "numeric"){ + X = bayesianSetup$prior$sampler(settings$startValue) + } + if(is.matrix(settings$startValue)) X <- settings$startValue + }else{ + X <- bayesianSetup$X + } + + # X = startValue + if (!is.matrix(X)) stop("wrong starting values") + + FUN = setup$posterior$density + + ## Initialize blockUpdate parameters and settings + blockdefault <- list("none", k = NULL, h = NULL, pSel = NULL, pGroup = NULL, + groupStart = 1000, groupIntervall = 1000) + + if(!is.null(settings$blockUpdate)){ + blockUpdate <- modifyList(blockdefault, settings$blockUpdate) + blockUpdate[[1]] <- settings$blockUpdate[[1]] # to catch first argument + if(blockUpdate[[1]] == "none"){ + blockUpdateType <- "none" + blocks = FALSE + BlockStart = FALSE + }else{ + groupStart <- blockUpdate$groupStart + groupIntervall <- blockUpdate$groupIntervall + blockUpdateType = blockUpdate[[1]] + blocks = TRUE + ## Initialize BlockStart + BlockStart = FALSE + Bcount = 0 + } + }else{ + blockUpdateType <- "none" + blocks = FALSE + BlockStart = FALSE + } + + + + Npar <- ncol(X) + Npop <- nrow(X) + burnin <- settings$burnin/Npop + n.iter <- ceiling(settings$iterations/Npop) + + if (n.iter < 2) stop ("The total number of iterations must be greater than the number of parameters to fit times 3.") + + lChain <- ceiling((n.iter - burnin)/settings$thin)+1 + #pChain <- array(NA, dim=c(n.iter*Npop, Npar+3)) + + pChain <- array(NA, dim=c(lChain, Npar+3, Npop)) + + + colnames(pChain) <- c(setup$names, "LP", "LL", "LPr") + + counter <- 1 + iseq <- 1:Npop + + + F2 = abs(settings$f)/sqrt(2*Npar) + if (settings$f>0) F1 = F2 else F1 = 0.98 + + logfitness_X <- FUN(X, returnAll = T) + + # Write first values in chain + pChain[1,,] <- t(cbind(X,logfitness_X)) + + # Print adjusted iterations + # cat("Iterations adjusted to", n.iter*Npop,"to fit settings", "\n") + + #### + eps <- settings$eps + currentChain <- settings$currentChain + iterations <- settings$iterations + + for (iter in 2:n.iter) { + + if (iter%%10) F_cur = F2 else F_cur = F1 + + + if(blocks){ + ### Update the groups. + if(iter == groupStart+ Bcount*groupIntervall){ + blockSettings <- updateGroups(chain = pChain[1:counter,, ], blockUpdate) + BlockStart <- TRUE + Bcount <- Bcount + 1 + } + } + #### + + for (i in iseq){ + # select to random different individuals (and different from i) in rr, a 2-vector + + rr <- sample(iseq[-i], 2, replace = FALSE) + x_prop <- X[i,] + F_cur * (X[rr[1],]-X[rr[2],]) + eps * rnorm(Npar,0,1) + + if(BlockStart){ + # Get the current group and update the proposal accordingly + Member <- getBlock(blockSettings) + x_prop[-Member] <- X[i,-Member] + #### + } + + logfitness_x_prop <- FUN(x_prop, returnAll = T) + if(!is.na(logfitness_x_prop[1] - logfitness_X[i,1])){ # To catch possible error + if ((logfitness_x_prop[1] - logfitness_X[i,1] ) > log(runif(1))){ + X[i,] <- x_prop + logfitness_X[i,] <- logfitness_x_prop + } + } + } #iseq + if ((iter > burnin) && (iter %% settings$thin == 0) ) { # retain sample + counter <- counter+1 + pChain[counter,,] <- t(cbind(X,logfitness_X)) + + } + + if(settings$message){ + if( (iter %% settings$consoleUpdates == 0) | (iter == n.iter)) cat("\r","Running DE-MCMC, chain ", currentChain, + "iteration" ,iter*Npop,"of",n.iter*Npop,". Current logp ", + logfitness_X[,1], + "Please wait!","\r") + flush.console() + } + + } # n.iter + iterationsOld <- 0 + + pChain <- pChain[1:counter,,] + + if(restart){ # Combine chains + newchains <- array(NA, dim = c((counter+nrow(bayesianSetup$chain[[1]])), (Npar+3), Npop)) + + for(i in 1:Npop){ + for(k in 1:(Npar+3)){ + newchains[,k,i] <- c(bayesianSetup$chain[[i]][,k],pChain[,k,i]) + } + } + pChain <- newchains + } + + + + pChain<- coda::as.mcmc.list(lapply(1:Npop,function(i) coda::as.mcmc(pChain[,1:(Npar+3),i]))) + + + list(Draws = pChain, X = as.matrix(X[,1:Npar])) + } diff --git a/BayesianTools/R/mcmcDEzs.R b/BayesianTools/R/mcmcDEzs.R index 570ac4d..f774508 100644 --- a/BayesianTools/R/mcmcDEzs.R +++ b/BayesianTools/R/mcmcDEzs.R @@ -1,398 +1,397 @@ -#TODO: long-term - consider combinining DE and DE.ZS - -#' Differential-Evolution MCMC zs -#' @author Francesco Minunno and Stefan Paul -#' @param bayesianSetup a BayesianSetup with the posterior density function to be sampled from -#' @param settings list with parameter settings -#' @param startValue (optional) either a matrix with start population, a number to define the number of chains that are run or a function that samples a starting population. -#' @param Z starting Z population -#' @param iterations number of iterations to run -#' @param pSnooker probability of Snooker update -#' @param burnin number of iterations treated as burn-in. These iterations are not recorded in the chain. -#' @param thin thinning parameter. Determines the interval in which values are recorded. -#' @param eps small number to avoid singularity -#' @param f scaling factor for gamma -#' @param parallel logical, determines weather parallel computing should be attempted (see details) -#' @param pGamma1 probability determining the frequency with which the scaling is set to 1 (allows jumps between modes) -#' @param eps.mult random term (multiplicative error) -#' @param eps.add random term -#' @param blockUpdate list determining whether parameters should be updated in blocks. For possible settings see Details. -#' @param message logical, specifies whether to print the progress of the sampler. -#' @references ter Braak C. J. F., and Vrugt J. A. (2008). Differential Evolution Markov Chain with snooker updater and fewer chains. Statistics and Computing http://dx.doi.org/10.1007/s11222-008-9104-9 -#' @export -#' @example /inst/examples/DEfamilyHelp.R -#' @seealso \code{\link{DE}} -#' @details For parallel computing, the likelihood density in the bayesianSetup needs to be parallelized, i.e., it needs to be able to operate on a matrix of proposals -#' -#' For blockUpdate the first element in the list determines the type of blocking. -#' Possible choices are -#' \itemize{ -#' \item{"none"}{ (default), no blocking of parameters} -#' \item{"correlation"} { blocking based on correlation of parameters. Using h or k (see below)} -#' \item{"random"} { random blocking. Using k (see below)} -#' \item{"user"} { user defined groups. Using groups (see below)} -#' } -#' Further, seven parameters can be specified. "k" defines the number of groups, "h" the strength -#' of the correlation used to group parameter and "groups" is used for user defined groups. -#' "groups" is a vector containing the group number for each parameter. E.g. for three parameters -#' with the first two in one group, "groups" would be c(1,1,2). -#' Moreover, pSel and pGroup can be used to influence the choice of groups. In the sampling process -#' a number of groups is drawn at random and updated. pSel is a vector containing relative probabilities -#' for updating the respective number of groups. E.g. To update one group at a time pSel = 1. -#' For updating one or two groups with the same probability pSel = c(1,1). By default all numbers -#' have the same probability. -#' The same principle is used in pGroup. Here, the user can influence the probability of each group -#' to be updated. By default all groups have the same probability. -#' Finally, "groupStart" defines the starting point of the groupUpdate and "groupIntervall" - the interval -#' in which the groups are evaluated. -#' -DEzs <- function(bayesianSetup, - settings = list(iterations=10000, - Z = NULL, - startValue = NULL, - pSnooker = 0.1, - burnin = 0, - thin = 1, - f = 2.38, - eps = 0, - parallel = NULL, - pGamma1 = 0.1, - eps.mult =0.2, - eps.add = 0, - consoleUpdates = 100, - zUpdateFrequency = 1, - currentChain = 1, - blockUpdate = list("none", k = NULL, h = NULL, pSel = NULL, pGroup = NULL, - groupStart = 1000, groupIntervall = 1000) - ,message = TRUE)) - { - - -# X = startValue - - - if("bayesianOutput" %in% class(bayesianSetup)){ - restart <- TRUE - } else restart <- FALSE - - - if(restart){ - if(is.null(settings)) settings <- bayesianSetup$settings - else settings <- applySettingsDefault(settings = settings, sampler = "DEzs") - }else{ - # If nothing provided use default settings - settings <- applySettingsDefault(settings = settings, sampler = "DEzs") - } - - if(!restart){ - setup <- bayesianSetup - } else setup <- bayesianSetup$setup - - setup <- checkBayesianSetup(setup, parallel = settings$parallel) # calling parallel will check if requested parallelization in settings is provided by the BayesianSetup - if(is.null(settings$parallel)) settings$parallel = setup$parallel # checking back - if no parallelization is provided, we use the parallelization in the BayesianSetup. We could also set parallel = F, but I feel it makes more sense to use the Bayesiansetup as default - - if(!restart){ - if(is.null(settings$startValue)){ - parLen = length(bayesianSetup$prior$sampler(1)) - X = bayesianSetup$prior$sampler(3) - } - if(is.function(settings$startValue)){ - X = settings$startValue() - } - if(class(settings$startValue)[1] == "numeric"){ - X = bayesianSetup$prior$sampler(settings$startValue) - } - - if(is.matrix(settings$startValue)) X <- settings$startValue - - if(is.null(settings$Z)){ - parLen = length(bayesianSetup$prior$sampler(1)) - Z = bayesianSetup$prior$sampler(parLen * 10) - } - if(is.function(settings$Z)){ - Z = settings$Z() - } - - if(class(settings$Z)[1] == "numeric"){ - Z = bayesianSetup$prior$sampler(settings$Z) - } - if(is.matrix(settings$Z)) Z <- settings$Z - - }else{ - X <- bayesianSetup$X - Z <- bayesianSetup$Z - if(is.vector(Z)) Z = as.matrix(Z) - } - - - if (! is.matrix(X)) stop("wrong starting values") - if (! is.matrix(Z)) stop("wrong Z values") - - - FUN = setup$posterior$density - - if(is.null(settings$parallel)) parallel = setup$parallel else parallel <- settings$parallel - if(parallel == T & setup$parallel == F) stop("parallel = T requested in DEzs but BayesianSetup does not support parallelization. See help of BayesianSetup on how to enable parallelization") - - ## Initialize blockUpdate parameters and settings - blockdefault <- list("none", k = NULL, h = NULL, pSel = NULL, pGroup = NULL, - groupStart = 1000, groupIntervall = 1000) - - if(!is.null(settings$blockUpdate)){ - blockUpdate <- modifyList(blockdefault, settings$blockUpdate) - blockUpdate[[1]] <- settings$blockUpdate[[1]] # to catch first argument - if(blockUpdate[[1]] == "none"){ - blockUpdateType <- "none" - blocks = FALSE - BlockStart = FALSE - }else{ - groupStart <- blockUpdate$groupStart - groupIntervall <- blockUpdate$groupIntervall - blockUpdateType = blockUpdate[[1]] - blocks = TRUE - ## Initialize BlockStart - BlockStart = FALSE - Bcount = 0 - } - }else{ - blockUpdateType <- "none" - blocks = FALSE - BlockStart = FALSE - } - - - # Initialize parameter values. Because they are called in - # the loop this saves time in comparison to referencing them - # every iteration using settings$... - iterations <- settings$iterations - consoleUpdates <- settings$currentChain - currentChain <- settings$currentChain - pSnooker <- settings$pSnooker - zUpdateFrequency <- settings$zUpdateFrequency - pGamma1 <- settings$pGamma1 - eps.mult <- settings$eps.mult - eps.add <- settings$eps.add - - # Initialization of previous chain length (= 0 if restart = F) - lChainOld <- 0 - - Npar <- ncol(X) - Npar12 <- (Npar - 1)/2 # factor for Metropolis ratio DE Snooker update - - # M0 is initial population size of Z is the size of Z, it's the same number, only kept 2 to stay consistent with the ter Brakk & Vrugt 2008 - M = M0 = nrow(Z) - Npop <- nrow(X) - - F2 = settings$f/sqrt(2*Npar) - F1 = 1.0 - rr = NULL - r_extra = 0 - - #if(burnin != 0) stop("burnin option is currently not implemented") - - burnin <- settings$burnin/Npop - n.iter <- ceiling(settings$iterations/Npop) - if (n.iter < 2) stop ("The total number of iterations must be greater than 3") - - lChain <- ceiling((n.iter - burnin)/settings$thin)+1 - - pChain <- array(NA, dim=c(lChain, Npar+3, Npop)) - - colnames(pChain) <- c(setup$names, "LP", "LL", "LPr") - - - # Print adjusted iterations -# cat("Iterations adjusted to", n.iter*Npop,"to fit settings", "\n") - - - # assign memory for Z - Zold <- Z - Z <- matrix(NA, nrow= M0 + floor((n.iter-1) /zUpdateFrequency) * Npop, ncol=Npar) - - Z[1:M,] <- Zold - - - counter <- 1 - counterZ <- 0 - - # accept.prob <- 0 - logfitness_X <- FUN(X, returnAll = T) - - - # Write first values in chain - pChain[1,,] <- t(cbind(X,logfitness_X)) - - - - for (iter in 2:n.iter) { - f <- ifelse(iter%%10 == 0, 0.98, F1) - #accept <- 0 - - - if(blocks){ - ### Update the groups. - if(iter == groupStart+ Bcount*groupIntervall){ - blockSettings <- updateGroups(chain = pChain[1:counter,, ], blockUpdate) - BlockStart <- TRUE - Bcount <- Bcount + 1 - } - } - - - if(parallel == TRUE | parallel == "external"){ - x_prop <- matrix(NA, nrow= Npop, ncol=Npar) - r_extra <- numeric(Npop) - - - for(i in 1:Npop){ - # select to random different individuals (and different from i) in rr, a 2-vector - rr <- sample.int(M, 3, replace = FALSE) - if(runif(1) < pSnooker) { - z <- Z[rr[3],] - x_z <- X[i,] - z - D2 <- max(sum(x_z*x_z), 1.0e-300) - projdiff <- sum((Z[rr[1],] -Z[rr[2],]) * x_z)/D2 # inner_product of difference with x_z / squared norm x_z - gamma_snooker <- runif(1, min=1.2,max=2.2) - - x_prop[i,] <- X[i,] + gamma_snooker * projdiff * x_z - x_z <- x_prop[i,] - z - D2prop <- max(sum(x_z*x_z), 1.0e-300) - r_extra[i] <- Npar12 * (log(D2prop) - log(D2)) - - } else { - if ( runif(1)< pGamma1 ) { gamma_par = F1 # to be able to jump between modes - } else { - gamma_par = F2 * runif(Npar, min=1-eps.mult, max=1+eps.mult) # multiplicative error to be applied to the difference - # gamma_par = F2 - } - rr = sample.int(M, 2, replace = FALSE) - if (eps.add ==0) { # avoid generating normal random variates if possible - x_prop[i,] = X[i,] + gamma_par * (Z[rr[1],]-Z[rr[2],]) - } else { - x_prop[i,] = X[i,] + gamma_par * (Z[rr[1],]-Z[rr[2],]) + eps.add*rnorm(Npar,0,1) - } - r_extra = rep(0, Npop) - } - } - # end proposal creation - - if(BlockStart){ - # Get the current group and update the proposal accordingly - Member <- getBlock(blockSettings) - x_prop[,-Member] <- X[,-Member] - #### - } - - - # run proposals - logfitness_x_prop <- FUN(x_prop, returnAll = T) - - # evaluate acceptance - for(i in 1:Npop){ - if(!is.na(logfitness_x_prop[i,1] - logfitness_X[i,1])){ - if ((logfitness_x_prop[i,1] - logfitness_X[i,1] + r_extra[i]) > log(runif(1))){ - # accept <- accept + 1 - X[i,] <- x_prop[i,] - logfitness_X[i,] <- logfitness_x_prop[i,] - } - } - } - - } else{ - # if not parallel - - for (i in 1:Npop){ - # select to random different individuals (and different from i) in rr, a 2-vector - rr <- sample.int(M, 3, replace = FALSE) - if(runif(1) < pSnooker) { - z <- Z[rr[3],] - x_z <- X[i,] - z - D2 <- max(sum(x_z*x_z), 1.0e-300) - projdiff <- sum((Z[rr[1],] -Z[rr[2],]) * x_z)/D2 # inner_product of difference with x_z / squared norm x_z - gamma_snooker <- runif(1, min=1.2,max=2.2) - x_prop <- X[i,] + gamma_snooker * projdiff * x_z - x_z <- x_prop - z - D2prop <- max(sum(x_z*x_z), 1.0e-300) - r_extra <- Npar12 * (log(D2prop) - log(D2)) - } else { - - if ( runif(1)< pGamma1 ) { gamma_par = F1 # to be able to jump between modes - } else { - gamma_par = F2 * runif(Npar, min=1-eps.mult, max=1+eps.mult) # multiplicative error to be applied to the difference - # gamma_par = F2 - } - rr = sample.int(M, 2, replace = FALSE) - if (eps.add ==0) { # avoid generating normal random variates if possible - x_prop = X[i,] + gamma_par * (Z[rr[1],]-Z[rr[2],]) } else { - x_prop = X[i,] + gamma_par * (Z[rr[1],]-Z[rr[2],]) + eps.add*rnorm(Npar,0,1) - } - r_extra = 0 - - } - if(BlockStart){ - # Get the current group and update the proposal accordingly - Member <- getBlock(blockSettings) - x_prop[-Member] <- X[i,-Member] - #### - } - - - # evaluate proposal - can this be mixed with the parallel above? - logfitness_x_prop <- FUN(x_prop, returnAll = T) - - # evaluate acceptance - if(!is.na(logfitness_x_prop[1] - logfitness_X[i,1])){ - if ((logfitness_x_prop[1] - logfitness_X[i,1] + r_extra) > log(runif(1))){ - # accept <- accept + 1 - X[i,] <- x_prop - logfitness_X[i,] <- logfitness_x_prop - } - } - } # for Npop - - - } - - if ((iter > burnin) && (iter %% settings$thin == 0) ) { # retain sample - counter <- counter+1 - pChain[counter,,] <- t(cbind(X,logfitness_X)) - - } - - if (iter%%zUpdateFrequency == 0) { # update history - - Z[( M0 + (counterZ*Npop) + 1 ):( M0 + (counterZ+1)*Npop),] <- X - counterZ <- counterZ +1 - M <- M + Npop - } - # Console update - - if(settings$message){ - if( (iter %% settings$consoleUpdates == 0) | (iter == n.iter)) cat("\r","Running DEzs-MCMC, chain ", currentChain, - "iteration" ,iter*Npop,"of",n.iter*Npop,". Current logp ", - logfitness_X[,1],". Please wait!","\r") - flush.console() - } - } # n.iter - - - pChain <- pChain[1:counter,,] - - if(restart){ # Combine chains - newchains <- array(NA, dim = c((counter+nrow(bayesianSetup$chain[[1]])), (Npar+3), Npop)) - - for(i in 1:Npop){ - for(k in 1:(Npar+3)){ - newchains[,k,i] <- c(bayesianSetup$chain[[i]][,k],pChain[,k,i]) - } - } - pChain <- newchains - } - - - pChain<- coda::as.mcmc.list(lapply(1:Npop,function(i) coda::as.mcmc(pChain[,1:(Npar+3),i]))) - - - - list(Draws = pChain, X = as.matrix(X[,1:Npar]), Z = Z) -} +#TODO: long-term - consider combinining DE and DE.ZS + +#' Differential-Evolution MCMC zs +#' @author Francesco Minunno and Stefan Paul +#' @param bayesianSetup a BayesianSetup with the posterior density function to be sampled from +#' @param settings list with parameter settings +#' @param startValue (optional) either a matrix with start population, a number to define the number of chains that are run or a function that samples a starting population. +#' @param Z starting Z population +#' @param iterations number of iterations to run +#' @param pSnooker probability of Snooker update +#' @param burnin number of iterations treated as burn-in. These iterations are not recorded in the chain. +#' @param thin thinning parameter. Determines the interval in which values are recorded. +#' @param eps small number to avoid singularity +#' @param f scaling factor for gamma +#' @param parallel logical, determines weather parallel computing should be attempted (see details) +#' @param pGamma1 probability determining the frequency with which the scaling is set to 1 (allows jumps between modes) +#' @param eps.mult random term (multiplicative error) +#' @param eps.add random term +#' @param blockUpdate list determining whether parameters should be updated in blocks. For possible settings see Details. +#' @param message logical, specifies whether to print the progress of the sampler. +#' @references ter Braak C. J. F., and Vrugt J. A. (2008). Differential Evolution Markov Chain with snooker updater and fewer chains. Statistics and Computing http://dx.doi.org/10.1007/s11222-008-9104-9 +#' @export +#' @example /inst/examples/DEfamilyHelp.R +#' @seealso \code{\link{DE}} +#' @details For parallel computing, the likelihood density in the bayesianSetup needs to be parallelized, i.e., it needs to be able to operate on a matrix of proposals +#' +#' For blockUpdate the first element in the list determines the type of blocking. +#' Possible choices are +#' \itemize{ +#' \item{"none"}{ (default), no blocking of parameters} +#' \item{"correlation"} { blocking based on correlation of parameters. Using h or k (see below)} +#' \item{"random"} { random blocking. Using k (see below)} +#' \item{"user"} { user defined groups. Using groups (see below)} +#' } +#' Further, seven parameters can be specified. "k" defines the number of groups, "h" the strength +#' of the correlation used to group parameter and "groups" is used for user defined groups. +#' "groups" is a vector containing the group number for each parameter. E.g. for three parameters +#' with the first two in one group, "groups" would be c(1,1,2). +#' Moreover, pSel and pGroup can be used to influence the choice of groups. In the sampling process +#' a number of groups is drawn at random and updated. pSel is a vector containing relative probabilities +#' for updating the respective number of groups. E.g. To update one group at a time pSel = 1. +#' For updating one or two groups with the same probability pSel = c(1,1). By default all numbers +#' have the same probability. +#' The same principle is used in pGroup. Here, the user can influence the probability of each group +#' to be updated. By default all groups have the same probability. +#' Finally, "groupStart" defines the starting point of the groupUpdate and "groupIntervall" - the interval +#' in which the groups are evaluated. +DEzs <- function(bayesianSetup, + settings = list(iterations=10000, + Z = NULL, + startValue = NULL, + pSnooker = 0.1, + burnin = 0, + thin = 1, + f = 2.38, + eps = 0, + parallel = NULL, + pGamma1 = 0.1, + eps.mult =0.2, + eps.add = 0, + consoleUpdates = 100, + zUpdateFrequency = 1, + currentChain = 1, + blockUpdate = list("none", k = NULL, h = NULL, pSel = NULL, pGroup = NULL, + groupStart = 1000, groupIntervall = 1000) + ,message = TRUE)) + { + + +# X = startValue + + + if("bayesianOutput" %in% class(bayesianSetup)){ + restart <- TRUE + } else restart <- FALSE + + + if(restart){ + if(is.null(settings)) settings <- bayesianSetup$settings + else settings <- applySettingsDefault(settings = settings, sampler = "DEzs") + }else{ + # If nothing provided use default settings + settings <- applySettingsDefault(settings = settings, sampler = "DEzs") + } + + if(!restart){ + setup <- bayesianSetup + } else setup <- bayesianSetup$setup + + setup <- checkBayesianSetup(setup, parallel = settings$parallel) # calling parallel will check if requested parallelization in settings is provided by the BayesianSetup + if(is.null(settings$parallel)) settings$parallel = setup$parallel # checking back - if no parallelization is provided, we use the parallelization in the BayesianSetup. We could also set parallel = F, but I feel it makes more sense to use the Bayesiansetup as default + + if(!restart){ + if(is.null(settings$startValue)){ + parLen = length(bayesianSetup$prior$sampler(1)) + X = bayesianSetup$prior$sampler(3) + } + if(is.function(settings$startValue)){ + X = settings$startValue() + } + if(class(settings$startValue)[1] == "numeric"){ + X = bayesianSetup$prior$sampler(settings$startValue) + } + + if(is.matrix(settings$startValue)) X <- settings$startValue + + if(is.null(settings$Z)){ + parLen = length(bayesianSetup$prior$sampler(1)) + Z = bayesianSetup$prior$sampler(parLen * 10) + } + if(is.function(settings$Z)){ + Z = settings$Z() + } + + if(class(settings$Z)[1] == "numeric"){ + Z = bayesianSetup$prior$sampler(settings$Z) + } + if(is.matrix(settings$Z)) Z <- settings$Z + + }else{ + X <- bayesianSetup$X + Z <- bayesianSetup$Z + if(is.vector(Z)) Z = as.matrix(Z) + } + + + if (! is.matrix(X)) stop("wrong starting values") + if (! is.matrix(Z)) stop("wrong Z values") + + + FUN = setup$posterior$density + + if(is.null(settings$parallel)) parallel = setup$parallel else parallel <- settings$parallel + if(parallel == T & setup$parallel == F) stop("parallel = T requested in DEzs but BayesianSetup does not support parallelization. See help of BayesianSetup on how to enable parallelization") + + ## Initialize blockUpdate parameters and settings + blockdefault <- list("none", k = NULL, h = NULL, pSel = NULL, pGroup = NULL, + groupStart = 1000, groupIntervall = 1000) + + if(!is.null(settings$blockUpdate)){ + blockUpdate <- modifyList(blockdefault, settings$blockUpdate) + blockUpdate[[1]] <- settings$blockUpdate[[1]] # to catch first argument + if(blockUpdate[[1]] == "none"){ + blockUpdateType <- "none" + blocks = FALSE + BlockStart = FALSE + }else{ + groupStart <- blockUpdate$groupStart + groupIntervall <- blockUpdate$groupIntervall + blockUpdateType = blockUpdate[[1]] + blocks = TRUE + ## Initialize BlockStart + BlockStart = FALSE + Bcount = 0 + } + }else{ + blockUpdateType <- "none" + blocks = FALSE + BlockStart = FALSE + } + + + # Initialize parameter values. Because they are called in + # the loop this saves time in comparison to referencing them + # every iteration using settings$... + iterations <- settings$iterations + consoleUpdates <- settings$currentChain + currentChain <- settings$currentChain + pSnooker <- settings$pSnooker + zUpdateFrequency <- settings$zUpdateFrequency + pGamma1 <- settings$pGamma1 + eps.mult <- settings$eps.mult + eps.add <- settings$eps.add + + # Initialization of previous chain length (= 0 if restart = F) + lChainOld <- 0 + + Npar <- ncol(X) + Npar12 <- (Npar - 1)/2 # factor for Metropolis ratio DE Snooker update + + # M0 is initial population size of Z is the size of Z, it's the same number, only kept 2 to stay consistent with the ter Brakk & Vrugt 2008 + M = M0 = nrow(Z) + Npop <- nrow(X) + + F2 = settings$f/sqrt(2*Npar) + F1 = 1.0 + rr = NULL + r_extra = 0 + + #if(burnin != 0) stop("burnin option is currently not implemented") + + burnin <- settings$burnin/Npop + n.iter <- ceiling(settings$iterations/Npop) + if (n.iter < 2) stop ("The total number of iterations must be greater than 3") + + lChain <- ceiling((n.iter - burnin)/settings$thin)+1 + + pChain <- array(NA, dim=c(lChain, Npar+3, Npop)) + + colnames(pChain) <- c(setup$names, "LP", "LL", "LPr") + + + # Print adjusted iterations +# cat("Iterations adjusted to", n.iter*Npop,"to fit settings", "\n") + + + # assign memory for Z + Zold <- Z + Z <- matrix(NA, nrow= M0 + floor((n.iter-1) /zUpdateFrequency) * Npop, ncol=Npar) + + Z[1:M,] <- Zold + + + counter <- 1 + counterZ <- 0 + + # accept.prob <- 0 + logfitness_X <- FUN(X, returnAll = T) + + + # Write first values in chain + pChain[1,,] <- t(cbind(X,logfitness_X)) + + + + for (iter in 2:n.iter) { + f <- ifelse(iter%%10 == 0, 0.98, F1) + #accept <- 0 + + + if(blocks){ + ### Update the groups. + if(iter == groupStart+ Bcount*groupIntervall){ + blockSettings <- updateGroups(chain = pChain[1:counter,, ], blockUpdate) + BlockStart <- TRUE + Bcount <- Bcount + 1 + } + } + + + if(parallel == TRUE | parallel == "external"){ + x_prop <- matrix(NA, nrow= Npop, ncol=Npar) + r_extra <- numeric(Npop) + + + for(i in 1:Npop){ + # select to random different individuals (and different from i) in rr, a 2-vector + rr <- sample.int(M, 3, replace = FALSE) + if(runif(1) < pSnooker) { + z <- Z[rr[3],] + x_z <- X[i,] - z + D2 <- max(sum(x_z*x_z), 1.0e-300) + projdiff <- sum((Z[rr[1],] -Z[rr[2],]) * x_z)/D2 # inner_product of difference with x_z / squared norm x_z + gamma_snooker <- runif(1, min=1.2,max=2.2) + + x_prop[i,] <- X[i,] + gamma_snooker * projdiff * x_z + x_z <- x_prop[i,] - z + D2prop <- max(sum(x_z*x_z), 1.0e-300) + r_extra[i] <- Npar12 * (log(D2prop) - log(D2)) + + } else { + if ( runif(1)< pGamma1 ) { gamma_par = F1 # to be able to jump between modes + } else { + gamma_par = F2 * runif(Npar, min=1-eps.mult, max=1+eps.mult) # multiplicative error to be applied to the difference + # gamma_par = F2 + } + rr = sample.int(M, 2, replace = FALSE) + if (eps.add ==0) { # avoid generating normal random variates if possible + x_prop[i,] = X[i,] + gamma_par * (Z[rr[1],]-Z[rr[2],]) + } else { + x_prop[i,] = X[i,] + gamma_par * (Z[rr[1],]-Z[rr[2],]) + eps.add*rnorm(Npar,0,1) + } + r_extra = rep(0, Npop) + } + } + # end proposal creation + + if(BlockStart){ + # Get the current group and update the proposal accordingly + Member <- getBlock(blockSettings) + x_prop[,-Member] <- X[,-Member] + #### + } + + + # run proposals + logfitness_x_prop <- FUN(x_prop, returnAll = T) + + # evaluate acceptance + for(i in 1:Npop){ + if(!is.na(logfitness_x_prop[i,1] - logfitness_X[i,1])){ + if ((logfitness_x_prop[i,1] - logfitness_X[i,1] + r_extra[i]) > log(runif(1))){ + # accept <- accept + 1 + X[i,] <- x_prop[i,] + logfitness_X[i,] <- logfitness_x_prop[i,] + } + } + } + + } else{ + # if not parallel + + for (i in 1:Npop){ + # select to random different individuals (and different from i) in rr, a 2-vector + rr <- sample.int(M, 3, replace = FALSE) + if(runif(1) < pSnooker) { + z <- Z[rr[3],] + x_z <- X[i,] - z + D2 <- max(sum(x_z*x_z), 1.0e-300) + projdiff <- sum((Z[rr[1],] -Z[rr[2],]) * x_z)/D2 # inner_product of difference with x_z / squared norm x_z + gamma_snooker <- runif(1, min=1.2,max=2.2) + x_prop <- X[i,] + gamma_snooker * projdiff * x_z + x_z <- x_prop - z + D2prop <- max(sum(x_z*x_z), 1.0e-300) + r_extra <- Npar12 * (log(D2prop) - log(D2)) + } else { + + if ( runif(1)< pGamma1 ) { gamma_par = F1 # to be able to jump between modes + } else { + gamma_par = F2 * runif(Npar, min=1-eps.mult, max=1+eps.mult) # multiplicative error to be applied to the difference + # gamma_par = F2 + } + rr = sample.int(M, 2, replace = FALSE) + if (eps.add ==0) { # avoid generating normal random variates if possible + x_prop = X[i,] + gamma_par * (Z[rr[1],]-Z[rr[2],]) } else { + x_prop = X[i,] + gamma_par * (Z[rr[1],]-Z[rr[2],]) + eps.add*rnorm(Npar,0,1) + } + r_extra = 0 + + } + if(BlockStart){ + # Get the current group and update the proposal accordingly + Member <- getBlock(blockSettings) + x_prop[-Member] <- X[i,-Member] + #### + } + + + # evaluate proposal - can this be mixed with the parallel above? + logfitness_x_prop <- FUN(x_prop, returnAll = T) + + # evaluate acceptance + if(!is.na(logfitness_x_prop[1] - logfitness_X[i,1])){ + if ((logfitness_x_prop[1] - logfitness_X[i,1] + r_extra) > log(runif(1))){ + # accept <- accept + 1 + X[i,] <- x_prop + logfitness_X[i,] <- logfitness_x_prop + } + } + } # for Npop + + + } + + if ((iter > burnin) && (iter %% settings$thin == 0) ) { # retain sample + counter <- counter+1 + pChain[counter,,] <- t(cbind(X,logfitness_X)) + + } + + if (iter%%zUpdateFrequency == 0) { # update history + + Z[( M0 + (counterZ*Npop) + 1 ):( M0 + (counterZ+1)*Npop),] <- X + counterZ <- counterZ +1 + M <- M + Npop + } + # Console update + + if(settings$message){ + if( (iter %% settings$consoleUpdates == 0) | (iter == n.iter)) cat("\r","Running DEzs-MCMC, chain ", currentChain, + "iteration" ,iter*Npop,"of",n.iter*Npop,". Current logp ", + logfitness_X[,1],". Please wait!","\r") + flush.console() + } + } # n.iter + + + pChain <- pChain[1:counter,,] + + if(restart){ # Combine chains + newchains <- array(NA, dim = c((counter+nrow(bayesianSetup$chain[[1]])), (Npar+3), Npop)) + + for(i in 1:Npop){ + for(k in 1:(Npar+3)){ + newchains[,k,i] <- c(bayesianSetup$chain[[i]][,k],pChain[,k,i]) + } + } + pChain <- newchains + } + + + pChain<- coda::as.mcmc.list(lapply(1:Npop,function(i) coda::as.mcmc(pChain[,1:(Npar+3),i]))) + + + + list(Draws = pChain, X = as.matrix(X[,1:Npar]), Z = Z) +} diff --git a/BayesianTools/R/mcmcDREAM.R b/BayesianTools/R/mcmcDREAM.R index b2504f2..a55b7bb 100644 --- a/BayesianTools/R/mcmcDREAM.R +++ b/BayesianTools/R/mcmcDREAM.R @@ -1,353 +1,352 @@ -### DREAM algorithm - -#' DREAM -#' @author Stefan Paul -#' @param bayesianSetup object of class 'bayesianSetup' or 'bayesianOuput'. -#' @param settings list with parameter values -#' @param iterations number of model evaluations -#' @param nCR parameter determining the number of cross-over proposals. If nCR = 1 all parameters are updated jointly. -#' @param updateInterval determines the interval for the pCR update -#' @param gamma Kurtosis parameter Bayesian Inference Scheme -#' @param eps Ergodicity term -#' @param e Ergodicity term -#' @param pCRupdate logical, if T, crossover probabilities will be updated -#' @param burnin number of iterations treated as burn-in. These iterations are not recorded in the chain. -#' @param thin thinning parameter. Determines the interval in which values are recorded. -#' @param adaptation number or percentage of samples that are used for the adaptation in DREAM (see Details). -#' @param DEpairs number of pairs used to generate proposal -#' @param startValue either a matrix containing the start values (see details), an integer to define the number of chains to be run, a function to sample the start values or NUll - in which case the values are sampled from the prior. -#' @param consoleUpdates interval at which the sampling progress is printed to the console -#' @param message logical, determines whether the sampler's progress should be printed -#' @return mcmc.object containing the following elements: chains, X, pCR -#' @references Vrugt, Jasper A., et al. "Accelerating Markov chain Monte Carlo simulation by differential evolution with self-adaptive randomized subspace sampling." International Journal of Nonlinear Sciences and Numerical Simulation 10.3 (2009): 273-290. -#' @details Instead of a bayesianSetup, the function can take the output of a previous run to restart the sampler -#' from the last iteration. Due to the sampler's internal structure you can only use the output -#' of DREAM. -#' If you provide a matrix with start values, the number of rows determines the number of chains that will be run. -#' The number of coloumns must be equivalent to the number of parameters in your bayesianSetup. \cr\cr -#' There are several small differences in the algorithm presented here compared to the original paper by Vrugt et al. (2009). Mainly -#' The algorithm implemented here does not have an automatic stopping criterion. Hence, it will -#' always run the number of iterations specified by the user. Also, convergence is not -#' monitored and left to the user. This can easily be done with coda::gelman.diag(chain). -#' Furthermore, the delayed rejection step proposed in Vrugt et al. (2009) is not implemented here.\cr\cr -#' -#' During the adaptation phase DREAM is running two mechanisms to enhance the sampler's efficiency. -#' First, the disribution of crossover values is tuned to favor large jumps in the parameter space. -#' The crossover probabilities determine how many parameters are updated simultaneously. -#' Second, outlier chains are replaced as they can largely deteriorate the sampler's performance. -#' However, these steps destroy the detailed balance of the chain. Consequently these parts of the chain -#' should be discarded when summarizing posterior moments. This can be done automatically during the -#' sampling process (i.e. burn-in > adaptation) or subsequently by the user. We chose to distinguish between -#' the burn-in and adaptation phase to allow the user more flexibility in the sampler's settings. -#' -#' -#' @example /inst/examples/DEfamilyHelp.R -#' @seealso \code{\link{DREAMzs}} -#' @export -DREAM <- function(bayesianSetup, settings = list( - iterations = 10000, - nCR = 3, - gamma = NULL, - eps = 0, - e = 5e-2, - pCRupdate = TRUE, - updateInterval = 10, - burnin = 0, - thin = 1, - adaptation = 0.2, - parallel = NULL, - DEpairs = 2, - consoleUpdates = 10, - startValue = NULL, - currentChain = 1, - message = TRUE)) -{ - - if("bayesianOutput" %in% class(bayesianSetup)){ - restart <- TRUE - } else restart <- FALSE - - - if(restart){ - if(is.null(settings)) settings <- bayesianSetup$settings - else settings <- applySettingsDefault(settings = settings, sampler = "DREAM") - - settings$adaptation <- 0 # set adaptation to 0 if restart because it has already been - # applied in chain that is restarted and destroys detailed balance. - - }else{ - # If nothing provided use default settings - settings <- applySettingsDefault(settings = settings, sampler = "DREAM") - } - - if(!restart){ - setup <- bayesianSetup - }else{ - setup <- bayesianSetup$setup - } - - - setup <- checkBayesianSetup(setup, parallel = settings$parallel) # calling parallel will check if requested parallelization in settings is provided by the BayesianSetup - if(is.null(settings$parallel)) settings$parallel = setup$parallel # checking back - if no parallelization is provided, we use the parallelization in the BayesianSetup. We could also set parallel = F, but I feel it makes more sense to use the Bayesiansetup as default - - if(!restart){ - if(is.null(settings$startValue)){ - parLen = length(bayesianSetup$prior$sampler(1)) - X = bayesianSetup$prior$sampler(max(4,2 * parLen)) - } - if(is.function(settings$startValue)){ - X = settings$startValue() - } - if(class(settings$startValue)[1] == "numeric"){ - X = bayesianSetup$prior$sampler(settings$startValue) - } - if(is.matrix(settings$startValue)) X <- settings$startValue - }else{ - X <- bayesianSetup$X - } - - # X = startValue - if (!is.matrix(X)) stop("wrong starting values") - - currentChain = settings$currentChain - - FUN = setup$posterior$density - - pCRupdate <- settings$pCRupdate - nCR <- settings$nCR - Npar <- ncol(X) - Npop <- nrow(X) - - # Check for consistency of DEpairs - if(settings$DEpairs > (Npop-2)) stop("DEpairs to large for number of chains") - - # Set adaptation if percentage is supplied - if(settings$adaptation <1) settings$adaptation <- settings$adaptation*settings$iterations - - # Set number of iterations and initialize chain - n.iter <- ceiling(settings$iterations/Npop) - if (n.iter < 2) stop ("The total number of iterations must be greater than the number of parameters to fit times 2.") - - settings$burnin <- settings$burnin/Npop - lChain <- ceiling((n.iter - settings$burnin)/settings$thin)+1 - pChain <- array(NA, dim=c(lChain, Npar+3, Npop)) - colnames(pChain) <- c(setup$names, "LP", "LL", "LPr") - - # Evaluate start values and write them in the chain - logfitness_X <- FUN(X, returnAll = T) - pChain[1,,] <- t(cbind(X,logfitness_X)) - - # Set counter - counter <- 1 - iseq <- 1:Npop - - # gamma initialization. However gamma is calculated every iteration (see below). - gamma <- 2.38/sqrt(settings$DEpairs*Npar) - - - # delta initialization - delta <- rep(0, settings$nCR) - - funevals <- 0 - - #### pCR update - if(!restart){ - pCR = rep(1/nCR, nCR) - lCR <- rep(0,nCR) - - CR <- matrix(1/nCR, nrow = Npop, ncol = settings$updateInterval) - }else{ - pCR <- bayesianSetup$pCR - CR <- generateCRvalues(pCR, settings, Npop) - - } - - # helper counter for CR value index - counter_update <- 0 - - ## omega initialization - omega <- numeric() - - ## eps and e - eps <- settings$eps - e <- settings$e - - - ##################### Start iterations ############################## - for(iter in 2:n.iter){ - - xOld <- X - counter_update <- counter_update +1 - - for(i in 1:Npop){ - - selectedChains1 <- sample((1:Npop)[-i], settings$DEpairs, replace = FALSE) - selectedChains2 <- numeric(settings$DEpairs) - - # Avoid that selected chains are identical - for(k in 1:settings$DEpairs){ - selectedChains2[k] <- sample((1:Npop)[-c(i,selectedChains1[k],selectedChains2[1:k]) ],1) - } - - - # Get indices of parameters that are updated = indX - rn <- runif(Npar) - indX <- which(rn>(1-CR[i, counter_update])) - - # Make sure at least one dimension is updated - if(length(indX) == 0) indX <- sample(1:Npar, 1) - - # First update proposal - x_prop <- X[i,] - - - # Calculate gamma based on DEpairs and number of dimensions - # that are updated simulateously. - # To jump between modes gamma is set to 1 every fifth iteration. - if(runif(1)>4/5){ - gamma <- 1 - }else{ - gamma <-2.38/sqrt(settings$DEpairs* length(indX)) - } - - - # Replace with new proposal for indX - x_prop[indX] <- X[i,indX] + (1+e)*gamma*(apply(as.matrix(X[selectedChains1,indX]),2,sum)- - apply(as.matrix(X[selectedChains2,indX]),2,sum)) + eps*rnorm(length(indX),0,1) - - - - - logfitness_x_prop <- FUN(x_prop, returnAll = T) - if(!is.na(logfitness_x_prop[1] - logfitness_X[i,1])){ # To catch possible error - if ((logfitness_x_prop[1] - logfitness_X[i,1] ) > log(runif(1))){ - X[i,] <- x_prop - logfitness_X[i,] <- logfitness_x_prop - } - - } - - } #Npop - - - - ## Write values in chain - - if((iter > settings$burnin) && (iter %% settings$thin == 0)){ - counter <- counter+1 - pChain[counter,,] <- t(cbind(X,logfitness_X)) - } - - if(iter < settings$adaptation){ - - if(pCRupdate){ ## Calculate delta, this is (unlike the update) done every iteration - ## Calculate delta - - ## Calculate standard deviation of each dimension of X - sdX <- apply(X[,1:Npar,drop=FALSE],2,sd) - - ## Compute Euclidean distance between old and new X values - delta_Norm <- rowSums(((xOld-X[,1:Npar,drop=FALSE])/sdX)^2) - - ## Now delta can be calculated - for (k in 1:settings$nCR){ # Loop over CR values - - # Find updated chains - ind <- which(abs(CR[,k]-(k/nCR)) < 1e-5) - - ## Add normalized squared distance to the current delta - delta[k] <- delta[k]+sum(delta_Norm[ind]) - #delta[k] <- delta[k]+sum(delta_Norm) - - } - - } - - - if(iter%%settings$updateInterval == 0){ - - - if(pCRupdate){ - # Update CR values - tmp <- AdaptpCR(CR, delta, lCR, settings, Npop) - pCR <- tmp$pCR - lCR <- tmp$lCR - - ## CR values are generated outside loop because they are calculated - # even after adaptation phase. See below! - } - - ## remove outliers - ## TODO include if(remOutliers = TRUE) ?? - for(out in 1:Npop){ - omega[out] <- mean(pChain[((counter/2):counter),Npar+1, out]) - } - - if(NaN %in% omega){ - outlierChain <- NULL # Prevent possible error - }else{ - # Inter quantile range - IQR <- quantile(omega, probs = c(0.25, 0.75)) - - # Determine outlier chains - outlierChain <- which(omega< IQR[1] - 2*(IQR[2]-IQR[1])) - } - - - # Replace with best chain - if(length(outlierChain) > 0){ - best <- which.max(pChain[counter,Npar+1,]) - pChain[counter,,outlierChain] <- pChain[counter,,best] - - } # Remove outliers - - } - } - - - if(iter%%settings$updateInterval == 0){ - counter_update <- 0 # set counter back to zero - CR <- generateCRvalues(pCR, settings, Npop) - - } - - if(settings$message){ - if( (iter %% settings$consoleUpdates == 0) | (iter == n.iter)) cat("\r","Running DREAM-MCMC, chain ", currentChain, - "iteration" ,iter*Npop,"of",n.iter*Npop,". Current logp ", - logfitness_X[,1], - "Please wait!","\r") - flush.console() - } - - - } # niter - - ################ End of iterations ################ - - - iterationsOld <- 0 - - pChain <- pChain[1:counter,,] - - if(restart){ # Combine chains - newchains <- array(NA, dim = c((counter+nrow(bayesianSetup$chain[[1]])), (Npar+3), Npop)) - - for(i in 1:Npop){ - for(k in 1:(Npar+3)){ - newchains[,k,i] <- c(bayesianSetup$chain[[i]][,k],pChain[,k,i]) - } - } - pChain <- newchains - } - - pChain<- coda::as.mcmc.list(lapply(1:Npop,function(i) coda::as.mcmc(pChain[,1:(Npar+3),i]))) - - - return(list(chains = pChain, X = as.matrix(X[,1:Npar]), pCR = pCR)) - -} - - - - - +### DREAM algorithm + +#' DREAM +#' @author Stefan Paul +#' @param bayesianSetup object of class 'bayesianSetup' or 'bayesianOuput'. +#' @param settings list with parameter values +#' @param iterations number of model evaluations +#' @param nCR parameter determining the number of cross-over proposals. If nCR = 1 all parameters are updated jointly. +#' @param updateInterval determines the interval for the pCR update +#' @param gamma Kurtosis parameter Bayesian Inference Scheme +#' @param eps Ergodicity term +#' @param e Ergodicity term +#' @param pCRupdate logical, if T, crossover probabilities will be updated +#' @param burnin number of iterations treated as burn-in. These iterations are not recorded in the chain. +#' @param thin thinning parameter. Determines the interval in which values are recorded. +#' @param adaptation number or percentage of samples that are used for the adaptation in DREAM (see Details). +#' @param DEpairs number of pairs used to generate proposal +#' @param startValue either a matrix containing the start values (see details), an integer to define the number of chains to be run, a function to sample the start values or NUll - in which case the values are sampled from the prior. +#' @param consoleUpdates interval at which the sampling progress is printed to the console +#' @param message logical, determines whether the sampler's progress should be printed +#' @return mcmc.object containing the following elements: chains, X, pCR +#' @references Vrugt, Jasper A., et al. "Accelerating Markov chain Monte Carlo simulation by differential evolution with self-adaptive randomized subspace sampling." International Journal of Nonlinear Sciences and Numerical Simulation 10.3 (2009): 273-290. +#' @details Instead of a bayesianSetup, the function can take the output of a previous run to restart the sampler +#' from the last iteration. Due to the sampler's internal structure you can only use the output +#' of DREAM. +#' If you provide a matrix with start values, the number of rows determines the number of chains that will be run. +#' The number of coloumns must be equivalent to the number of parameters in your bayesianSetup. \cr\cr +#' There are several small differences in the algorithm presented here compared to the original paper by Vrugt et al. (2009). Mainly +#' The algorithm implemented here does not have an automatic stopping criterion. Hence, it will +#' always run the number of iterations specified by the user. Also, convergence is not +#' monitored and left to the user. This can easily be done with coda::gelman.diag(chain). +#' Furthermore, the delayed rejection step proposed in Vrugt et al. (2009) is not implemented here.\cr\cr +#' +#' During the adaptation phase DREAM is running two mechanisms to enhance the sampler's efficiency. +#' First, the disribution of crossover values is tuned to favor large jumps in the parameter space. +#' The crossover probabilities determine how many parameters are updated simultaneously. +#' Second, outlier chains are replaced as they can largely deteriorate the sampler's performance. +#' However, these steps destroy the detailed balance of the chain. Consequently these parts of the chain +#' should be discarded when summarizing posterior moments. This can be done automatically during the +#' sampling process (i.e. burn-in > adaptation) or subsequently by the user. We chose to distinguish between +#' the burn-in and adaptation phase to allow the user more flexibility in the sampler's settings. +#' +#' @example /inst/examples/DEfamilyHelp.R +#' @seealso \code{\link{DREAMzs}} +#' @export +DREAM <- function(bayesianSetup, settings = list( + iterations = 10000, + nCR = 3, + gamma = NULL, + eps = 0, + e = 5e-2, + pCRupdate = TRUE, + updateInterval = 10, + burnin = 0, + thin = 1, + adaptation = 0.2, + parallel = NULL, + DEpairs = 2, + consoleUpdates = 10, + startValue = NULL, + currentChain = 1, + message = TRUE)) +{ + + if("bayesianOutput" %in% class(bayesianSetup)){ + restart <- TRUE + } else restart <- FALSE + + + if(restart){ + if(is.null(settings)) settings <- bayesianSetup$settings + else settings <- applySettingsDefault(settings = settings, sampler = "DREAM") + + settings$adaptation <- 0 # set adaptation to 0 if restart because it has already been + # applied in chain that is restarted and destroys detailed balance. + + }else{ + # If nothing provided use default settings + settings <- applySettingsDefault(settings = settings, sampler = "DREAM") + } + + if(!restart){ + setup <- bayesianSetup + }else{ + setup <- bayesianSetup$setup + } + + + setup <- checkBayesianSetup(setup, parallel = settings$parallel) # calling parallel will check if requested parallelization in settings is provided by the BayesianSetup + if(is.null(settings$parallel)) settings$parallel = setup$parallel # checking back - if no parallelization is provided, we use the parallelization in the BayesianSetup. We could also set parallel = F, but I feel it makes more sense to use the Bayesiansetup as default + + if(!restart){ + if(is.null(settings$startValue)){ + parLen = length(bayesianSetup$prior$sampler(1)) + X = bayesianSetup$prior$sampler(max(4,2 * parLen)) + } + if(is.function(settings$startValue)){ + X = settings$startValue() + } + if(class(settings$startValue)[1] == "numeric"){ + X = bayesianSetup$prior$sampler(settings$startValue) + } + if(is.matrix(settings$startValue)) X <- settings$startValue + }else{ + X <- bayesianSetup$X + } + + # X = startValue + if (!is.matrix(X)) stop("wrong starting values") + + currentChain = settings$currentChain + + FUN = setup$posterior$density + + pCRupdate <- settings$pCRupdate + nCR <- settings$nCR + Npar <- ncol(X) + Npop <- nrow(X) + + # Check for consistency of DEpairs + if(settings$DEpairs > (Npop-2)) stop("DEpairs to large for number of chains") + + # Set adaptation if percentage is supplied + if(settings$adaptation <1) settings$adaptation <- settings$adaptation*settings$iterations + + # Set number of iterations and initialize chain + n.iter <- ceiling(settings$iterations/Npop) + if (n.iter < 2) stop ("The total number of iterations must be greater than the number of parameters to fit times 2.") + + settings$burnin <- settings$burnin/Npop + lChain <- ceiling((n.iter - settings$burnin)/settings$thin)+1 + pChain <- array(NA, dim=c(lChain, Npar+3, Npop)) + colnames(pChain) <- c(setup$names, "LP", "LL", "LPr") + + # Evaluate start values and write them in the chain + logfitness_X <- FUN(X, returnAll = T) + pChain[1,,] <- t(cbind(X,logfitness_X)) + + # Set counter + counter <- 1 + iseq <- 1:Npop + + # gamma initialization. However gamma is calculated every iteration (see below). + gamma <- 2.38/sqrt(settings$DEpairs*Npar) + + + # delta initialization + delta <- rep(0, settings$nCR) + + funevals <- 0 + + #### pCR update + if(!restart){ + pCR = rep(1/nCR, nCR) + lCR <- rep(0,nCR) + + CR <- matrix(1/nCR, nrow = Npop, ncol = settings$updateInterval) + }else{ + pCR <- bayesianSetup$pCR + CR <- generateCRvalues(pCR, settings, Npop) + + } + + # helper counter for CR value index + counter_update <- 0 + + ## omega initialization + omega <- numeric() + + ## eps and e + eps <- settings$eps + e <- settings$e + + + ##################### Start iterations ############################## + for(iter in 2:n.iter){ + + xOld <- X + counter_update <- counter_update +1 + + for(i in 1:Npop){ + + selectedChains1 <- sample((1:Npop)[-i], settings$DEpairs, replace = FALSE) + selectedChains2 <- numeric(settings$DEpairs) + + # Avoid that selected chains are identical + for(k in 1:settings$DEpairs){ + selectedChains2[k] <- sample((1:Npop)[-c(i,selectedChains1[k],selectedChains2[1:k]) ],1) + } + + + # Get indices of parameters that are updated = indX + rn <- runif(Npar) + indX <- which(rn>(1-CR[i, counter_update])) + + # Make sure at least one dimension is updated + if(length(indX) == 0) indX <- sample(1:Npar, 1) + + # First update proposal + x_prop <- X[i,] + + + # Calculate gamma based on DEpairs and number of dimensions + # that are updated simulateously. + # To jump between modes gamma is set to 1 every fifth iteration. + if(runif(1)>4/5){ + gamma <- 1 + }else{ + gamma <-2.38/sqrt(settings$DEpairs* length(indX)) + } + + + # Replace with new proposal for indX + x_prop[indX] <- X[i,indX] + (1+e)*gamma*(apply(as.matrix(X[selectedChains1,indX]),2,sum)- + apply(as.matrix(X[selectedChains2,indX]),2,sum)) + eps*rnorm(length(indX),0,1) + + + + + logfitness_x_prop <- FUN(x_prop, returnAll = T) + if(!is.na(logfitness_x_prop[1] - logfitness_X[i,1])){ # To catch possible error + if ((logfitness_x_prop[1] - logfitness_X[i,1] ) > log(runif(1))){ + X[i,] <- x_prop + logfitness_X[i,] <- logfitness_x_prop + } + + } + + } #Npop + + + + ## Write values in chain + + if((iter > settings$burnin) && (iter %% settings$thin == 0)){ + counter <- counter+1 + pChain[counter,,] <- t(cbind(X,logfitness_X)) + } + + if(iter < settings$adaptation){ + + if(pCRupdate){ ## Calculate delta, this is (unlike the update) done every iteration + ## Calculate delta + + ## Calculate standard deviation of each dimension of X + sdX <- apply(X[,1:Npar,drop=FALSE],2,sd) + + ## Compute Euclidean distance between old and new X values + delta_Norm <- rowSums(((xOld-X[,1:Npar,drop=FALSE])/sdX)^2) + + ## Now delta can be calculated + for (k in 1:settings$nCR){ # Loop over CR values + + # Find updated chains + ind <- which(abs(CR[,k]-(k/nCR)) < 1e-5) + + ## Add normalized squared distance to the current delta + delta[k] <- delta[k]+sum(delta_Norm[ind]) + #delta[k] <- delta[k]+sum(delta_Norm) + + } + + } + + + if(iter%%settings$updateInterval == 0){ + + + if(pCRupdate){ + # Update CR values + tmp <- AdaptpCR(CR, delta, lCR, settings, Npop) + pCR <- tmp$pCR + lCR <- tmp$lCR + + ## CR values are generated outside loop because they are calculated + # even after adaptation phase. See below! + } + + ## remove outliers + ## TODO include if(remOutliers = TRUE) ?? + for(out in 1:Npop){ + omega[out] <- mean(pChain[((counter/2):counter),Npar+1, out]) + } + + if(NaN %in% omega){ + outlierChain <- NULL # Prevent possible error + }else{ + # Inter quantile range + IQR <- quantile(omega, probs = c(0.25, 0.75)) + + # Determine outlier chains + outlierChain <- which(omega< IQR[1] - 2*(IQR[2]-IQR[1])) + } + + + # Replace with best chain + if(length(outlierChain) > 0){ + best <- which.max(pChain[counter,Npar+1,]) + pChain[counter,,outlierChain] <- pChain[counter,,best] + + } # Remove outliers + + } + } + + + if(iter%%settings$updateInterval == 0){ + counter_update <- 0 # set counter back to zero + CR <- generateCRvalues(pCR, settings, Npop) + + } + + if(settings$message){ + if( (iter %% settings$consoleUpdates == 0) | (iter == n.iter)) cat("\r","Running DREAM-MCMC, chain ", currentChain, + "iteration" ,iter*Npop,"of",n.iter*Npop,". Current logp ", + logfitness_X[,1], + "Please wait!","\r") + flush.console() + } + + + } # niter + + ################ End of iterations ################ + + + iterationsOld <- 0 + + pChain <- pChain[1:counter,,] + + if(restart){ # Combine chains + newchains <- array(NA, dim = c((counter+nrow(bayesianSetup$chain[[1]])), (Npar+3), Npop)) + + for(i in 1:Npop){ + for(k in 1:(Npar+3)){ + newchains[,k,i] <- c(bayesianSetup$chain[[i]][,k],pChain[,k,i]) + } + } + pChain <- newchains + } + + pChain<- coda::as.mcmc.list(lapply(1:Npop,function(i) coda::as.mcmc(pChain[,1:(Npar+3),i]))) + + + return(list(chains = pChain, X = as.matrix(X[,1:Npar]), pCR = pCR)) + +} + + + + + diff --git a/BayesianTools/R/mcmcDREAM_helperFunctions.R b/BayesianTools/R/mcmcDREAM_helperFunctions.R index f7e6f80..e0b4b4c 100644 --- a/BayesianTools/R/mcmcDREAM_helperFunctions.R +++ b/BayesianTools/R/mcmcDREAM_helperFunctions.R @@ -1,73 +1,72 @@ -##' Generates matrix of CR values based on pCR -##' @param pCR vector of crossover probabilities. Needs to be of length nCR. -##' @param settings list of settings -##' @param Npop number of chains -##' @return Matrix with CR values -#' @keywords internal -generateCRvalues <- function(pCR,settings, Npop){ - - # Random vector, add zero to get first position - RandomVec <- c(0,cumsum(as.numeric(rmultinom(1, size = Npop*settings$updateInterval, prob = pCR)))) - - # get candidate points - cand <- sample(Npop*settings$updateInterval) - CR <- rep(NA, Npop*settings$updateInterval) - - ## Now loop over chains to generate CR values - for(i in 1:settings$nCR){ - #Start and End - Start <- RandomVec[i]+1 - End <- RandomVec[i+1] - - # get candidates - candx <- cand[Start:End] - - # Assign these indices settings$CR - CR[candx] <- i/settings$nCR - } - ## Reshape CR - CR <- matrix(CR,Npop,settings$updateInterval) - - return(CR) -} - - - - -#' Adapts pCR values -#' @param CR vector of crossover probabilities. Needs to be of length nCR. -#' @param settings list of settings -#' @param delta vector with differences -#' @param lCR values to weight delta -#' @param Npop number of chains. -#' @return Matrix with CR values -#' @keywords internal -AdaptpCR <- function(CR, delta ,lCR, settings, Npop){ - if(any(delta >0)){ ## Adaptions can only be made if there are changes in X - - # Change CR to vector - CR <- c(CR) - - # Store old lCR values - lCROld <- lCR - ## Determine lCR - lCR <- rep(NA,settings$nCR) - - for (k in 1:settings$nCR){ - - ## how many times a CR value is used. This is used to weight delta - CR_counter <- length(which(CR==k/settings$nCR)) - lCR[k] <- lCROld[k]+ CR_counter - } - - ## Adapt pCR - pCR <- Npop * (delta / lCR) / sum(delta) - - pCR[which(is.nan(pCR))] <- 1/settings$nCR # catch possible error if delta and lCR = 0 - - ## Normalize values - pCR <- pCR/sum(pCR) - - } - return(list(pCR=pCR,lCR=lCR)) -} ##AdaptpCR +##' Generates matrix of CR values based on pCR +##' @param pCR vector of crossover probabilities. Needs to be of length nCR. +##' @param settings list of settings +##' @param Npop number of chains +##' @return Matrix with CR values +#' @keywords internal +generateCRvalues <- function(pCR,settings, Npop){ + + # Random vector, add zero to get first position + RandomVec <- c(0,cumsum(as.numeric(rmultinom(1, size = Npop*settings$updateInterval, prob = pCR)))) + + # get candidate points + cand <- sample(Npop*settings$updateInterval) + CR <- rep(NA, Npop*settings$updateInterval) + + ## Now loop over chains to generate CR values + for(i in 1:settings$nCR){ + #Start and End + Start <- RandomVec[i]+1 + End <- RandomVec[i+1] + + # get candidates + candx <- cand[Start:End] + + # Assign these indices settings$CR + CR[candx] <- i/settings$nCR + } + ## Reshape CR + CR <- matrix(CR,Npop,settings$updateInterval) + + return(CR) +} + + + +#' Adapts pCR values +#' @param CR vector of crossover probabilities. Needs to be of length nCR. +#' @param settings list of settings +#' @param delta vector with differences +#' @param lCR values to weight delta +#' @param Npop number of chains. +#' @return Matrix with CR values +#' @keywords internal +AdaptpCR <- function(CR, delta ,lCR, settings, Npop){ + if(any(delta >0)){ ## Adaptions can only be made if there are changes in X + + # Change CR to vector + CR <- c(CR) + + # Store old lCR values + lCROld <- lCR + ## Determine lCR + lCR <- rep(NA,settings$nCR) + + for (k in 1:settings$nCR){ + + ## how many times a CR value is used. This is used to weight delta + CR_counter <- length(which(CR==k/settings$nCR)) + lCR[k] <- lCROld[k]+ CR_counter + } + + ## Adapt pCR + pCR <- Npop * (delta / lCR) / sum(delta) + + pCR[which(is.nan(pCR))] <- 1/settings$nCR # catch possible error if delta and lCR = 0 + + ## Normalize values + pCR <- pCR/sum(pCR) + + } + return(list(pCR=pCR,lCR=lCR)) +} ##AdaptpCR diff --git a/BayesianTools/R/mcmcDREAMzs.R b/BayesianTools/R/mcmcDREAMzs.R index 6f1fd01..f52a482 100644 --- a/BayesianTools/R/mcmcDREAMzs.R +++ b/BayesianTools/R/mcmcDREAMzs.R @@ -1,488 +1,489 @@ -### DREAMzs algorithm - -#' DREAMzs -#' @author Stefan Paul -#' @param bayesianSetup object of class 'bayesianSetup' or 'bayesianOuput'. -#' @param settings list with parameter values -#' @param iterations number of model evaluations -#' @param nCR parameter determining the number of cross-over proposals. If nCR = 1 all parameters are updated jointly. -#' @param updateInterval determines the interval for the pCR (crossover probabilities) update -#' @param gamma kurtosis parameter Bayesian Inference Scheme. -#' @param eps Ergodicity term -#' @param e Ergodicity term -#' @param pCRupdate update of crossover probabilities -#' @param burnin number of iterations treated as burn-in. These iterations are not recorded in the chain. -#' @param thin thinning parameter. Determines the interval in which values are recorded. -#' @param adaptation number or percentage of samples that are used for the adaptation in DREAM (see Details) -#' @param DEpairs number of pairs used to generate proposal -#' @param ZupdateFrequency frequency to update Z matrix -#' @param pSnooker probability of snooker update -#' @param Z starting matrix for Z -#' @param startValue either a matrix containing the start values (see details), an integer to define the number of chains to be run, a function to sample the start values or NUll - in which case the values are sampled from the prior. -#' @param consoleUpdates interval in which the sampling progress is printed to the console -#' @param message logical, determines whether the sampler's progress should be printed -#' @return mcmc.object containing the following elements: chains, X, pCR, Z -#' @references Vrugt, Jasper A., et al. "Accelerating Markov chain Monte Carlo simulation by differential evolution with self-adaptive randomized subspace sampling." International Journal of Nonlinear Sciences and Numerical Simulation 10.3 (2009): 273-290. -#' @references ter Braak C. J. F., and Vrugt J. A. (2008). Differential Evolution Markov Chain with snooker updater and fewer chains. Statistics and Computing http://dx.doi.org/10.1007/s11222-008-9104-9 -#' @details Instead of a bayesianSetup, the function can take the output of a previous run to restart the sampler -#' from the last iteration. Due to the sampler's internal structure you can only use the output -#' of DREAMzs. -#' If you provide a matrix with start values, the number of rows determines the number of chains that will be run. -#' The number of columns must be equivalent to the number of parameters in your bayesianSetup. \cr\cr -#' There are several small differences in the algorithm presented here compared to the original paper by Vrugt et al. (2009). Mainly -#' The algorithm implemented here does not have an automatic stopping criterion. Hence, it will -#' always run the number of iterations specified by the user. Also, convergence is not -#' monitored and left to the user. This can easily be done with coda::gelman.diag(chain). -#' Furthermore, the delayed rejection step proposed in Vrugt et al. (2009) is not implemented here.\cr\cr -#' During the adaptation phase DREAM is running two mechanisms to enhance the sampler's efficiency. -#' First, the distribution of crossover values is tuned to favor large jumps in the parameter space. -#' The crossover probabilities determine how many parameters are updated simultaneously. -#' Second, outlier chains are replaced as they can largely deteriorate the sampler's performance. -#' However, these steps destroy the detailed balance of the chain. Consequently these parts of the chain -#' should be discarded when summarizing posterior moments. This can be done automatically during the -#' sampling process (i.e. burn-in > adaptation) or subsequently by the user. We chose to distinguish between -#' the burn-in and adaptation phase to allow the user more flexibility in the sampler's settings. -#' @example /inst/examples/DEfamilyHelp.R -#' @seealso \code{\link{DREAM}} -#' @export -DREAMzs <- function(bayesianSetup, - settings = list(iterations = 10000, - nCR = 3, - gamma = NULL, - eps = 0, - e = 5e-2, - pCRupdate = FALSE, - updateInterval = 10, - burnin = 0, - thin = 1, - adaptation = 0.2, - parallel = NULL, - - Z = NULL, - ZupdateFrequency = 10, - pSnooker = 0.1, - - - DEpairs = 2, - consoleUpdates = 10, - startValue = NULL, - currentChain = 1, - message = FALSE)) { - - - - if("bayesianOutput" %in% class(bayesianSetup)){ - restart <- TRUE - } else restart <- FALSE - - - if(restart){ - if(is.null(settings)) settings <- bayesianSetup$settings - else settings <- applySettingsDefault(settings = settings, sampler = "DREAMzs") - - settings$adaptation <- 0 # set burnIn to 0 if restart because it has already been - # applied in chain that is restarted and destroys detailed balance. - - }else{ - # If nothing provided use default settings - settings <- applySettingsDefault(settings = settings, sampler = "DREAMzs") - } - - if(!restart){ - setup <- bayesianSetup - } else setup <- bayesianSetup$setup - - setup <- checkBayesianSetup(setup, parallel = settings$parallel) # calling parallel will check if requested parallelization in settings is provided by the BayesianSetup - if(is.null(settings$parallel)) settings$parallel = setup$parallel # checking back - if no parallelization is provided, we use the parallelization in the BayesianSetup. We could also set parallel = F, but I feel it makes more sense to use the Bayesiansetup as default - - if(!restart){ - if(is.null(settings$startValue)){ - parLen = length(bayesianSetup$prior$sampler(1)) - X = bayesianSetup$prior$sampler(3) - } - if(is.function(settings$startValue)){ - X = settings$startValue() - } - if(class(settings$startValue)[1] == "numeric"){ - X = bayesianSetup$prior$sampler(settings$startValue) - } - - if(is.matrix(settings$startValue)) X <- settings$startValue - - if(is.null(settings$Z)){ - parLen = length(bayesianSetup$prior$sampler(1)) - Z = bayesianSetup$prior$sampler(parLen * 10) - } - if(is.function(settings$Z)){ - Z = settings$Z() - } - - if(class(settings$Z)[1] == "numeric"){ - Z = bayesianSetup$prior$sampler(settings$Z) - } - if(is.matrix(settings$Z)) Z <- settings$Z - - }else{ - X <- bayesianSetup$X - Z <- bayesianSetup$Z - if(is.vector(Z)) Z = as.matrix(Z) - } - - - if (! is.matrix(X)) stop("wrong starting values") - if (! is.matrix(Z)) stop("wrong Z values") - - - FUN = setup$posterior$density - - pCRupdate <- settings$pCRupdate - nCR <- settings$nCR - Npar <- ncol(X) - - Npar12 <- (Npar - 1)/2 # factor for Metropolis ratio DE Snooker update - - parallel <- settings$parallel - if(!is.null(parallel)){ - if(is.numeric(parallel) | parallel == "external") parallel <- TRUE - }else parallel <- FALSE - - pCRupdate <- settings$pCRupdate - nCR <- settings$nCR - Npar <- ncol(X) - Npop <- nrow(X) - - - # Set adaptation if percentage is supplied - if(settings$adaptation <1) settings$adaptation <- settings$adaptation*settings$iterations - - # Determine number of iterations and initialize chain - n.iter <- ceiling(settings$iterations/Npop) - if (n.iter < 2) stop ("The total number of iterations must be greater than 3") - settings$burnin <- settings$burnin/Npop - lChain <- ceiling((n.iter - settings$burnin)/settings$thin)+1 - pChain <- array(NA, dim=c(lChain, Npar+3, Npop)) - - - # assign memory for Z and write first values in Z - M <- nrow(Z[complete.cases(Z),,drop = FALSE]) - Zold <- Z[complete.cases(Z),,drop = FALSE] - Z <- matrix(NA, nrow= M + floor((n.iter) /settings$ZupdateFrequency) * Npop, ncol=Npar) - Z[1:M,] <- Zold - - - colnames(pChain) <- c(setup$names, "LP", "LL", "LPr") - - - # Evaluate start values and write them in the chain - logfitness_X <- FUN(X, returnAll = T) - pChain[1,,] <- t(cbind(X,logfitness_X)) - - - # Set counter - counter <- 1 - iseq <- 1:Npop - - - #### gamma, initialization. However gamma is calculated every iteration (see below). - gamma <- 2.38/sqrt(settings$DEpairs*Npar) - - - ## delta initialization - delta <- rep(0, settings$nCR) - - funevals <- 0 - #### pCR update - # Initialization - if(!restart){ - pCR = rep(1/nCR, nCR) - lCR <- rep(0,nCR) - - CR <- matrix(1/nCR, nrow = Npop, ncol = settings$updateInterval) - }else{ - pCR <- bayesianSetup$pCR - CR <- generateCRvalues(pCR, settings, Npop) - - } - - - # helper counter for CR value index - counter_update <- 0 - - ## Omega initialization - omega <- numeric() - - ## eps and e - eps <- settings$eps - e <- settings$e - - - ##################### Start iterations ############################## - for(iter in 2:n.iter){ - - xOld <- X - - - if(parallel == TRUE){ - x_prop <- matrix(NA, nrow= Npop, ncol=Npar) - r_extra <- numeric(Npop) - - for(i in 1:Npop){ - - if(runif(1)>settings$pSnooker){ - selectedChains1 <- sample((1:M), settings$DEpairs, replace = FALSE) - selectedChains2 <- numeric(settings$DEpairs) - - # Avoid that selected chains are identical - for(k in 1:settings$DEpairs){ - selectedChains2[k] <- sample((1:M)[-c(selectedChains1[k],selectedChains2[1:k]) ],1) - } - - # Get indices of parameters that are updated = indX - rn <- runif(Npar) - indX <- which(rn>(1-CR[i])) - - # Make sure at least one dimension is updated - if(length(indX) == 0) indX <- sample(1:Npar, 1) - - # First update proposal - x_prop[i,] <- X[i,] - - # Calculate gamma based on DEpairs and number of dimensions - # that are updated simulateously. - # To jump between modes gamma is set to 1 every fifth iteration. - if(runif(1)>4/5){ - gamma <- 1 - }else{ - gamma <-2.38/sqrt(settings$DEpairs* length(indX)) - } - - # No snooker update - # Replace with new proposal for indX - x_prop[i,indX] <- X[i,indX] + (1+e)*gamma*(apply(as.matrix(Z[selectedChains1,indX]),2,sum)- - apply(as.matrix(Z[selectedChains2,indX]),2,sum)) + eps*rnorm(length(indX),0,1) - r_extra[i] <- 0 - - }else{ # Make proposal using snooker update - selectSnooker <- sample((1:M),replace = FALSE, 3) - - z <- Z[selectSnooker[1],] - x_z <- X[i,] - z - D2 <- max(sum(x_z*x_z), 1.0e-300) - projdiff <- sum((Z[selectSnooker[1],] -Z[selectSnooker[2],]) * x_z)/D2 # inner_product of difference with x_z / squared norm x_z - gamma_snooker <- runif(1, min=1.2,max=2.2) - - x_prop[i,] <- X[i,] + gamma_snooker * projdiff * x_z - x_z <- x_prop[i,] - z - D2prop <- max(sum(x_z*x_z), 1.0e-300) - r_extra[i] <- Npar12 * (log(D2prop) - log(D2)) - - } - } # Npop - - - # run proposals - logfitness_x_prop <- FUN(x_prop, returnAll = T) - - # evaluate acceptance - for(i in 1:Npop){ - if(!is.na(logfitness_x_prop[i,1] - logfitness_X[i,1])){ - if ((logfitness_x_prop[i,1] - logfitness_X[i,1] + r_extra[i]) > log(runif(1))){ - # accept <- accept + 1 - X[i,] <- x_prop[i,] - logfitness_X[i,] <- logfitness_x_prop[i,] - } - } - } - - - }else{ ## If not parallel - for(i in 1:Npop){ - - if(runif(1)>settings$pSnooker){ - selectedChains1 <- sample((1:M), settings$DEpairs, replace = FALSE) - selectedChains2 <- numeric(settings$DEpairs) - - # Avoid that selected chains are identical - for(k in 1:settings$DEpairs){ - selectedChains2[k] <- sample((1:M)[-c(selectedChains1[k],selectedChains2[1:k]) ],1) - } - - # Get indices of parameters that are updated = indX - rn <- runif(Npar) - indX <- which(rn>(1-CR[i])) - - # Make sure at least one dimension is updated - if(length(indX) == 0) indX <- sample(1:Npar, 1) - - # First update proposal - x_prop <- X[i,] - - # Calculate gamma based on DEpairs and number of dimensions - # that are updated simulateously. - # To jump between modes gamma is set to 1 every fifth iteration. - if(runif(1)>4/5){ - gamma <- 1 - }else{ - gamma <-2.38/sqrt(settings$DEpairs* length(indX)) - } - - # No snooker update - # Replace with new proposal for indX - x_prop[indX] <- X[i,indX] + (1+e)*gamma*(apply(as.matrix(Z[selectedChains1,indX]),2,sum)- - apply(as.matrix(Z[selectedChains2,indX]),2,sum)) + eps*rnorm(length(indX),0,1) - r_extra <- 0 - - }else{ # Make proposal using snooker update - selectSnooker <- sample((1:M),replace = FALSE, 3) - - z <- Z[selectSnooker[1],] - x_z <- X[i,] - z - D2 <- max(sum(x_z*x_z), 1.0e-300) - projdiff <- sum((Z[selectSnooker[1],] -Z[selectSnooker[2],]) * x_z)/D2 # inner_product of difference with x_z / squared norm x_z - gamma_snooker <- runif(1, min=1.2,max=2.2) - - x_prop <- X[i,] + gamma_snooker * projdiff * x_z - x_z <- x_prop - z - D2prop <- max(sum(x_z*x_z), 1.0e-300) - r_extra <- Npar12 * (log(D2prop) - log(D2)) - - } - - - logfitness_x_prop <- FUN(x_prop, returnAll = T) - - if(!is.na(logfitness_x_prop[1] - logfitness_X[i,1])){ # To catch possible error - if ((logfitness_x_prop[1] - logfitness_X[i,1] + r_extra) > log(runif(1))){ - X[i,] <- x_prop - logfitness_X[i,] <- logfitness_x_prop - } - - } - - } #Npop - - } # not parallel - - - ## Write values in chain - - if((iter > settings$burnin) && (iter %% settings$thin == 0)){ - counter <- counter+1 - pChain[counter,,] <- t(cbind(X,logfitness_X)) - } - - # Update Z - if(counter%%settings$ZupdateFrequency == 0){ - Z[(M+1):(M+Npop),] <- X - M <- M+Npop - - } - - ################################### - - if(iter < settings$adaptation){ - - if(pCRupdate){ ## Calculate delta, this is (unlike the update) done every iteration - ## Calculate delta - - ## Calculate standard deviation of each dimension of X - sdX <- apply(X[,1:Npar,drop=FALSE],2,sd) - - ## Compute Euclidean distance between old and new X values - delta_Norm <- rowSums(((xOld-X[,1:Npar,drop=FALSE])/sdX)^2) - - ## Now delta can be calculated - for (k in 1:settings$nCR){ # Loop over CR values - - # Find updated chains - ind <- which(abs(CR[,k]-(k/nCR)) < 1e-5) - - ## Add normalized squared distance to the current delta - delta[k] <- delta[k]+sum(delta_Norm[ind]) - #delta[k] <- delta[k]+sum(delta_Norm) - - } - - } - - - if(iter%%settings$updateInterval == 0){ - - - if(pCRupdate){ - # Update CR values - tmp <- AdaptpCR(CR, delta, lCR, settings, Npop) - pCR <- tmp$pCR - lCR <- tmp$lCR - } - - ## remove outliers - ## TODO include if(remOutliers = TRUE) ?? - for(out in 1:Npop){ - omega[out] <- mean(pChain[((counter/2):counter),Npar+1, out]) - } - - if(NaN %in% omega){ - outlierChain <- NULL # Prevent possible error - }else{ - # Inter quantile range - IQR <- quantile(omega, probs = c(0.25, 0.75)) - - # Determine outlier chains - outlierChain <- which(omega< IQR[1] - 2*(IQR[2]-IQR[1])) - } - - - # Replace with best chain - if(length(outlierChain) > 0){ - best <- which.max(pChain[counter,Npar+1,]) - pChain[counter,,outlierChain] <- pChain[counter,,best] - - } # Remove outliers - - } - } - - if(iter%%settings$updateInterval == 0){ - counter_update <- 0 # set counter back to zero - CR <- generateCRvalues(pCR, settings, Npop) - - } - ############################### - - - - if(settings$message){ - if( (iter %% settings$consoleUpdates == 0) | (iter == n.iter)) cat("\r","Running DREAM-MCMC, chain ", settings$currentChain, - "iteration" ,iter*Npop,"of",n.iter*Npop,". Current logp ", - logfitness_X[,1], - "Please wait!","\r") - flush.console() - } - - - } # niter - - iterationsOld <- 0 - - pChain <- pChain[1:counter,,] - - if(restart){ # Combine chains - newchains <- array(NA, dim = c((counter+nrow(bayesianSetup$chain[[1]])), (Npar+3), Npop)) - - for(i in 1:Npop){ - for(k in 1:(Npar+3)){ - newchains[,k,i] <- c(bayesianSetup$chain[[i]][,k],pChain[,k,i]) - } - } - pChain <- newchains - } - - - - pChain<- coda::as.mcmc.list(lapply(1:Npop,function(i) coda::as.mcmc(pChain[,1:(Npar+3),i]))) - - - list(chains = pChain, X = as.matrix(X[,1:Npar]), Z = Z, pCR = pCR) - -} +### DREAMzs algorithm + +#' DREAMzs +#' @author Stefan Paul +#' @param bayesianSetup object of class 'bayesianSetup' or 'bayesianOuput'. +#' @param settings list with parameter values +#' @param iterations number of model evaluations +#' @param nCR parameter determining the number of cross-over proposals. If nCR = 1 all parameters are updated jointly. +#' @param updateInterval determines the interval for the pCR (crossover probabilities) update +#' @param gamma kurtosis parameter Bayesian Inference Scheme. +#' @param eps Ergodicity term +#' @param e Ergodicity term +#' @param pCRupdate update of crossover probabilities +#' @param burnin number of iterations treated as burn-in. These iterations are not recorded in the chain. +#' @param thin thinning parameter. Determines the interval in which values are recorded. +#' @param adaptation number or percentage of samples that are used for the adaptation in DREAM (see Details) +#' @param DEpairs number of pairs used to generate proposal +#' @param ZupdateFrequency frequency to update Z matrix +#' @param pSnooker probability of snooker update +#' @param Z starting matrix for Z +#' @param startValue either a matrix containing the start values (see details), an integer to define the number of chains to be run, a function to sample the start values or NUll - in which case the values are sampled from the prior. +#' @param consoleUpdates interval in which the sampling progress is printed to the console +#' @param message logical, determines whether the sampler's progress should be printed +#' @return mcmc.object containing the following elements: chains, X, pCR, Z +#' @references Vrugt, Jasper A., et al. "Accelerating Markov chain Monte Carlo simulation by differential evolution with self-adaptive randomized subspace sampling." International Journal of Nonlinear Sciences and Numerical Simulation 10.3 (2009): 273-290. +#' @references ter Braak C. J. F., and Vrugt J. A. (2008). Differential Evolution Markov Chain with snooker updater and fewer chains. Statistics and Computing http://dx.doi.org/10.1007/s11222-008-9104-9 +#' @details Instead of a bayesianSetup, the function can take the output of a previous run to restart the sampler +#' from the last iteration. Due to the sampler's internal structure you can only use the output +#' of DREAMzs. +#' If you provide a matrix with start values, the number of rows determines the number of chains that will be run. +#' The number of columns must be equivalent to the number of parameters in your bayesianSetup. \cr\cr +#' There are several small differences in the algorithm presented here compared to the original paper by Vrugt et al. (2009). Mainly +#' The algorithm implemented here does not have an automatic stopping criterion. Hence, it will +#' always run the number of iterations specified by the user. Also, convergence is not +#' monitored and left to the user. This can easily be done with coda::gelman.diag(chain). +#' Furthermore, the delayed rejection step proposed in Vrugt et al. (2009) is not implemented here.\cr\cr +#' During the adaptation phase DREAM is running two mechanisms to enhance the sampler's efficiency. +#' First, the distribution of crossover values is tuned to favor large jumps in the parameter space. +#' The crossover probabilities determine how many parameters are updated simultaneously. +#' Second, outlier chains are replaced as they can largely deteriorate the sampler's performance. +#' However, these steps destroy the detailed balance of the chain. Consequently these parts of the chain +#' should be discarded when summarizing posterior moments. This can be done automatically during the +#' sampling process (i.e. burn-in > adaptation) or subsequently by the user. We chose to distinguish between +#' the burn-in and adaptation phase to allow the user more flexibility in the sampler's settings. +#' @example /inst/examples/DEfamilyHelp.R +#' @seealso \code{\link{DREAM}} +#' @export +#' +DREAMzs <- function(bayesianSetup, + settings = list(iterations = 10000, + nCR = 3, + gamma = NULL, + eps = 0, + e = 5e-2, + pCRupdate = FALSE, + updateInterval = 10, + burnin = 0, + thin = 1, + adaptation = 0.2, + parallel = NULL, + + Z = NULL, + ZupdateFrequency = 10, + pSnooker = 0.1, + + + DEpairs = 2, + consoleUpdates = 10, + startValue = NULL, + currentChain = 1, + message = FALSE)) { + + + + if("bayesianOutput" %in% class(bayesianSetup)){ + restart <- TRUE + } else restart <- FALSE + + + if(restart){ + if(is.null(settings)) settings <- bayesianSetup$settings + else settings <- applySettingsDefault(settings = settings, sampler = "DREAMzs") + + settings$adaptation <- 0 # set burnIn to 0 if restart because it has already been + # applied in chain that is restarted and destroys detailed balance. + + }else{ + # If nothing provided use default settings + settings <- applySettingsDefault(settings = settings, sampler = "DREAMzs") + } + + if(!restart){ + setup <- bayesianSetup + } else setup <- bayesianSetup$setup + + setup <- checkBayesianSetup(setup, parallel = settings$parallel) # calling parallel will check if requested parallelization in settings is provided by the BayesianSetup + if(is.null(settings$parallel)) settings$parallel = setup$parallel # checking back - if no parallelization is provided, we use the parallelization in the BayesianSetup. We could also set parallel = F, but I feel it makes more sense to use the Bayesiansetup as default + + if(!restart){ + if(is.null(settings$startValue)){ + parLen = length(bayesianSetup$prior$sampler(1)) + X = bayesianSetup$prior$sampler(3) + } + if(is.function(settings$startValue)){ + X = settings$startValue() + } + if(class(settings$startValue)[1] == "numeric"){ + X = bayesianSetup$prior$sampler(settings$startValue) + } + + if(is.matrix(settings$startValue)) X <- settings$startValue + + if(is.null(settings$Z)){ + parLen = length(bayesianSetup$prior$sampler(1)) + Z = bayesianSetup$prior$sampler(parLen * 10) + } + if(is.function(settings$Z)){ + Z = settings$Z() + } + + if(class(settings$Z)[1] == "numeric"){ + Z = bayesianSetup$prior$sampler(settings$Z) + } + if(is.matrix(settings$Z)) Z <- settings$Z + + }else{ + X <- bayesianSetup$X + Z <- bayesianSetup$Z + if(is.vector(Z)) Z = as.matrix(Z) + } + + + if (! is.matrix(X)) stop("wrong starting values") + if (! is.matrix(Z)) stop("wrong Z values") + + + FUN = setup$posterior$density + + pCRupdate <- settings$pCRupdate + nCR <- settings$nCR + Npar <- ncol(X) + + Npar12 <- (Npar - 1)/2 # factor for Metropolis ratio DE Snooker update + + parallel <- settings$parallel + if(!is.null(parallel)){ + if(is.numeric(parallel) | parallel == "external") parallel <- TRUE + }else parallel <- FALSE + + pCRupdate <- settings$pCRupdate + nCR <- settings$nCR + Npar <- ncol(X) + Npop <- nrow(X) + + + # Set adaptation if percentage is supplied + if(settings$adaptation <1) settings$adaptation <- settings$adaptation*settings$iterations + + # Determine number of iterations and initialize chain + n.iter <- ceiling(settings$iterations/Npop) + if (n.iter < 2) stop ("The total number of iterations must be greater than 3") + settings$burnin <- settings$burnin/Npop + lChain <- ceiling((n.iter - settings$burnin)/settings$thin)+1 + pChain <- array(NA, dim=c(lChain, Npar+3, Npop)) + + + # assign memory for Z and write first values in Z + M <- nrow(Z[complete.cases(Z),,drop = FALSE]) + Zold <- Z[complete.cases(Z),,drop = FALSE] + Z <- matrix(NA, nrow= M + floor((n.iter) /settings$ZupdateFrequency) * Npop, ncol=Npar) + Z[1:M,] <- Zold + + + colnames(pChain) <- c(setup$names, "LP", "LL", "LPr") + + + # Evaluate start values and write them in the chain + logfitness_X <- FUN(X, returnAll = T) + pChain[1,,] <- t(cbind(X,logfitness_X)) + + + # Set counter + counter <- 1 + iseq <- 1:Npop + + + #### gamma, initialization. However gamma is calculated every iteration (see below). + gamma <- 2.38/sqrt(settings$DEpairs*Npar) + + + ## delta initialization + delta <- rep(0, settings$nCR) + + funevals <- 0 + #### pCR update + # Initialization + if(!restart){ + pCR = rep(1/nCR, nCR) + lCR <- rep(0,nCR) + + CR <- matrix(1/nCR, nrow = Npop, ncol = settings$updateInterval) + }else{ + pCR <- bayesianSetup$pCR + CR <- generateCRvalues(pCR, settings, Npop) + + } + + + # helper counter for CR value index + counter_update <- 0 + + ## Omega initialization + omega <- numeric() + + ## eps and e + eps <- settings$eps + e <- settings$e + + + ##################### Start iterations ############################## + for(iter in 2:n.iter){ + + xOld <- X + + + if(parallel == TRUE){ + x_prop <- matrix(NA, nrow= Npop, ncol=Npar) + r_extra <- numeric(Npop) + + for(i in 1:Npop){ + + if(runif(1)>settings$pSnooker){ + selectedChains1 <- sample((1:M), settings$DEpairs, replace = FALSE) + selectedChains2 <- numeric(settings$DEpairs) + + # Avoid that selected chains are identical + for(k in 1:settings$DEpairs){ + selectedChains2[k] <- sample((1:M)[-c(selectedChains1[k],selectedChains2[1:k]) ],1) + } + + # Get indices of parameters that are updated = indX + rn <- runif(Npar) + indX <- which(rn>(1-CR[i])) + + # Make sure at least one dimension is updated + if(length(indX) == 0) indX <- sample(1:Npar, 1) + + # First update proposal + x_prop[i,] <- X[i,] + + # Calculate gamma based on DEpairs and number of dimensions + # that are updated simulateously. + # To jump between modes gamma is set to 1 every fifth iteration. + if(runif(1)>4/5){ + gamma <- 1 + }else{ + gamma <-2.38/sqrt(settings$DEpairs* length(indX)) + } + + # No snooker update + # Replace with new proposal for indX + x_prop[i,indX] <- X[i,indX] + (1+e)*gamma*(apply(as.matrix(Z[selectedChains1,indX]),2,sum)- + apply(as.matrix(Z[selectedChains2,indX]),2,sum)) + eps*rnorm(length(indX),0,1) + r_extra[i] <- 0 + + }else{ # Make proposal using snooker update + selectSnooker <- sample((1:M),replace = FALSE, 3) + + z <- Z[selectSnooker[1],] + x_z <- X[i,] - z + D2 <- max(sum(x_z*x_z), 1.0e-300) + projdiff <- sum((Z[selectSnooker[1],] -Z[selectSnooker[2],]) * x_z)/D2 # inner_product of difference with x_z / squared norm x_z + gamma_snooker <- runif(1, min=1.2,max=2.2) + + x_prop[i,] <- X[i,] + gamma_snooker * projdiff * x_z + x_z <- x_prop[i,] - z + D2prop <- max(sum(x_z*x_z), 1.0e-300) + r_extra[i] <- Npar12 * (log(D2prop) - log(D2)) + + } + } # Npop + + + # run proposals + logfitness_x_prop <- FUN(x_prop, returnAll = T) + + # evaluate acceptance + for(i in 1:Npop){ + if(!is.na(logfitness_x_prop[i,1] - logfitness_X[i,1])){ + if ((logfitness_x_prop[i,1] - logfitness_X[i,1] + r_extra[i]) > log(runif(1))){ + # accept <- accept + 1 + X[i,] <- x_prop[i,] + logfitness_X[i,] <- logfitness_x_prop[i,] + } + } + } + + + }else{ ## If not parallel + for(i in 1:Npop){ + + if(runif(1)>settings$pSnooker){ + selectedChains1 <- sample((1:M), settings$DEpairs, replace = FALSE) + selectedChains2 <- numeric(settings$DEpairs) + + # Avoid that selected chains are identical + for(k in 1:settings$DEpairs){ + selectedChains2[k] <- sample((1:M)[-c(selectedChains1[k],selectedChains2[1:k]) ],1) + } + + # Get indices of parameters that are updated = indX + rn <- runif(Npar) + indX <- which(rn>(1-CR[i])) + + # Make sure at least one dimension is updated + if(length(indX) == 0) indX <- sample(1:Npar, 1) + + # First update proposal + x_prop <- X[i,] + + # Calculate gamma based on DEpairs and number of dimensions + # that are updated simulateously. + # To jump between modes gamma is set to 1 every fifth iteration. + if(runif(1)>4/5){ + gamma <- 1 + }else{ + gamma <-2.38/sqrt(settings$DEpairs* length(indX)) + } + + # No snooker update + # Replace with new proposal for indX + x_prop[indX] <- X[i,indX] + (1+e)*gamma*(apply(as.matrix(Z[selectedChains1,indX]),2,sum)- + apply(as.matrix(Z[selectedChains2,indX]),2,sum)) + eps*rnorm(length(indX),0,1) + r_extra <- 0 + + }else{ # Make proposal using snooker update + selectSnooker <- sample((1:M),replace = FALSE, 3) + + z <- Z[selectSnooker[1],] + x_z <- X[i,] - z + D2 <- max(sum(x_z*x_z), 1.0e-300) + projdiff <- sum((Z[selectSnooker[1],] -Z[selectSnooker[2],]) * x_z)/D2 # inner_product of difference with x_z / squared norm x_z + gamma_snooker <- runif(1, min=1.2,max=2.2) + + x_prop <- X[i,] + gamma_snooker * projdiff * x_z + x_z <- x_prop - z + D2prop <- max(sum(x_z*x_z), 1.0e-300) + r_extra <- Npar12 * (log(D2prop) - log(D2)) + + } + + + logfitness_x_prop <- FUN(x_prop, returnAll = T) + + if(!is.na(logfitness_x_prop[1] - logfitness_X[i,1])){ # To catch possible error + if ((logfitness_x_prop[1] - logfitness_X[i,1] + r_extra) > log(runif(1))){ + X[i,] <- x_prop + logfitness_X[i,] <- logfitness_x_prop + } + + } + + } #Npop + + } # not parallel + + + ## Write values in chain + + if((iter > settings$burnin) && (iter %% settings$thin == 0)){ + counter <- counter+1 + pChain[counter,,] <- t(cbind(X,logfitness_X)) + } + + # Update Z + if(counter%%settings$ZupdateFrequency == 0){ + Z[(M+1):(M+Npop),] <- X + M <- M+Npop + + } + + ################################### + + if(iter < settings$adaptation){ + + if(pCRupdate){ ## Calculate delta, this is (unlike the update) done every iteration + ## Calculate delta + + ## Calculate standard deviation of each dimension of X + sdX <- apply(X[,1:Npar,drop=FALSE],2,sd) + + ## Compute Euclidean distance between old and new X values + delta_Norm <- rowSums(((xOld-X[,1:Npar,drop=FALSE])/sdX)^2) + + ## Now delta can be calculated + for (k in 1:settings$nCR){ # Loop over CR values + + # Find updated chains + ind <- which(abs(CR[,k]-(k/nCR)) < 1e-5) + + ## Add normalized squared distance to the current delta + delta[k] <- delta[k]+sum(delta_Norm[ind]) + #delta[k] <- delta[k]+sum(delta_Norm) + + } + + } + + + if(iter%%settings$updateInterval == 0){ + + + if(pCRupdate){ + # Update CR values + tmp <- AdaptpCR(CR, delta, lCR, settings, Npop) + pCR <- tmp$pCR + lCR <- tmp$lCR + } + + ## remove outliers + ## TODO include if(remOutliers = TRUE) ?? + for(out in 1:Npop){ + omega[out] <- mean(pChain[((counter/2):counter),Npar+1, out]) + } + + if(NaN %in% omega){ + outlierChain <- NULL # Prevent possible error + }else{ + # Inter quantile range + IQR <- quantile(omega, probs = c(0.25, 0.75)) + + # Determine outlier chains + outlierChain <- which(omega< IQR[1] - 2*(IQR[2]-IQR[1])) + } + + + # Replace with best chain + if(length(outlierChain) > 0){ + best <- which.max(pChain[counter,Npar+1,]) + pChain[counter,,outlierChain] <- pChain[counter,,best] + + } # Remove outliers + + } + } + + if(iter%%settings$updateInterval == 0){ + counter_update <- 0 # set counter back to zero + CR <- generateCRvalues(pCR, settings, Npop) + + } + ############################### + + + + if(settings$message){ + if( (iter %% settings$consoleUpdates == 0) | (iter == n.iter)) cat("\r","Running DREAM-MCMC, chain ", settings$currentChain, + "iteration" ,iter*Npop,"of",n.iter*Npop,". Current logp ", + logfitness_X[,1], + "Please wait!","\r") + flush.console() + } + + + } # niter + + iterationsOld <- 0 + + pChain <- pChain[1:counter,,] + + if(restart){ # Combine chains + newchains <- array(NA, dim = c((counter+nrow(bayesianSetup$chain[[1]])), (Npar+3), Npop)) + + for(i in 1:Npop){ + for(k in 1:(Npar+3)){ + newchains[,k,i] <- c(bayesianSetup$chain[[i]][,k],pChain[,k,i]) + } + } + pChain <- newchains + } + + + + pChain<- coda::as.mcmc.list(lapply(1:Npop,function(i) coda::as.mcmc(pChain[,1:(Npar+3),i]))) + + + list(chains = pChain, X = as.matrix(X[,1:Npar]), Z = Z, pCR = pCR) + +} diff --git a/BayesianTools/R/mcmcFrancesco.R b/BayesianTools/R/mcmcFrancesco.R index 22288a3..982e505 100644 --- a/BayesianTools/R/mcmcFrancesco.R +++ b/BayesianTools/R/mcmcFrancesco.R @@ -1,349 +1,350 @@ -#' The Metropolis Algorithm -#' @author Francesco Minunno -#' @description The Metropolis Algorithm (Metropolis et al. 1953) -#' @param startValue vector with the start values for the algorithm. Can be NULL if FUN is of class BayesianSetup. In this case, startValues are sampled from the prior. -#' @param iterations number of iterations to run -#' @param nBI number of burn-in -#' @param parmin minimum values for the parameter vector or NULL if FUN is of class BayesianSetup -#' @param parmax maximum values for the parameter vector or NULL if FUN is of class BayesianSetup -#' @param f scaling factor -#' @param FUN function to be sampled from or object of class bayesianSetup -#' @param consoleUpdates integer, determines the frequency with which sampler progress is printed to the console -#' @references Metropolis, Nicholas, et al. "Equation of state calculations by fast computing machines." The journal of chemical physics 21.6 (1953): 1087-1092. -#' @keywords internal -# #' @export -M <- function(startValue = NULL, iterations = 10000, nBI = 0 , parmin = NULL, parmax= NULL, f = 1, FUN, consoleUpdates=1000) { - - - if(inherits(FUN, "BayesianSetup")){ - if(FUN$numPars==1) stop("Sampler cannot be started for 1 parameter") - - if(is.null(startValue)){ - startValue <- FUN$prior$sampler() - } - parmin <- FUN$prior$lower - parmax <- FUN$prior$upper - FUN <- FUN$posterior$density - } - - - pValues = startValue - lChain = iterations - - npar <- length(pValues) - logMAP <- -Inf - pChain <- matrix(NA_real_, nrow = lChain - nBI, ncol = npar+3) - -#******************************************************************************** - -# First call to the model. Calculate likelihood and prior - postL0 <- FUN(pValues, returnAll = T) - accept.prob <- 0 - -#******************************************************************************** - -# Define Variance-covariance matrix (vcovProp) for proposal generation an - - scalProp <- f * 2.4^2/npar # This f is the scaling factor tuned manually - covPar <- scalProp * diag((0.01 * (parmax - parmin))^2) - -#******************************************************************************** -# Build up the chain. Candidates for the parameter values (candidatepValues) -# are assumed to stem from a multivariate normal distribution (mvrnorm) with mean -# at the current state and covariance given by scalProp*covPar. -#----- - - for (j in 1:lChain) { - if (j%%consoleUpdates == 0) print(c(j,postL1[1])) - candidatepValues <- mvtnorm::rmvnorm(1, pValues, covPar) - - # Call the model and calculate the likelihood - postL1 <- FUN(candidatepValues, returnAll = T) - - # Check whether the candidates are accepted. - alpha <- min(exp(postL1[1] - postL0[1]), 1) - accept <- 0 - if (runif(1) < alpha) { - postL0 <- postL1 - pValues <- candidatepValues - accept <- 1 - if (postL0[1] > logMAP) - { - logMAP <- postL0[1] - psetMAP <- pValues - } - - } - if (j > nBI) { - pChain[j-nBI,] <- c(pValues,postL0) - accept.prob <- accept.prob + accept - } - } - accept.prob <- accept.prob/(lChain-nBI) - list(Draws = pChain, accept.prob = accept.prob,psetMAP=psetMAP) -} - - -#' The Adaptive Metropolis Algorithm -#' @author Francesco Minunno -#' @description The Adaptive Metropolis Algorithm (Haario et al. 2001) -#' @param startValue vector with the start values for the algorithm. Can be NULL if FUN is of class BayesianSetup. In this case startValues are sampled from the prior. -#' @param iterations iterations to run -#' @param nBI number of burnin -#' @param parmin minimum values for the parameter vector or NULL if FUN is of class BayesianSetup -#' @param parmax maximum values for the parameter vector or NULL if FUN is of class BayesianSetup -#' @param f scaling factor -#' @param FUN function to be sampled from or object of class bayesianSetup -#' @param eps small number to avoid singularity -#' @references Haario, Heikki, Eero Saksman, and Johanna Tamminen. "An adaptive Metropolis algorithm." Bernoulli (2001): 223-242. -#' @keywords internal -# #' @export -AM <- function(startValue = NULL, iterations = 10000, nBI = 0, parmin = NULL, parmax = NULL, FUN, f = 1, eps = 0) { - - if(inherits(FUN, "BayesianSetup")){ - if(FUN$numPars==1) stop("Sampler cannot be started for 1 parameter") - if(is.null(startValue)){ - startValue <- FUN$prior$sampler() - } - parmin <- FUN$prior$lower - parmax <- FUN$prior$upper - FUN <- FUN$posterior$density - } - - - - pValues = startValue - lChain = iterations - - noAdapt <- 1000 - n.iter <- lChain + noAdapt - npar = length(pValues) - pChain <- matrix(NA_real_, nrow = n.iter - nBI, ncol = npar+3) - - #******************************************************************************** - - # First call to the model. Calculate likelihood and prior - postL0 <- FUN(pValues, returnAll = T) - accept.prob <- 0 - - epsDiag <- eps * diag(npar) - scalProp <- f * (2.4^2/npar) - covPar <- scalProp * diag((0.01*(parmax - parmin))^2) - - for (j in 1:n.iter) { - candidatepValues <- as.vector(mvtnorm::rmvnorm(1, pValues, covPar)) - - postL1 <- FUN(candidatepValues, returnAll = T) - - alpha <- min(exp(postL1[1] - postL0[1]), 1) - accept <- 0 - if (runif(1) < alpha) { - postL0 <- postL1 - pValues <- candidatepValues - accept <- 1 - } - - if (j > nBI) { - pChain[j-nBI,] <- c(pValues, postL0) - } - - if (j == (nBI + noAdapt)) { - avePar <- apply(pChain[1:noAdapt,1:npar], 2, mean) - covPar <- scalProp * (cov(pChain[1:noAdapt,1:npar], pChain[1:noAdapt,1:npar]) + epsDiag) - } - if (j > (nBI + noAdapt)) { - accept.prob <- accept.prob + accept - t <- j - nBI - avePar_new <- as.vector(((t-1) * avePar + pValues) / t) - covPar_new <- ((t-2) * covPar + scalProp * ((t-1) * (avePar %o% avePar) - t * (avePar_new %o% avePar_new) + (pValues %o% pValues)) + epsDiag) / (t-1) - avePar <- avePar_new - covPar <- covPar_new - } - } - accept.prob = accept.prob/(lChain-nBI) - list(Draws = pChain[(noAdapt+1):(n.iter-nBI),], accept.prob = accept.prob) -} - - -#' The Delayed Rejection Algorithm -#' @author Francesco Minunno -#' @description The Delayed Rejection Algorithm (Tierney and Mira, 1999) -#' @param startValue vector with the start values for the algorithm. Can be NULL if FUN is of class BayesianSetup. In this case startValues are sampled from the prior. -#' @param iterations iterations to run -#' @param nBI number of burnin -#' @param parmin minimum values for the parameter vector or NULL if FUN is of class BayesianSetup -#' @param parmax maximum values for the parameter vector or NULL if FUN is of class BayesianSetup -#' @param f1 scaling factor for first proposal -#' @param f2 scaling factor for second proposal -#' @param FUN function to be sampled from or object of class bayesianSetup -#' @references Tierney, Luke, and Antonietta Mira. "Some adaptive Monte Carlo methods for Bayesian inference." Statistics in medicine 18.1718 (1999): 2507-2515. -#' @keywords internal -# #' @export -DR <- function(startValue = NULL, iterations = 10000, nBI=0, parmin = NULL, parmax =NULL, f1 = 1, f2= 0.5, FUN) { - - if(inherits(FUN, "BayesianSetup")){ - if(FUN$numPars==1) stop("Sampler cannot be started for 1 parameter") - if(is.null(startValue)){ - startValue <- FUN$prior$sampler() - } - parmin <- FUN$prior$lower - parmax <- FUN$prior$upper - FUN <- FUN$posterior$density - } - - pValues = startValue - lChain = iterations - - npar = length(pValues) - pChain <- matrix(NA_real_, nrow = lChain - nBI, ncol = npar+3) - - #******************************************************************************** - - # First call to the model. Calculate likelihood and prior - postL0 <- FUN(pValues, returnAll = T) - - #******************************************************************************** - # Define Variance-covariance matrix (vcovProp) for proposal generation an - covPar <- diag((0.01 * (parmax - parmin))^2) - sP <- (2.4^2/npar) * c(f1, f2) - accept.prob <- 0 - - for (j in 1:lChain) { - candidatepValues <- mvtnorm::rmvnorm(1, pValues, sP[1] * covPar) - - # Call the model and calculate the likelihood - postL1 <- FUN(candidatepValues, returnAll = T) - - # Check whether the candidates are accepted. If yes and if burn-in has been completed, - alpha1 <- min(exp(postL1[1]-postL0[1]), 1.0) - accept <- 0 - if (runif(1) < alpha1) { - pValues <- candidatepValues - postL0 = postL1 - accept <- 1 - } else { - candidatepValues2 <- mvtnorm::rmvnorm(1, pValues, sP[2] * covPar) - - # Call the model and calculate the likelihood - postL2 <- FUN(candidatepValues2, returnAll = T) - - # Check whether the candidates are accepted. - - alpha2 <- min(exp(postL1[1]-postL2[1]), 1.0) - temp <- mvtnorm::dmvnorm(candidatepValues, candidatepValues2, sP[1] * covPar) / mvtnorm::dmvnorm(candidatepValues, pValues, sP[1] * covPar) - alpha <- min(exp(postL2[1]-postL0[1]) * temp * ((1.0-alpha2)/(1.0-alpha1)), 1.0) - if(is.nan(alpha)) { - alpha <- -1 - } - if (runif(1) < alpha) { - pValues <- candidatepValues2 - postL0 <- postL2 - accept <- 1 - } - } - if (j > nBI) { - pChain[j-nBI,] <- c(pValues, postL0) - accept.prob <- accept.prob + accept - } - } - accept.prob = accept.prob/(lChain-nBI) - list(Draws = pChain, accept.prob = accept.prob) -} - - -#' The Delayed Rejection Adaptive Metropolis Algorithm -#' @author Francesco Minunno -#' @description The Delayed Rejection Adaptive Metropolis Algorithm (Haario et al. 2001) -#' @param startValue vector with the start values for the algorithm. Can be NULL if FUN is of class BayesianSetup. In this case startValues are sampled from the prior. -#' @param iterations iterations to run -#' @param nBI number of burnin -#' @param parmin minimum values for the parameter vector or NULL if FUN is of class BayesianSetup -#' @param parmax maximum values for the parameter vector or NULL if FUN is of class BayesianSetup -#' @param f scaling factor -#' @param FUN function to be sampled from -#' @param eps small number to avoid singularity or object of class bayesianSetup -#' @references Haario, Heikki, Eero Saksman, and Johanna Tamminen. "An adaptive Metropolis algorithm." Bernoulli (2001): 223-242. -#' @keywords internal -# #' @export -DRAM <- function(startValue = NULL, iterations = 10000, nBI = 0, parmin = NULL, parmax = NULL, FUN, f = 1, eps = 0) { - - if(inherits(FUN, "BayesianSetup")){ - if(FUN$numPars==1) stop("Sampler cannot be started for 1 parameter") - if(is.null(startValue)){ - startValue <- FUN$prior$sampler() - } - parmin <- FUN$prior$lower - parmax <- FUN$prior$upper - FUN <- FUN$posterior$density - } - - pValues = startValue - lChain = iterations - - noAdapt <- 1000 - n.iter <- lChain + noAdapt - npar = length(pValues) - pChain <- matrix(NA_real_, nrow = n.iter - nBI, ncol = npar+3) - - #******************************************************************************** - - # First call to the model. Calculate likelihood and prior - postL0 <- FUN(pValues, returnAll = T) - accept.prob <- 0 - - epsDiag <- eps * diag(npar) - scalProp <- f * (2.4^2/npar) - covPar <- scalProp * diag((0.01*(parmax - parmin))^2) - - for (j in 1:n.iter) { - candidatepValues <- as.vector(mvtnorm::rmvnorm(1, pValues, covPar)) - - postL1 <- FUN(candidatepValues, returnAll = T) - - alpha1 <- min(exp(postL1[1] - postL0[1]), 1) - accept <- 0 - if (runif(1) < alpha1) { - postL0 <- postL1 - pValues <- candidatepValues - accept <- 1 - } else { - candidatepValues2 <- as.vector(mvtnorm::rmvnorm(1, pValues, 0.5 * covPar)) - - # Call the model and calculate the likelihood - postL2 <- FUN(candidatepValues2, returnAll = T) - - # Check whether the candidates are accepted. - - alpha2 <- min(exp(postL1[1]-postL2[1]), 1.0) - temp <- mvtnorm::dmvnorm(candidatepValues, candidatepValues2, covPar) / mvtnorm::dmvnorm(candidatepValues, pValues, covPar) - alpha <- min(exp(postL2[1]-postL0[1]) * temp * ((1.0-alpha2)/(1.0-alpha1)), 1.0) - if(is.nan(alpha)) { - alpha <- -1 - } - if (runif(1) < alpha) { - pValues <- candidatepValues2 - postL0 <- postL2 - accept <- 1 - } - } - - if (j > nBI) { - pChain[j-nBI,] <- c(pValues, postL0) - } - - if (j == (nBI + noAdapt)) { - avePar <- apply(pChain[1:noAdapt,1:npar], 2, mean) - covPar <- scalProp * (cov(pChain[1:noAdapt,1:npar], pChain[1:noAdapt,1:npar]) + epsDiag) - } - if (j > (nBI + noAdapt)) { - accept.prob <- accept.prob + accept - t <- j - nBI - avePar_new <- as.vector(((t-1) * avePar + pValues) / t) - covPar_new <- ((t-2) * covPar + scalProp * ((t-1) * (avePar %o% avePar) - t * (avePar_new %o% avePar_new) + (pValues %o% pValues)) + epsDiag) / (t-1) - avePar <- avePar_new - covPar <- covPar_new - } - } - accept.prob = accept.prob/(lChain-nBI) - list(Draws = pChain[(noAdapt+1):(n.iter-nBI),], accept.prob = accept.prob) -} + +#' The Metropolis Algorithm +#' @author Francesco Minunno +#' @description The Metropolis Algorithm (Metropolis et al. 1953) +#' @param startValue vector with the start values for the algorithm. Can be NULL if FUN is of class BayesianSetup. In this case, startValues are sampled from the prior. +#' @param iterations number of iterations to run +#' @param nBI number of burn-in +#' @param parmin minimum values for the parameter vector or NULL if FUN is of class BayesianSetup +#' @param parmax maximum values for the parameter vector or NULL if FUN is of class BayesianSetup +#' @param f scaling factor +#' @param FUN function to be sampled from or object of class bayesianSetup +#' @param consoleUpdates integer, determines the frequency with which sampler progress is printed to the console +#' @references Metropolis, Nicholas, et al. "Equation of state calculations by fast computing machines." The journal of chemical physics 21.6 (1953): 1087-1092. +#' @keywords internal +# #' @export +M <- function(startValue = NULL, iterations = 10000, nBI = 0 , parmin = NULL, parmax= NULL, f = 1, FUN, consoleUpdates=1000) { + + + if(inherits(FUN, "BayesianSetup")){ + if(FUN$numPars==1) stop("Sampler cannot be started for 1 parameter") + + if(is.null(startValue)){ + startValue <- FUN$prior$sampler() + } + parmin <- FUN$prior$lower + parmax <- FUN$prior$upper + FUN <- FUN$posterior$density + } + + + pValues = startValue + lChain = iterations + + npar <- length(pValues) + logMAP <- -Inf + pChain <- matrix(NA_real_, nrow = lChain - nBI, ncol = npar+3) + +#******************************************************************************** + +# First call to the model. Calculate likelihood and prior + postL0 <- FUN(pValues, returnAll = T) + accept.prob <- 0 + +#******************************************************************************** + +# Define Variance-covariance matrix (vcovProp) for proposal generation an + + scalProp <- f * 2.4^2/npar # This f is the scaling factor tuned manually + covPar <- scalProp * diag((0.01 * (parmax - parmin))^2) + +#******************************************************************************** +# Build up the chain. Candidates for the parameter values (candidatepValues) +# are assumed to stem from a multivariate normal distribution (mvrnorm) with mean +# at the current state and covariance given by scalProp*covPar. +#----- + + for (j in 1:lChain) { + if (j%%consoleUpdates == 0) print(c(j,postL1[1])) + candidatepValues <- mvtnorm::rmvnorm(1, pValues, covPar) + + # Call the model and calculate the likelihood + postL1 <- FUN(candidatepValues, returnAll = T) + + # Check whether the candidates are accepted. + alpha <- min(exp(postL1[1] - postL0[1]), 1) + accept <- 0 + if (runif(1) < alpha) { + postL0 <- postL1 + pValues <- candidatepValues + accept <- 1 + if (postL0[1] > logMAP) + { + logMAP <- postL0[1] + psetMAP <- pValues + } + + } + if (j > nBI) { + pChain[j-nBI,] <- c(pValues,postL0) + accept.prob <- accept.prob + accept + } + } + accept.prob <- accept.prob/(lChain-nBI) + list(Draws = pChain, accept.prob = accept.prob,psetMAP=psetMAP) +} + + +#' The Adaptive Metropolis Algorithm +#' @author Francesco Minunno +#' @description The Adaptive Metropolis Algorithm (Haario et al. 2001) +#' @param startValue vector with the start values for the algorithm. Can be NULL if FUN is of class BayesianSetup. In this case startValues are sampled from the prior. +#' @param iterations iterations to run +#' @param nBI number of burnin +#' @param parmin minimum values for the parameter vector or NULL if FUN is of class BayesianSetup +#' @param parmax maximum values for the parameter vector or NULL if FUN is of class BayesianSetup +#' @param f scaling factor +#' @param FUN function to be sampled from or object of class bayesianSetup +#' @param eps small number to avoid singularity +#' @references Haario, Heikki, Eero Saksman, and Johanna Tamminen. "An adaptive Metropolis algorithm." Bernoulli (2001): 223-242. +#' @keywords internal +# #' @export +AM <- function(startValue = NULL, iterations = 10000, nBI = 0, parmin = NULL, parmax = NULL, FUN, f = 1, eps = 0) { + + if(inherits(FUN, "BayesianSetup")){ + if(FUN$numPars==1) stop("Sampler cannot be started for 1 parameter") + if(is.null(startValue)){ + startValue <- FUN$prior$sampler() + } + parmin <- FUN$prior$lower + parmax <- FUN$prior$upper + FUN <- FUN$posterior$density + } + + + + pValues = startValue + lChain = iterations + + noAdapt <- 1000 + n.iter <- lChain + noAdapt + npar = length(pValues) + pChain <- matrix(NA_real_, nrow = n.iter - nBI, ncol = npar+3) + + #******************************************************************************** + + # First call to the model. Calculate likelihood and prior + postL0 <- FUN(pValues, returnAll = T) + accept.prob <- 0 + + epsDiag <- eps * diag(npar) + scalProp <- f * (2.4^2/npar) + covPar <- scalProp * diag((0.01*(parmax - parmin))^2) + + for (j in 1:n.iter) { + candidatepValues <- as.vector(mvtnorm::rmvnorm(1, pValues, covPar)) + + postL1 <- FUN(candidatepValues, returnAll = T) + + alpha <- min(exp(postL1[1] - postL0[1]), 1) + accept <- 0 + if (runif(1) < alpha) { + postL0 <- postL1 + pValues <- candidatepValues + accept <- 1 + } + + if (j > nBI) { + pChain[j-nBI,] <- c(pValues, postL0) + } + + if (j == (nBI + noAdapt)) { + avePar <- apply(pChain[1:noAdapt,1:npar], 2, mean) + covPar <- scalProp * (cov(pChain[1:noAdapt,1:npar], pChain[1:noAdapt,1:npar]) + epsDiag) + } + if (j > (nBI + noAdapt)) { + accept.prob <- accept.prob + accept + t <- j - nBI + avePar_new <- as.vector(((t-1) * avePar + pValues) / t) + covPar_new <- ((t-2) * covPar + scalProp * ((t-1) * (avePar %o% avePar) - t * (avePar_new %o% avePar_new) + (pValues %o% pValues)) + epsDiag) / (t-1) + avePar <- avePar_new + covPar <- covPar_new + } + } + accept.prob = accept.prob/(lChain-nBI) + list(Draws = pChain[(noAdapt+1):(n.iter-nBI),], accept.prob = accept.prob) +} + + +#' The Delayed Rejection Algorithm +#' @author Francesco Minunno +#' @description The Delayed Rejection Algorithm (Tierney and Mira, 1999) +#' @param startValue vector with the start values for the algorithm. Can be NULL if FUN is of class BayesianSetup. In this case startValues are sampled from the prior. +#' @param iterations iterations to run +#' @param nBI number of burnin +#' @param parmin minimum values for the parameter vector or NULL if FUN is of class BayesianSetup +#' @param parmax maximum values for the parameter vector or NULL if FUN is of class BayesianSetup +#' @param f1 scaling factor for first proposal +#' @param f2 scaling factor for second proposal +#' @param FUN function to be sampled from or object of class bayesianSetup +#' @references Tierney, Luke, and Antonietta Mira. "Some adaptive Monte Carlo methods for Bayesian inference." Statistics in medicine 18.1718 (1999): 2507-2515. +#' @keywords internal +# #' @export +DR <- function(startValue = NULL, iterations = 10000, nBI=0, parmin = NULL, parmax =NULL, f1 = 1, f2= 0.5, FUN) { + + if(inherits(FUN, "BayesianSetup")){ + if(FUN$numPars==1) stop("Sampler cannot be started for 1 parameter") + if(is.null(startValue)){ + startValue <- FUN$prior$sampler() + } + parmin <- FUN$prior$lower + parmax <- FUN$prior$upper + FUN <- FUN$posterior$density + } + + pValues = startValue + lChain = iterations + + npar = length(pValues) + pChain <- matrix(NA_real_, nrow = lChain - nBI, ncol = npar+3) + + #******************************************************************************** + + # First call to the model. Calculate likelihood and prior + postL0 <- FUN(pValues, returnAll = T) + + #******************************************************************************** + # Define Variance-covariance matrix (vcovProp) for proposal generation an + covPar <- diag((0.01 * (parmax - parmin))^2) + sP <- (2.4^2/npar) * c(f1, f2) + accept.prob <- 0 + + for (j in 1:lChain) { + candidatepValues <- mvtnorm::rmvnorm(1, pValues, sP[1] * covPar) + + # Call the model and calculate the likelihood + postL1 <- FUN(candidatepValues, returnAll = T) + + # Check whether the candidates are accepted. If yes and if burn-in has been completed, + alpha1 <- min(exp(postL1[1]-postL0[1]), 1.0) + accept <- 0 + if (runif(1) < alpha1) { + pValues <- candidatepValues + postL0 = postL1 + accept <- 1 + } else { + candidatepValues2 <- mvtnorm::rmvnorm(1, pValues, sP[2] * covPar) + + # Call the model and calculate the likelihood + postL2 <- FUN(candidatepValues2, returnAll = T) + + # Check whether the candidates are accepted. + + alpha2 <- min(exp(postL1[1]-postL2[1]), 1.0) + temp <- mvtnorm::dmvnorm(candidatepValues, candidatepValues2, sP[1] * covPar) / mvtnorm::dmvnorm(candidatepValues, pValues, sP[1] * covPar) + alpha <- min(exp(postL2[1]-postL0[1]) * temp * ((1.0-alpha2)/(1.0-alpha1)), 1.0) + if(is.nan(alpha)) { + alpha <- -1 + } + if (runif(1) < alpha) { + pValues <- candidatepValues2 + postL0 <- postL2 + accept <- 1 + } + } + if (j > nBI) { + pChain[j-nBI,] <- c(pValues, postL0) + accept.prob <- accept.prob + accept + } + } + accept.prob = accept.prob/(lChain-nBI) + list(Draws = pChain, accept.prob = accept.prob) +} + + +#' The Delayed Rejection Adaptive Metropolis Algorithm +#' @author Francesco Minunno +#' @description The Delayed Rejection Adaptive Metropolis Algorithm (Haario et al. 2001) +#' @param startValue vector with the start values for the algorithm. Can be NULL if FUN is of class BayesianSetup. In this case startValues are sampled from the prior. +#' @param iterations iterations to run +#' @param nBI number of burnin +#' @param parmin minimum values for the parameter vector or NULL if FUN is of class BayesianSetup +#' @param parmax maximum values for the parameter vector or NULL if FUN is of class BayesianSetup +#' @param f scaling factor +#' @param FUN function to be sampled from +#' @param eps small number to avoid singularity or object of class bayesianSetup +#' @references Haario, Heikki, Eero Saksman, and Johanna Tamminen. "An adaptive Metropolis algorithm." Bernoulli (2001): 223-242. +#' @keywords internal +# #' @export +DRAM <- function(startValue = NULL, iterations = 10000, nBI = 0, parmin = NULL, parmax = NULL, FUN, f = 1, eps = 0) { + + if(inherits(FUN, "BayesianSetup")){ + if(FUN$numPars==1) stop("Sampler cannot be started for 1 parameter") + if(is.null(startValue)){ + startValue <- FUN$prior$sampler() + } + parmin <- FUN$prior$lower + parmax <- FUN$prior$upper + FUN <- FUN$posterior$density + } + + pValues = startValue + lChain = iterations + + noAdapt <- 1000 + n.iter <- lChain + noAdapt + npar = length(pValues) + pChain <- matrix(NA_real_, nrow = n.iter - nBI, ncol = npar+3) + + #******************************************************************************** + + # First call to the model. Calculate likelihood and prior + postL0 <- FUN(pValues, returnAll = T) + accept.prob <- 0 + + epsDiag <- eps * diag(npar) + scalProp <- f * (2.4^2/npar) + covPar <- scalProp * diag((0.01*(parmax - parmin))^2) + + for (j in 1:n.iter) { + candidatepValues <- as.vector(mvtnorm::rmvnorm(1, pValues, covPar)) + + postL1 <- FUN(candidatepValues, returnAll = T) + + alpha1 <- min(exp(postL1[1] - postL0[1]), 1) + accept <- 0 + if (runif(1) < alpha1) { + postL0 <- postL1 + pValues <- candidatepValues + accept <- 1 + } else { + candidatepValues2 <- as.vector(mvtnorm::rmvnorm(1, pValues, 0.5 * covPar)) + + # Call the model and calculate the likelihood + postL2 <- FUN(candidatepValues2, returnAll = T) + + # Check whether the candidates are accepted. + + alpha2 <- min(exp(postL1[1]-postL2[1]), 1.0) + temp <- mvtnorm::dmvnorm(candidatepValues, candidatepValues2, covPar) / mvtnorm::dmvnorm(candidatepValues, pValues, covPar) + alpha <- min(exp(postL2[1]-postL0[1]) * temp * ((1.0-alpha2)/(1.0-alpha1)), 1.0) + if(is.nan(alpha)) { + alpha <- -1 + } + if (runif(1) < alpha) { + pValues <- candidatepValues2 + postL0 <- postL2 + accept <- 1 + } + } + + if (j > nBI) { + pChain[j-nBI,] <- c(pValues, postL0) + } + + if (j == (nBI + noAdapt)) { + avePar <- apply(pChain[1:noAdapt,1:npar], 2, mean) + covPar <- scalProp * (cov(pChain[1:noAdapt,1:npar], pChain[1:noAdapt,1:npar]) + epsDiag) + } + if (j > (nBI + noAdapt)) { + accept.prob <- accept.prob + accept + t <- j - nBI + avePar_new <- as.vector(((t-1) * avePar + pValues) / t) + covPar_new <- ((t-2) * covPar + scalProp * ((t-1) * (avePar %o% avePar) - t * (avePar_new %o% avePar_new) + (pValues %o% pValues)) + epsDiag) / (t-1) + avePar <- avePar_new + covPar <- covPar_new + } + } + accept.prob = accept.prob/(lChain-nBI) + list(Draws = pChain[(noAdapt+1):(n.iter-nBI),], accept.prob = accept.prob) +} diff --git a/BayesianTools/R/mcmcMetropolis.R b/BayesianTools/R/mcmcMetropolis.R index 9a6c681..d98a06e 100644 --- a/BayesianTools/R/mcmcMetropolis.R +++ b/BayesianTools/R/mcmcMetropolis.R @@ -1,196 +1,197 @@ -#' Creates a Metropolis-type MCMC with options for covariance adaptatin, delayed rejection, Metropolis-within-Gibbs, and tempering -#' @author Florian Hartig -#' @param bayesianSetup either an object of class bayesianSetup created by \code{\link{createBayesianSetup}} (recommended), or a log target function -#' @param settings a list of settings - possible options follow -#' @param startValue startValue for the MCMC and optimization (if optimize = T). If not provided, the sampler will attempt to obtain the startValue from the bayesianSetup -#' @param optimize logical, determines whether an optimization for start values and proposal function should be run before starting the sampling -#' @param proposalGenerator optional, proposalgenerator object (see \code{\link{createProposalGenerator}}) -#' @param proposalScaling additional scaling parameter for the proposals that controls the different scales of the proposals after delayed rejection (typical, after a rejection, one would want to try a smaller scale). Needs to be as long as DRlevels. Defaults to 0.5^(- 0:(mcmcSampler$settings$DRlevels -1) -#' @param burnin number of iterations treated as burn-in. These iterations are not recorded in the chain. -#' @param thin thinning parameter. Determines the interval in which values are recorded. -#' @param consoleUpdates integer, determines the frequency with which sampler progress is printed to the console -#' @param adapt logical, determines whether an adaptive algorithm should be implemented. Default is TRUE. -#' @param adaptationInterval integer, determines the interval of the adaption if adapt = TRUE. -#' @param adaptationNotBefore integer, determines the start value for the adaption if adapt = TRUE. -#' @param DRlevels integer, determines the number of levels for a delayed rejection sampler. Default is 1, which means no delayed rejection is used. -#' @param temperingFunction function to implement simulated tempering in the algorithm. The function describes how the acceptance rate will be influenced in the course of the iterations. -#' @param gibbsProbabilities vector that defines the relative probabilities of the number of parameters to be changed simultaneously. -#' @param message logical, determines whether the sampler's progress should be printed -#' @details The 'Metropolis' function is the main function for all Metropolis based samplers in this package. To call the derivatives from the basic Metropolis-Hastings MCMC, you can either use the corresponding function (e.g. \code{\link{AM}} for an adaptive Metropolis sampler) or use the parameters to adapt the basic Metropolis-Hastings. The advantage of the latter case is that you can easily combine different properties (e.g. adapive sampling and delayed rejection sampling) without changing the function. -#' @import coda -#' @example /inst/examples/MetropolisHelp.R -#' @export -#' @references Haario, H., E. Saksman, and J. Tamminen (2001). An adaptive metropolis algorithm. Bernoulli , 223-242. -#' @references Haario, Heikki, et al. "DRAM: efficient adaptive MCMC." Statistics and Computing 16.4 (2006): 339-354. -#' @references Hastings, W. K. (1970). Monte carlo sampling methods using markov chains and their applications. Biometrika 57 (1), 97-109. -#' @references Green, Peter J., and Antonietta Mira. "Delayed rejection in reversible jump Metropolis-Hastings." Biometrika (2001): 1035-1053. -#' @references Metropolis, N., A. W. Rosenbluth, M. N. Rosenbluth, A. H. Teller, and E. Teller (1953). Equation of state calculations by fast computing machines. The journal of chemical physics 21 (6), 1087 - 1092. -Metropolis <- function(bayesianSetup, - settings = list(startValue = NULL, - optimize = T, - proposalGenerator = NULL, - consoleUpdates=100, - burnin = 0, - thin = 1, - parallel = NULL, - adapt = T, - adaptationInterval= 500, - adaptationNotBefore = 3000, - DRlevels = 1 , - proposalScaling = NULL, - adaptationDepth = NULL, - temperingFunction = NULL, - gibbsProbabilities = NULL, - message = TRUE - )){ - - ## General setup - this template should be similar for all MCMC algorithms - - setup <- checkBayesianSetup(bayesianSetup, parallel = settings$parallel) # calling parallel will check if requested parallelization in settings is provided by the BayesianSetup - if(is.null(settings$parallel)) settings$parallel = bayesianSetup$parallel # checking back - if no parallelization is provided, we use the parallelization in the BayesianSetup. We could also set parallel = F, but I feel it makes more sense to use the Bayesiansetup as default - - settings = applySettingsDefault(settings, sampler = "Metropolis") - - if(is.null(settings$startValue)){ - settings$startValue = bayesianSetup$prior$sampler() - } - if(is.function(settings$startValue)){ - settings$startValue = settings$startValue() - } - - ## Parameter consistency checks - - if(is.null(settings$adaptationDepth)){ - settings$adaptationDepth = settings$adaptationNotBefore - } - - # Decreasing scaling for DRAM by default - if (is.null(settings$proposalScaling)) settings$proposalScaling = 0.5^(- 0:(settings$DRlevels -1)) - - tmp <- setupStartProposal(proposalGenerator = settings$proposalGenerator, bayesianSetup = bayesianSetup, settings = settings) - settings = tmp$settings - proposalGenerator = tmp$proposalGenerator - - ####### CREATE CHAIN - - chain = array(dim = c(1,bayesianSetup$numPars+3)) - chain[1,1:bayesianSetup$numPars] = settings$startValue - colnames(chain) = c(1:bayesianSetup$numPars, "LP", "LL", "LPr") - chain[1, (bayesianSetup$numPars+1):(bayesianSetup$numPars+3)] = setup$posterior$density(settings$startValue, returnAll = T) - - current = settings$startValue - currentLP = as.numeric(chain[1, (bayesianSetup$numPars+1)]) - - ##### Sampling - - classFields = list( - setup = setup, - settings = settings, - current = current, - currentLP = currentLP, - chain = chain, - proposalGenerator = proposalGenerator, - funEvals = 0, - acceptanceRate = 0 - ) - - class(classFields) <- c("mcmcSampler", "bayesianOutput") - return(classFields) -} - - -#' gets samples while adopting the MCMC proposal generator -#' @author Florian Hartig -#' @param mcmcSampler an mcmcSampler -#' @param iterations iterations -#' @description Function to sample with cobinations of the basic Metropolis-Hastings MCMC algorithm (Metropolis et al., 1953), a variation of the adaptive Metropolis MCMC (Haario et al., 2001), the delayed rejection algorithm (Tierney & Mira, 1999), and the delayed rejection adaptive Metropolis algorithm (DRAM, Haario et al), and the Metropolis within Gibbs -#' @export -#' @keywords internal -sampleMetropolis <- function(mcmcSampler, iterations){ - - burnin <- mcmcSampler$settings$burnin - thin <- mcmcSampler$settings$thin - - CounterFunEvals = mcmcSampler$funEvals - CounterAccept = nrow(mcmcSampler$chain)*mcmcSampler$acceptanceRate - - if (mcmcSampler$settings$DRlevels > 2) stop("DRlevels > 2 currently not implemented") - - # Increase chain - lastvalue = nrow(mcmcSampler$chain) - mcmcSampler$chain = rbind(mcmcSampler$chain, array(dim = c(floor((iterations-burnin)/thin),mcmcSampler$setup$numPars+3))) - - alpha = rep(NA, mcmcSampler$settings$DRlevels) - proposalEval = matrix( nrow = mcmcSampler$settings$DRlevels, ncol = 3) - proposal = matrix( nrow = mcmcSampler$settings$DRlevels, ncol = mcmcSampler$setup$numPars) - - # Initialize counter for chain update - counter <- lastvalue - - for (i in lastvalue:(lastvalue+iterations-1)){ - - accepted = F - - if(is.null(mcmcSampler$settings$temperingFunction)) tempering = 1 else tempering = mcmcSampler$settings$temperingFunction(i) - - if(tempering < 1) warning("Tempering option < 1. This usually doesn't make sense!") - - for (j in 1:mcmcSampler$settings$DRlevels){ - - proposal[j,] = mcmcSampler$proposalGenerator$returnProposal(x = mcmcSampler$current, scale = mcmcSampler$settings$proposalScaling[j]) - proposalEval[j,] <- mcmcSampler$setup$posterior$density(proposal[j,], returnAll = T) - CounterFunEvals <- CounterFunEvals+1 - - # case j = 1 (normal MH-MCMC) - if (j == 1){ - alpha[j] = metropolisRatio(proposalEval[j,1], mcmcSampler$currentLP, tempering) - jumpProbab = alpha[1] - # case j = 2 (first delayed rejection) - } else if (j == 2 & alpha[j-1] > 0 ){ - alpha[j] = metropolisRatio(proposalEval[j,1], proposalEval[j-1,1], tempering) - - temp <- metropolisRatio(mcmcSampler$proposalGenerator$returnDensity(proposal[1,], proposal[2,]), mcmcSampler$proposalGenerator$returnDensity(mcmcSampler$current, proposal[1,])) - - jumpProbab = metropolisRatio(proposalEval[j,1], mcmcSampler$currentLP, tempering) * temp * (1.0-alpha[j]) / (1.0-alpha[j-1]) - } - - if (runif(1) < jumpProbab){ - accepted = T - mcmcSampler$current = proposal[j,] - mcmcSampler$currentLP = proposalEval[j,1] - if((i > (lastvalue+burnin)) && (i %% thin == 0) ){ - counter <- counter+1 - mcmcSampler$chain[counter,] = c(proposal[j,], proposalEval[j,]) - } - break - } - } - if((accepted == F) && (i > (lastvalue+burnin)) && (i %% thin == 0)){ - counter <- counter +1 - mcmcSampler$chain[counter,] = mcmcSampler$chain[counter-1,] - } - if(accepted == T) CounterAccept <- CounterAccept+1 - - # Proposal update - - if(mcmcSampler$settings$adapt == T & i > mcmcSampler$settings$adaptationNotBefore & i %% mcmcSampler$settings$adaptationInterval == 0 ){ - start = max(1, counter - mcmcSampler$settings$adaptationDepth) - mcmcSampler$proposalGenerator = updateProposalGenerator(proposal = mcmcSampler$proposalGenerator, chain = mcmcSampler$chain[start:counter,1:mcmcSampler$setup$numPars], message = F) - } - - # Console update - - if(mcmcSampler$settings$message){ - if( i %% mcmcSampler$settings$consoleUpdates == 0 ) cat("\r","Running Metropolis-MCMC, chain ", - mcmcSampler$settings$currentChain, "iteration" ,i,"of",iterations, - ". Current logp: ", mcmcSampler$chain[counter,mcmcSampler$setup$numPars+1]," Please wait!","\r") - flush.console() - } - } - - # Make sure chain has right size TODO - why is this neccessary - mcmcSampler$chain <- mcmcSampler$chain[1:counter,] - mcmcSampler$funEvals <- CounterFunEvals - mcmcSampler$acceptanceRate <- CounterAccept/CounterFunEvals - return(mcmcSampler) +#' Creates a Metropolis-type MCMC with options for covariance adaptatin, delayed rejection, Metropolis-within-Gibbs, and tempering +#' @author Florian Hartig +#' @param bayesianSetup either an object of class bayesianSetup created by \code{\link{createBayesianSetup}} (recommended), or a log target function +#' @param settings a list of settings - possible options follow +#' @param startValue startValue for the MCMC and optimization (if optimize = T). If not provided, the sampler will attempt to obtain the startValue from the bayesianSetup +#' @param optimize logical, determines whether an optimization for start values and proposal function should be run before starting the sampling +#' @param proposalGenerator optional, proposalgenerator object (see \code{\link{createProposalGenerator}}) +#' @param proposalScaling additional scaling parameter for the proposals that controls the different scales of the proposals after delayed rejection (typical, after a rejection, one would want to try a smaller scale). Needs to be as long as DRlevels. Defaults to 0.5^(- 0:(mcmcSampler$settings$DRlevels -1) +#' @param burnin number of iterations treated as burn-in. These iterations are not recorded in the chain. +#' @param thin thinning parameter. Determines the interval in which values are recorded. +#' @param consoleUpdates integer, determines the frequency with which sampler progress is printed to the console +#' @param adapt logical, determines whether an adaptive algorithm should be implemented. Default is TRUE. +#' @param adaptationInterval integer, determines the interval of the adaption if adapt = TRUE. +#' @param adaptationNotBefore integer, determines the start value for the adaption if adapt = TRUE. +#' @param DRlevels integer, determines the number of levels for a delayed rejection sampler. Default is 1, which means no delayed rejection is used. +#' @param temperingFunction function to implement simulated tempering in the algorithm. The function describes how the acceptance rate will be influenced in the course of the iterations. +#' @param gibbsProbabilities vector that defines the relative probabilities of the number of parameters to be changed simultaneously. +#' @param message logical, determines whether the sampler's progress should be printed +#' @details The 'Metropolis' function is the main function for all Metropolis based samplers in this package. To call the derivatives from the basic Metropolis-Hastings MCMC, you can either use the corresponding function (e.g. \code{\link{AM}} for an adaptive Metropolis sampler) or use the parameters to adapt the basic Metropolis-Hastings. The advantage of the latter case is that you can easily combine different properties (e.g. adapive sampling and delayed rejection sampling) without changing the function. +#' @import coda +#' @example /inst/examples/MetropolisHelp.R +#' @export +#' @references Haario, H., E. Saksman, and J. Tamminen (2001). An adaptive metropolis algorithm. Bernoulli , 223-242. +#' @references Haario, Heikki, et al. "DRAM: efficient adaptive MCMC." Statistics and Computing 16.4 (2006): 339-354. +#' @references Hastings, W. K. (1970). Monte carlo sampling methods using markov chains and their applications. Biometrika 57 (1), 97-109. +#' @references Green, Peter J., and Antonietta Mira. "Delayed rejection in reversible jump Metropolis-Hastings." Biometrika (2001): 1035-1053. +#' @references Metropolis, N., A. W. Rosenbluth, M. N. Rosenbluth, A. H. Teller, and E. Teller (1953). Equation of state calculations by fast computing machines. The journal of chemical physics 21 (6), 1087 - 1092. + +Metropolis <- function(bayesianSetup, + settings = list(startValue = NULL, + optimize = T, + proposalGenerator = NULL, + consoleUpdates=100, + burnin = 0, + thin = 1, + parallel = NULL, + adapt = T, + adaptationInterval= 500, + adaptationNotBefore = 3000, + DRlevels = 1 , + proposalScaling = NULL, + adaptationDepth = NULL, + temperingFunction = NULL, + gibbsProbabilities = NULL, + message = TRUE + )){ + + ## General setup - this template should be similar for all MCMC algorithms + + setup <- checkBayesianSetup(bayesianSetup, parallel = settings$parallel) # calling parallel will check if requested parallelization in settings is provided by the BayesianSetup + if(is.null(settings$parallel)) settings$parallel = bayesianSetup$parallel # checking back - if no parallelization is provided, we use the parallelization in the BayesianSetup. We could also set parallel = F, but I feel it makes more sense to use the Bayesiansetup as default + + settings = applySettingsDefault(settings, sampler = "Metropolis") + + if(is.null(settings$startValue)){ + settings$startValue = bayesianSetup$prior$sampler() + } + if(is.function(settings$startValue)){ + settings$startValue = settings$startValue() + } + + ## Parameter consistency checks + + if(is.null(settings$adaptationDepth)){ + settings$adaptationDepth = settings$adaptationNotBefore + } + + # Decreasing scaling for DRAM by default + if (is.null(settings$proposalScaling)) settings$proposalScaling = 0.5^(- 0:(settings$DRlevels -1)) + + tmp <- setupStartProposal(proposalGenerator = settings$proposalGenerator, bayesianSetup = bayesianSetup, settings = settings) + settings = tmp$settings + proposalGenerator = tmp$proposalGenerator + + ####### CREATE CHAIN + + chain = array(dim = c(1,bayesianSetup$numPars+3)) + chain[1,1:bayesianSetup$numPars] = settings$startValue + colnames(chain) = c(1:bayesianSetup$numPars, "LP", "LL", "LPr") + chain[1, (bayesianSetup$numPars+1):(bayesianSetup$numPars+3)] = setup$posterior$density(settings$startValue, returnAll = T) + + current = settings$startValue + currentLP = as.numeric(chain[1, (bayesianSetup$numPars+1)]) + + ##### Sampling + + classFields = list( + setup = setup, + settings = settings, + current = current, + currentLP = currentLP, + chain = chain, + proposalGenerator = proposalGenerator, + funEvals = 0, + acceptanceRate = 0 + ) + + class(classFields) <- c("mcmcSampler", "bayesianOutput") + return(classFields) +} + + +#' gets samples while adopting the MCMC proposal generator +#' @author Florian Hartig +#' @param mcmcSampler an mcmcSampler +#' @param iterations iterations +#' @description Function to sample with cobinations of the basic Metropolis-Hastings MCMC algorithm (Metropolis et al., 1953), a variation of the adaptive Metropolis MCMC (Haario et al., 2001), the delayed rejection algorithm (Tierney & Mira, 1999), and the delayed rejection adaptive Metropolis algorithm (DRAM, Haario et al), and the Metropolis within Gibbs +#' @export +#' @keywords internal +sampleMetropolis <- function(mcmcSampler, iterations){ + + burnin <- mcmcSampler$settings$burnin + thin <- mcmcSampler$settings$thin + + CounterFunEvals = mcmcSampler$funEvals + CounterAccept = nrow(mcmcSampler$chain)*mcmcSampler$acceptanceRate + + if (mcmcSampler$settings$DRlevels > 2) stop("DRlevels > 2 currently not implemented") + + # Increase chain + lastvalue = nrow(mcmcSampler$chain) + mcmcSampler$chain = rbind(mcmcSampler$chain, array(dim = c(floor((iterations-burnin)/thin),mcmcSampler$setup$numPars+3))) + + alpha = rep(NA, mcmcSampler$settings$DRlevels) + proposalEval = matrix( nrow = mcmcSampler$settings$DRlevels, ncol = 3) + proposal = matrix( nrow = mcmcSampler$settings$DRlevels, ncol = mcmcSampler$setup$numPars) + + # Initialize counter for chain update + counter <- lastvalue + + for (i in lastvalue:(lastvalue+iterations-1)){ + + accepted = F + + if(is.null(mcmcSampler$settings$temperingFunction)) tempering = 1 else tempering = mcmcSampler$settings$temperingFunction(i) + + if(tempering < 1) warning("Tempering option < 1. This usually doesn't make sense!") + + for (j in 1:mcmcSampler$settings$DRlevels){ + + proposal[j,] = mcmcSampler$proposalGenerator$returnProposal(x = mcmcSampler$current, scale = mcmcSampler$settings$proposalScaling[j]) + proposalEval[j,] <- mcmcSampler$setup$posterior$density(proposal[j,], returnAll = T) + CounterFunEvals <- CounterFunEvals+1 + + # case j = 1 (normal MH-MCMC) + if (j == 1){ + alpha[j] = metropolisRatio(proposalEval[j,1], mcmcSampler$currentLP, tempering) + jumpProbab = alpha[1] + # case j = 2 (first delayed rejection) + } else if (j == 2 & alpha[j-1] > 0 ){ + alpha[j] = metropolisRatio(proposalEval[j,1], proposalEval[j-1,1], tempering) + + temp <- metropolisRatio(mcmcSampler$proposalGenerator$returnDensity(proposal[1,], proposal[2,]), mcmcSampler$proposalGenerator$returnDensity(mcmcSampler$current, proposal[1,])) + + jumpProbab = metropolisRatio(proposalEval[j,1], mcmcSampler$currentLP, tempering) * temp * (1.0-alpha[j]) / (1.0-alpha[j-1]) + } + + if (runif(1) < jumpProbab){ + accepted = T + mcmcSampler$current = proposal[j,] + mcmcSampler$currentLP = proposalEval[j,1] + if((i > (lastvalue+burnin)) && (i %% thin == 0) ){ + counter <- counter+1 + mcmcSampler$chain[counter,] = c(proposal[j,], proposalEval[j,]) + } + break + } + } + if((accepted == F) && (i > (lastvalue+burnin)) && (i %% thin == 0)){ + counter <- counter +1 + mcmcSampler$chain[counter,] = mcmcSampler$chain[counter-1,] + } + if(accepted == T) CounterAccept <- CounterAccept+1 + + # Proposal update + + if(mcmcSampler$settings$adapt == T & i > mcmcSampler$settings$adaptationNotBefore & i %% mcmcSampler$settings$adaptationInterval == 0 ){ + start = max(1, counter - mcmcSampler$settings$adaptationDepth) + mcmcSampler$proposalGenerator = updateProposalGenerator(proposal = mcmcSampler$proposalGenerator, chain = mcmcSampler$chain[start:counter,1:mcmcSampler$setup$numPars], message = F) + } + + # Console update + + if(mcmcSampler$settings$message){ + if( i %% mcmcSampler$settings$consoleUpdates == 0 ) cat("\r","Running Metropolis-MCMC, chain ", + mcmcSampler$settings$currentChain, "iteration" ,i,"of",iterations, + ". Current logp: ", mcmcSampler$chain[counter,mcmcSampler$setup$numPars+1]," Please wait!","\r") + flush.console() + } + } + + # Make sure chain has right size TODO - why is this neccessary + mcmcSampler$chain <- mcmcSampler$chain[1:counter,] + mcmcSampler$funEvals <- CounterFunEvals + mcmcSampler$acceptanceRate <- CounterAccept/CounterFunEvals + return(mcmcSampler) } \ No newline at end of file diff --git a/BayesianTools/R/mcmcMultipleChains.R b/BayesianTools/R/mcmcMultipleChains.R index 4d0cd7d..1ebdfc2 100644 --- a/BayesianTools/R/mcmcMultipleChains.R +++ b/BayesianTools/R/mcmcMultipleChains.R @@ -1,39 +1,40 @@ -#' Run multiple chains -#' @param bayesianSetup object of class "BayesianSetup" -#' @param settings list with settings for sampler -#' @param sampler character, either "Metropolis" or "DE" -#' @return list containing the single runs ($sampler) and the chains in a coda::mcmc.list ($mcmc.list) -#' @keywords internal -mcmcMultipleChains <- function(bayesianSetup, settings, sampler) { - # Get number of chains - nrChains <- settings$nrChains - - # Set settings$nrChains to one to avoid infinite loop - settings$nrChains <- 1 - - # Initialize output - out <- list() - out$sampler <- list() - - # Run sampler - for (i in 1:nrChains) { - out$sampler[[i]] <- - runMCMC(bayesianSetup, sampler = sampler, settings = settings) - } - - - # Make coda::mcmc.list object - for (i in 1:nrChains) { - txtemp <- paste("coda::mcmc(out$sampler[[", i, "]]$chain)", sep = "") - if (i == 1) - tx = txtemp - else - tx <- paste(tx, txtemp, sep = ", ") - } - - tx <- paste("coda::mcmc.list(", tx, ")", sep = "") - out$mcmc.list <- eval(parse(text = tx)) - - - return(out) -} + +#' Run multiple chains +#' @param bayesianSetup object of class "BayesianSetup" +#' @param settings list with settings for sampler +#' @param sampler character, either "Metropolis" or "DE" +#' @return list containing the single runs ($sampler) and the chains in a coda::mcmc.list ($mcmc.list) +#' @keywords internal +mcmcMultipleChains <- function(bayesianSetup, settings, sampler) { + # Get number of chains + nrChains <- settings$nrChains + + # Set settings$nrChains to one to avoid infinite loop + settings$nrChains <- 1 + + # Initialize output + out <- list() + out$sampler <- list() + + # Run sampler + for (i in 1:nrChains) { + out$sampler[[i]] <- + runMCMC(bayesianSetup, sampler = sampler, settings = settings) + } + + + # Make coda::mcmc.list object + for (i in 1:nrChains) { + txtemp <- paste("coda::mcmc(out$sampler[[", i, "]]$chain)", sep = "") + if (i == 1) + tx = txtemp + else + tx <- paste(tx, txtemp, sep = ", ") + } + + tx <- paste("coda::mcmc.list(", tx, ")", sep = "") + out$mcmc.list <- eval(parse(text = tx)) + + + return(out) +} diff --git a/BayesianTools/R/mcmcRun.R b/BayesianTools/R/mcmcRun.R index c653615..6b38a63 100644 --- a/BayesianTools/R/mcmcRun.R +++ b/BayesianTools/R/mcmcRun.R @@ -1,523 +1,524 @@ -#' Main wrapper function to start MCMCs, particle MCMCs and SMCs -#' @author Florian Hartig -#' @param bayesianSetup either a BayesianSetup (see \code{\link{createBayesianSetup}}), a function, or a BayesianOutput created by runMCMC. The latter allows to continue a previous MCMC run. See details for how to restart a sampler. -#' @param sampler sampling algorithm to be run. Default is DEzs. Options are "Metropolis", "AM", "DR", "DRAM", "DE", "DEzs", "DREAM", "DREAMzs", "SMC". For details see the help of the individual functions. -#' @param settings list with settings for each sampler. If a setting is not provided, defaults (see \code{\link{applySettingsDefault}}) will be used. -#' @details The runMCMC function can be started with either one of -#' -#' 1. an object of class BayesianSetup with prior and likelihood function (created with \code{\link{createBayesianSetup}}). check if appropriate parallelization options are used - many samplers can make use of parallelization if this option is activated when the class is created. -#' 2. a log posterior or other target function, -#' 3. an object of class BayesianOutput created by runMCMC. The latter allows to continue a previous MCMC run. -#' -#' Settings for the sampler are provides as a list. You can see the default values by running \code{\link{applySettingsDefault}} with the respective sampler name. The following settings can be used for all MCMCs: -#' -#' * startValue (no default) start values for the MCMC. Note that DE family samplers require a matrix of start values. If startvalues are not provided, they are sampled from the prior. -#' * iterations (10000) the MCMC iterations -#' * burnin (0) burnin -#' * thin (1) thinning while sampling -#' * consoleUpdates (100) update frequency for console updates -#' * parallel (NULL) whether parallelization is to be used -#' * message (TRUE) if progress messages are to be printed -#' * nrChains (1) the number of independent MCMC chains to be run. Note that this is not controlling the internal number of chains in population MCMCs such as DE, so if you run nrChains = 3 with a DEzs startValue that is a 4xparameter matrix (= 4 internal chains), you will run independent DEzs runs with 4 internal chains each. -#' -#' The MCMC samplers will have a number of additional settings, which are described in the Vignette (run vignette("BayesianTools", package="BayesianTools") and in the help of the samplers. See \code{\link{Metropolis}} for Metropolis based samplers, \code{\link{DE}} and \code{\link{DEzs}} for standard differential evolution samplers, \code{\link{DREAM}} and \code{\link{DREAMzs}} for DREAM sampler, \code{\link{Twalk}} for the Twalk sampler, and \code{\link{smcSampler}} for rejection and Sequential Monte Carlo sampling. Note that the samplers "AM", "DR", and "DRAM" are special cases of the "Metropolis" sampler and are shortcuts for predefined settings ("AM": adapt=TRUE; "DR": DRlevels=2; "DRAM": adapt=True, DRlevels=2). -#' -#' Note that even if you specify parallel = T, this will only turn on internal parallelization of the samplers. The independent samplers controlled by nrChains are not evaluated in parallel, so if time is an issue it will be better to run the MCMCs individually and then combine them via \code{\link{createMcmcSamplerList}} into one joint object. -#' -#' Note that, DE and DREAM variants as well as SMC and T-walk require a population to start, which should be provided as a matrix. Default (NULL) sets the population size for DE to 3 x dimensions of parameters, for DREAM to 2 x dimensions of parameters and for DEzs and DREAMzs to three, sampled from the prior. Note also that the zs variants of DE and DREAM require two populations, the current population and the z matrix (a kind of memory) - if you want to set both, provide a list with startvalue$X and startvalue$Z. -#' -#' setting startValue for sampling with nrChains > 1 : if you want to provide different start values for the different chains, provide them as a list -#' -#' @return The function returns an object of class mcmcSampler (if one chain is run) or mcmcSamplerList. Both have the superclass bayesianOutput. It is possible to extract the samples as a coda object or matrix with \code{\link{getSample}}. -#' It is also possible to summarize the posterior as a new prior via \code{\link{createPriorDensity}}. -#' @example /inst/examples/mcmcRun.R -#' @seealso \code{\link{createBayesianSetup}} -#' @export -runMCMC <- function(bayesianSetup , sampler = "DEzs", settings = NULL){ - - options(warn = 0) - - ptm <- proc.time() - - ####### RESTART ########## - - if("bayesianOutput" %in% class(bayesianSetup)){ - - # TODO - the next statements should have assertions in case someone overwrites the existing setting or similar - - previousMcmcSampler <- bayesianSetup - - - # Catch the settings in case of nrChains > 1 - if(!("mcmcSamplerList" %in% class(previousMcmcSampler) | "smcSamplerList" %in% class(previousMcmcSampler) )){ - if(is.null(settings)) settings <- previousMcmcSampler$settings - setup <- previousMcmcSampler$setup - sampler <- previousMcmcSampler$settings$sampler - previousSettings <- previousMcmcSampler$settings - } else{ - if(is.null(settings)) settings <- previousMcmcSampler[[1]]$settings - settings$nrChains <- length(previousMcmcSampler) - setup <- previousMcmcSampler[[1]]$setup - sampler <- previousMcmcSampler[[1]]$settings$sampler - previousSettings <- previousMcmcSampler[[1]]$settings - } - - # Set settings$sampler (only needed if new settings are supplied) - settings$sampler <- sampler - - # overwrite new settings - for(name in names(settings)) previousSettings[[name]] <- settings[[name]] - - settings <- previousSettings - - # Check if previous settings will be new default - - previousMcmcSampler$settings <- applySettingsDefault(settings = settings, sampler = settings$sampler, check = TRUE) - - restart <- TRUE - - - ## NOT RESTART STARTS HERE ################### - - }else if(inherits(bayesianSetup, "BayesianSetup")){ - restart <- FALSE - - if(is.null(settings$parallel)) settings$parallel <- bayesianSetup$parallel - if(is.numeric(settings$parallel)) settings$parallel <- TRUE - - setup <- checkBayesianSetup(bayesianSetup, parallel = settings$parallel) - settings <- applySettingsDefault(settings = settings, sampler = sampler, check = TRUE) - } else stop("runMCMC requires a class of type BayesianOutput or BayesianSetup") - - ###### END RESTART ############## - - - # TODO - the following statement should be removed once all further functions access settings$sampler instead of sampler - # At the moment only the same sampler can be used to restart sampling. - sampler = settings$sampler - - #### Assertions - if(!restart && setup$numPars == 1) if(!getPossibleSamplerTypes()$univariate[which(getPossibleSamplerTypes()$BTname == settings$sampler)]) stop("This sampler can not be applied to a univariate distribution") - - if(restart == T) if(!getPossibleSamplerTypes()$restartable[which(getPossibleSamplerTypes()$BTname == settings$sampler)]) stop("This sampler can not be restarted") - - ########### Recursive call in case multiple chains are to be run - if(settings$nrChains >1){ - - # Initialize output list - out<- list() - - # Run several samplers - for(i in 1:settings$nrChains){ - - settingsTemp <- settings - settingsTemp$nrChains <- 1 # avoid infinite loop - settingsTemp$currentChain <- i - - if(restart){ - out[[i]] <- runMCMC(bayesianSetup = previousMcmcSampler[[i]], settings = settingsTemp) - }else{ - if(is.list(settings$startValue)) settingsTemp$startValue = settings$startValue[[i]] - out[[i]] <- runMCMC(bayesianSetup = setup, sampler = settings$sampler, settings = settingsTemp) - } - } - if(settings$sampler == "SMC") class(out) = c("smcSamplerList", "bayesianOutput") - else class(out) = c("mcmcSamplerList", "bayesianOutput") - return(out) - - ######### END RECURSIVE CALL - # MAIN RUN FUNCTION HERE - }else{ - - # check start values - setup$prior$checkStart(settings$startValue) - - - if (sampler == "Metropolis" || sampler == "AM" || sampler == "DR" || sampler == "DRAM"){ - if(restart == FALSE){ - mcmcSampler <- Metropolis(bayesianSetup = setup, settings = settings) - mcmcSampler <- sampleMetropolis(mcmcSampler = mcmcSampler, iterations = settings$iterations) - } else { - mcmcSampler <- sampleMetropolis(mcmcSampler = previousMcmcSampler, iterations = settings$iterations) - } - } - - - - ############## Differential Evolution ##################### - if (sampler == "DE"){ - - if(restart == F) out <- DE(bayesianSetup = setup, settings = settings) - else out <- DE(bayesianSetup = previousMcmcSampler, settings = settings) - - #out <- DE(bayesianSetup = bayesianSetup, settings = list(startValue = NULL, iterations = settings$iterations, burnin = settings$burnin, eps = settings$eps, parallel = settings$parallel, consoleUpdates = settings$consoleUpdates, - # blockUpdate = settings$blockUpdate, currentChain = settings$currentChain)) - - mcmcSampler = list( - setup = setup, - settings = settings, - chain = out$Draws, - X = out$X, - sampler = "DE" - ) - } - - ############## Differential Evolution with snooker update - if (sampler == "DEzs"){ - # check z matrix - if(!is.null(settings$Z)) setup$prior$checkStart(settings$Z,z = TRUE) - - if(restart == F) out <- DEzs(bayesianSetup = setup, settings = settings) - else out <- DEzs(bayesianSetup = previousMcmcSampler, settings = settings) - - mcmcSampler = list( - setup = setup, - settings = settings, - chain = out$Draws, - X = out$X, - Z = out$Z, - sampler = "DEzs" - ) - } - - ############## DREAM - if (sampler == "DREAM"){ - - if(restart == F) out <- DREAM(bayesianSetup = setup, settings = settings) - else out <- DREAM(bayesianSetup = previousMcmcSampler, settings = settings) - - mcmcSampler = list( - setup = setup, - settings = settings, - chain = out$chains, - pCR = out$pCR, - sampler = "DREAM", - lCR = out$lCR, - X = out$X, - delta = out$delta - ) - } - - ############## DREAMzs - if (sampler == "DREAMzs"){ - # check z matrix - if(!is.null(settings$Z)) setup$prior$checkStart(settings$Z,z = TRUE) - - if(restart == F) out <- DREAMzs(bayesianSetup = setup, settings = settings) - else out <- DREAMzs(bayesianSetup = previousMcmcSampler, settings = settings) - - mcmcSampler = list( - setup = setup, - settings = settings, - chain = out$chains, - pCR = out$pCR, - sampler = "DREAMzs", - JumpRates = out$JumpRates, - X = out$X, - Z = out$Z - ) - - } - - if(sampler == "Twalk"){ - warning("At the moment using T-walk is discouraged: numeric instability") - if(!restart){ - if(is.null(settings$startValue)){ - settings$startValue = bayesianSetup$prior$sampler(2) - } - mcmcSampler <- Twalk(bayesianSetup = setup, settings = settings) - }else{ - mcmcSampler <- Twalk(bayesianSetup = previousMcmcSampler, settings = settings) - } - mcmcSampler$setup <- setup - mcmcSampler$sampler <- "Twalk" - } - - - if ((sampler != "SMC")){ - class(mcmcSampler) <- c("mcmcSampler", "bayesianOutput") - } - - ############# SMC ##################### - - if (sampler == "SMC"){ - - mcmcSampler <- smcSampler(bayesianSetup = bayesianSetup, initialParticles = settings$initialParticles, iterations = settings$iterations, resampling = settings$resampling, resamplingSteps = settings$resamplingSteps, proposal = settings$proposal, adaptive = settings$adaptive, proposalScale = settings$proposalScale ) - mcmcSampler$settings = settings - } - - mcmcSampler$settings$runtime = mcmcSampler$settings$runtime + proc.time() - ptm - if(is.null(settings$message) || settings$message == TRUE){ - message("runMCMC terminated after ", mcmcSampler$settings$runtime[3], "seconds") - } - return(mcmcSampler) - } -} - - -#bayesianSetup = bayesianSetup, initialParticles = settings$initialParticles, iterations = settings$iterations, resampling = settings$resampling, resamplingSteps = settings$resamplingSteps, proposal = settings$proposal, adaptive = settings$adaptive, parallel = settings$parallel - - -#' Provides the default settings for the different samplers in runMCMC -#' @author Florian Hartig -#' @param settings optional list with parameters that will be used instead of the defaults -#' @param sampler one of the samplers in \code{\link{runMCMC}} -#' @param check logical determines whether parameters should be checked for consistency -#' @details see \code{\link{runMCMC}} -#' @export -applySettingsDefault<-function(settings=NULL, sampler = "DEzs", check = FALSE){ - - if(is.null(settings)) settings = list() - - if(!is.null(sampler)){ - if(!is.null(settings$sampler)) { - # TODO: this is a bit hacky. The best would prabably be to change the Metropolis function to allow AM, DR and DRAM - # arguments and call applySettingsDefault for those - if (settings$sampler %in% c("AM", "DR", "DRAM") && sampler == "Metropolis") { - sampler <- settings$sampler - } - if(settings$sampler != sampler) { - warning("sampler argument overwrites an existing settings$sampler in applySettingsDefault. This only makes sense if one wants to take over settings from one sampler to another") - } - } - settings$sampler = sampler - } - - if(!settings$sampler %in% getPossibleSamplerTypes()$BTname) stop("trying to set values for a sampler that does not exist") - - - mcmcDefaults <- list(startValue = NULL, - iterations = 10000, - burnin = 0, - thin = 1, - consoleUpdates = 100, - parallel = NULL, - message = TRUE) - - #### Metropolis #### - if(settings$sampler %in% c("AM", "DR", "DRAM", "Metropolis")){ - - defaultSettings <- c(mcmcDefaults, list(optimize = T, - proposalGenerator = NULL, - adapt = F, - adaptationInterval = 500, - adaptationNotBefore = 3000, - DRlevels = 1 , - proposalScaling = NULL, - adaptationDepth = NULL, - temperingFunction = NULL, - proposalGenerator = NULL, - gibbsProbabilities = NULL)) - - if (settings$sampler %in% c("AM", "DRAM")) defaultSettings$adapt <- TRUE - if (settings$sampler %in% c("DR", "DRAM")) defaultSettings$DRlevels <- 2 - } - - #### DE Family #### - if(settings$sampler %in% c("DE", "DEzs")){ - defaultSettings <- c(mcmcDefaults, list(eps = 0, - currentChain = 1, - blockUpdate = list("none", - k = NULL, - h = NULL, - pSel = NULL, - pGroup = NULL, - groupStart = 1000, - groupIntervall = 1000) - )) - - if (settings$sampler == "DE"){ - defaultSettings$f <- -2.38 # TODO CHECK - - } - - if (settings$sampler == "DEzs"){ - defaultSettings$f <- 2.38 - defaultSettings <- c(defaultSettings, list(Z = NULL, - zUpdateFrequency = 1, - pSnooker = 0.1, - pGamma1 = 0.1, - eps.mult =0.2, - eps.add = 0)) - } - - } - - #### DREAM Family #### - - if(settings$sampler %in% c("DREAM", "DREAMzs")){ - defaultSettings <- c(mcmcDefaults, list(nCR = 3, - currentChain = 1, - gamma = NULL, - eps = 0, - e = 5e-2, - DEpairs = 2, - adaptation = 0.2, - updateInterval = 10)) - - if (settings$sampler == "DREAM"){ - defaultSettings$pCRupdate <- TRUE - } - - if (settings$sampler == "DREAMzs"){ - defaultSettings = c(defaultSettings, list( - pCRupdate = FALSE, - Z = NULL, - ZupdateFrequency = 10, - pSnooker = 0.1 - )) - } - } - - #### Twalk #### - - if (settings$sampler == "Twalk"){ - defaultSettings = c(mcmcDefaults, - list(at = 6, - aw = 1.5, - pn1 = NULL, - Ptrav = 0.4918, - Pwalk = NULL, - Pblow = NULL)) - defaultSettings$parallel = NULL - } - - #### SMC #### - - if (settings$sampler == "SMC"){ - defaultSettings = list(iterations = 10, - resampling = T, - resamplingSteps = 2, - proposal = NULL, - adaptive = T, - proposalScale = 0.5, - initialParticles = 1000 - ) - } - - - - ## CHECK DEFAULTS - - if(check){ - nam = c(names(defaultSettings), "sampler", "nrChains", - "runtime", "sessionInfo", "parallel") - - ind <- which((names(settings) %in% nam == FALSE)) - - nam_n <- names(settings)[ind] - for(i in 1:length(nam_n)) nam_n[i] <- paste(nam_n[i], " ") - - if(length(ind) > 0){ - message("Parameter(s) ", nam_n , " not used in ", settings$sampler, "\n") - } - } - - defaultSettings$nrChains = 1 - defaultSettings$runtime = 0 - defaultSettings$sessionInfo = utils::sessionInfo() - - nam = names(defaultSettings) - - for (i in 1:length(defaultSettings)){ - if(! nam[i] %in% names(settings)){ - addition = list( defaultSettings[[i]]) - names(addition) = nam[i] - settings = c(settings, addition) - } - } - - - if (! is.null(settings$burnin)){ - if (settings$burnin > settings$iterations) stop("BayesianToools::applySettingsDefault - setting burnin cannnot be larger than setting iteration") - if (! is.null(settings$adaptationNotBefore)){ - if (settings$burnin >= settings$adaptationNotBefore) stop("BayesianToools::applySettingsDefault - setting burnin cannnot be larger than setting adaptationNotBefore") - } - } - - return(settings) -} - - -#' Help function to find starvalues and proposalGenerator settings -#' @author Florian Hartig -#' @param proposalGenerator proposal generator -#' @param bayesianSetup either an object of class bayesianSetup created by \code{\link{createBayesianSetup}} (recommended), or a log target function -#' @param settings list with settings -#' @keywords internal -setupStartProposal <- function(proposalGenerator = NULL, bayesianSetup, settings){ - - # Proposal - range = (bayesianSetup$prior$upper - bayesianSetup$prior$lower) / 50 - - if(is.null(settings$startValue)) settings$startValue = (bayesianSetup$prior$upper + bayesianSetup$prior$lower) / 2 - - if (length(range) != bayesianSetup$numPars) range = rep(1,bayesianSetup$numPars) - - if(is.null(proposalGenerator)){ - proposalGenerator = createProposalGenerator(range, gibbsProbabilities = settings$gibbsProbabilities) - } - - ####### OPTIMIZATION - - if (settings$optimize == T){ - if(is.null(settings$message) || settings$message == TRUE){ - cat("BT runMCMC: trying to find optimal start and covariance values", "\b") - } - - target <- function(x){ - out <- bayesianSetup$posterior$density(x) - if (out == -Inf) out = -1e20 # rnorm(1, mean = -1e20, sd = 1e-20) - return(out) - } - - try( { - if(bayesianSetup$numPars > 1) optresul <- optim(par=settings$startValue,fn=target, method="Nelder-Mead", hessian=F, control=list("fnscale"=-1, "maxit" = 10000)) - else optresul <- optim(par=settings$startValue,fn=target, method="Brent", hessian=F, control=list("fnscale"=-1, "maxit" = 10000), lower = bayesianSetup$prior$lower, upper = bayesianSetup$prior$upper) - settings$startValue = optresul$par - hessian = numDeriv::hessian(target, optresul$par) - - - proposalGenerator$covariance = as.matrix(Matrix::nearPD(MASS::ginv(-hessian))$mat) - #proposalGenerator$covariance = MASS::ginv(-optresul$hessian) - - # Create objects for startValues and covariance to add space between values - startV <-covV <- character() - - for(i in 1:length(settings$startValue)){ - startV[i] <- paste(settings$startValue[i], "") - } - for(i in 1:length( proposalGenerator$covariance)){ - covV[i] <- paste( proposalGenerator$covariance[i], "") - } - - if(is.null(settings$message) || settings$message == TRUE){ - message("BT runMCMC: Optimization finished, setting startValues to " , - startV, " - Setting covariance to " , covV) - } - - proposalGenerator = updateProposalGenerator(proposalGenerator) - - } - , silent = FALSE) - } - out = list(proposalGenerator = proposalGenerator, settings = settings) - return(out) -} - -#' Returns possible sampler types -#' @export -#' @author Florian Hartig -getPossibleSamplerTypes <- function(){ - - out = list( - BTname = c("AM", "DR", "DRAM", "Metropolis", "DE", "DEzs", "DREAM", "DREAMzs", "Twalk", "SMC"), - possibleSettings = list() , - possibleSettingsName = list() , - - univariatePossible = c(T, T, T, T, T, T, T, T, T, F), - restartable = c(T, T, T, T, T, T, T, T, T, F) - ) - - return(out) + +#' Main wrapper function to start MCMCs, particle MCMCs and SMCs +#' @author Florian Hartig +#' @param bayesianSetup either a BayesianSetup (see \code{\link{createBayesianSetup}}), a function, or a BayesianOutput created by runMCMC. The latter allows to continue a previous MCMC run. See details for how to restart a sampler. +#' @param sampler sampling algorithm to be run. Default is DEzs. Options are "Metropolis", "AM", "DR", "DRAM", "DE", "DEzs", "DREAM", "DREAMzs", "SMC". For details see the help of the individual functions. +#' @param settings list with settings for each sampler. If a setting is not provided, defaults (see \code{\link{applySettingsDefault}}) will be used. +#' @details The runMCMC function can be started with either one of +#' +#' 1. an object of class BayesianSetup with prior and likelihood function (created with \code{\link{createBayesianSetup}}). check if appropriate parallelization options are used - many samplers can make use of parallelization if this option is activated when the class is created. +#' 2. a log posterior or other target function, +#' 3. an object of class BayesianOutput created by runMCMC. The latter allows to continue a previous MCMC run. +#' +#' Settings for the sampler are provides as a list. You can see the default values by running \code{\link{applySettingsDefault}} with the respective sampler name. The following settings can be used for all MCMCs: +#' +#' * startValue (no default) start values for the MCMC. Note that DE family samplers require a matrix of start values. If startvalues are not provided, they are sampled from the prior. +#' * iterations (10000) the MCMC iterations +#' * burnin (0) burnin +#' * thin (1) thinning while sampling +#' * consoleUpdates (100) update frequency for console updates +#' * parallel (NULL) whether parallelization is to be used +#' * message (TRUE) if progress messages are to be printed +#' * nrChains (1) the number of independent MCMC chains to be run. Note that this is not controlling the internal number of chains in population MCMCs such as DE, so if you run nrChains = 3 with a DEzs startValue that is a 4xparameter matrix (= 4 internal chains), you will run independent DEzs runs with 4 internal chains each. +#' +#' The MCMC samplers will have a number of additional settings, which are described in the Vignette (run vignette("BayesianTools", package="BayesianTools") and in the help of the samplers. See \code{\link{Metropolis}} for Metropolis based samplers, \code{\link{DE}} and \code{\link{DEzs}} for standard differential evolution samplers, \code{\link{DREAM}} and \code{\link{DREAMzs}} for DREAM sampler, \code{\link{Twalk}} for the Twalk sampler, and \code{\link{smcSampler}} for rejection and Sequential Monte Carlo sampling. Note that the samplers "AM", "DR", and "DRAM" are special cases of the "Metropolis" sampler and are shortcuts for predefined settings ("AM": adapt=TRUE; "DR": DRlevels=2; "DRAM": adapt=True, DRlevels=2). +#' +#' Note that even if you specify parallel = T, this will only turn on internal parallelization of the samplers. The independent samplers controlled by nrChains are not evaluated in parallel, so if time is an issue it will be better to run the MCMCs individually and then combine them via \code{\link{createMcmcSamplerList}} into one joint object. +#' +#' Note that, DE and DREAM variants as well as SMC and T-walk require a population to start, which should be provided as a matrix. Default (NULL) sets the population size for DE to 3 x dimensions of parameters, for DREAM to 2 x dimensions of parameters and for DEzs and DREAMzs to three, sampled from the prior. Note also that the zs variants of DE and DREAM require two populations, the current population and the z matrix (a kind of memory) - if you want to set both, provide a list with startvalue$X and startvalue$Z. +#' +#' setting startValue for sampling with nrChains > 1 : if you want to provide different start values for the different chains, provide them as a list +#' +#' @return The function returns an object of class mcmcSampler (if one chain is run) or mcmcSamplerList. Both have the superclass bayesianOutput. It is possible to extract the samples as a coda object or matrix with \code{\link{getSample}}. +#' It is also possible to summarize the posterior as a new prior via \code{\link{createPriorDensity}}. +#' @example /inst/examples/mcmcRun.R +#' @seealso \code{\link{createBayesianSetup}} +#' @export +runMCMC <- function(bayesianSetup , sampler = "DEzs", settings = NULL){ + + options(warn = 0) + + ptm <- proc.time() + + ####### RESTART ########## + + if("bayesianOutput" %in% class(bayesianSetup)){ + + # TODO - the next statements should have assertions in case someone overwrites the existing setting or similar + + previousMcmcSampler <- bayesianSetup + + + # Catch the settings in case of nrChains > 1 + if(!("mcmcSamplerList" %in% class(previousMcmcSampler) | "smcSamplerList" %in% class(previousMcmcSampler) )){ + if(is.null(settings)) settings <- previousMcmcSampler$settings + setup <- previousMcmcSampler$setup + sampler <- previousMcmcSampler$settings$sampler + previousSettings <- previousMcmcSampler$settings + } else{ + if(is.null(settings)) settings <- previousMcmcSampler[[1]]$settings + settings$nrChains <- length(previousMcmcSampler) + setup <- previousMcmcSampler[[1]]$setup + sampler <- previousMcmcSampler[[1]]$settings$sampler + previousSettings <- previousMcmcSampler[[1]]$settings + } + + # Set settings$sampler (only needed if new settings are supplied) + settings$sampler <- sampler + + # overwrite new settings + for(name in names(settings)) previousSettings[[name]] <- settings[[name]] + + settings <- previousSettings + + # Check if previous settings will be new default + + previousMcmcSampler$settings <- applySettingsDefault(settings = settings, sampler = settings$sampler, check = TRUE) + + restart <- TRUE + + + ## NOT RESTART STARTS HERE ################### + + }else if(inherits(bayesianSetup, "BayesianSetup")){ + restart <- FALSE + + if(is.null(settings$parallel)) settings$parallel <- bayesianSetup$parallel + if(is.numeric(settings$parallel)) settings$parallel <- TRUE + + setup <- checkBayesianSetup(bayesianSetup, parallel = settings$parallel) + settings <- applySettingsDefault(settings = settings, sampler = sampler, check = TRUE) + } else stop("runMCMC requires a class of type BayesianOutput or BayesianSetup") + + ###### END RESTART ############## + + + # TODO - the following statement should be removed once all further functions access settings$sampler instead of sampler + # At the moment only the same sampler can be used to restart sampling. + sampler = settings$sampler + + #### Assertions + if(!restart && setup$numPars == 1) if(!getPossibleSamplerTypes()$univariate[which(getPossibleSamplerTypes()$BTname == settings$sampler)]) stop("This sampler can not be applied to a univariate distribution") + + if(restart == T) if(!getPossibleSamplerTypes()$restartable[which(getPossibleSamplerTypes()$BTname == settings$sampler)]) stop("This sampler can not be restarted") + + ########### Recursive call in case multiple chains are to be run + if(settings$nrChains >1){ + + # Initialize output list + out<- list() + + # Run several samplers + for(i in 1:settings$nrChains){ + + settingsTemp <- settings + settingsTemp$nrChains <- 1 # avoid infinite loop + settingsTemp$currentChain <- i + + if(restart){ + out[[i]] <- runMCMC(bayesianSetup = previousMcmcSampler[[i]], settings = settingsTemp) + }else{ + if(is.list(settings$startValue)) settingsTemp$startValue = settings$startValue[[i]] + out[[i]] <- runMCMC(bayesianSetup = setup, sampler = settings$sampler, settings = settingsTemp) + } + } + if(settings$sampler == "SMC") class(out) = c("smcSamplerList", "bayesianOutput") + else class(out) = c("mcmcSamplerList", "bayesianOutput") + return(out) + + ######### END RECURSIVE CALL + # MAIN RUN FUNCTION HERE + }else{ + + # check start values + setup$prior$checkStart(settings$startValue) + + + if (sampler == "Metropolis" || sampler == "AM" || sampler == "DR" || sampler == "DRAM"){ + if(restart == FALSE){ + mcmcSampler <- Metropolis(bayesianSetup = setup, settings = settings) + mcmcSampler <- sampleMetropolis(mcmcSampler = mcmcSampler, iterations = settings$iterations) + } else { + mcmcSampler <- sampleMetropolis(mcmcSampler = previousMcmcSampler, iterations = settings$iterations) + } + } + + + + ############## Differential Evolution ##################### + if (sampler == "DE"){ + + if(restart == F) out <- DE(bayesianSetup = setup, settings = settings) + else out <- DE(bayesianSetup = previousMcmcSampler, settings = settings) + + #out <- DE(bayesianSetup = bayesianSetup, settings = list(startValue = NULL, iterations = settings$iterations, burnin = settings$burnin, eps = settings$eps, parallel = settings$parallel, consoleUpdates = settings$consoleUpdates, + # blockUpdate = settings$blockUpdate, currentChain = settings$currentChain)) + + mcmcSampler = list( + setup = setup, + settings = settings, + chain = out$Draws, + X = out$X, + sampler = "DE" + ) + } + + ############## Differential Evolution with snooker update + if (sampler == "DEzs"){ + # check z matrix + if(!is.null(settings$Z)) setup$prior$checkStart(settings$Z,z = TRUE) + + if(restart == F) out <- DEzs(bayesianSetup = setup, settings = settings) + else out <- DEzs(bayesianSetup = previousMcmcSampler, settings = settings) + + mcmcSampler = list( + setup = setup, + settings = settings, + chain = out$Draws, + X = out$X, + Z = out$Z, + sampler = "DEzs" + ) + } + + ############## DREAM + if (sampler == "DREAM"){ + + if(restart == F) out <- DREAM(bayesianSetup = setup, settings = settings) + else out <- DREAM(bayesianSetup = previousMcmcSampler, settings = settings) + + mcmcSampler = list( + setup = setup, + settings = settings, + chain = out$chains, + pCR = out$pCR, + sampler = "DREAM", + lCR = out$lCR, + X = out$X, + delta = out$delta + ) + } + + ############## DREAMzs + if (sampler == "DREAMzs"){ + # check z matrix + if(!is.null(settings$Z)) setup$prior$checkStart(settings$Z,z = TRUE) + + if(restart == F) out <- DREAMzs(bayesianSetup = setup, settings = settings) + else out <- DREAMzs(bayesianSetup = previousMcmcSampler, settings = settings) + + mcmcSampler = list( + setup = setup, + settings = settings, + chain = out$chains, + pCR = out$pCR, + sampler = "DREAMzs", + JumpRates = out$JumpRates, + X = out$X, + Z = out$Z + ) + + } + + if(sampler == "Twalk"){ + warning("At the moment using T-walk is discouraged: numeric instability") + if(!restart){ + if(is.null(settings$startValue)){ + settings$startValue = bayesianSetup$prior$sampler(2) + } + mcmcSampler <- Twalk(bayesianSetup = setup, settings = settings) + }else{ + mcmcSampler <- Twalk(bayesianSetup = previousMcmcSampler, settings = settings) + } + mcmcSampler$setup <- setup + mcmcSampler$sampler <- "Twalk" + } + + + if ((sampler != "SMC")){ + class(mcmcSampler) <- c("mcmcSampler", "bayesianOutput") + } + + ############# SMC ##################### + + if (sampler == "SMC"){ + + mcmcSampler <- smcSampler(bayesianSetup = bayesianSetup, initialParticles = settings$initialParticles, iterations = settings$iterations, resampling = settings$resampling, resamplingSteps = settings$resamplingSteps, proposal = settings$proposal, adaptive = settings$adaptive, proposalScale = settings$proposalScale ) + mcmcSampler$settings = settings + } + + mcmcSampler$settings$runtime = mcmcSampler$settings$runtime + proc.time() - ptm + if(is.null(settings$message) || settings$message == TRUE){ + message("runMCMC terminated after ", mcmcSampler$settings$runtime[3], "seconds") + } + return(mcmcSampler) + } +} + + +#bayesianSetup = bayesianSetup, initialParticles = settings$initialParticles, iterations = settings$iterations, resampling = settings$resampling, resamplingSteps = settings$resamplingSteps, proposal = settings$proposal, adaptive = settings$adaptive, parallel = settings$parallel + + +#' Provides the default settings for the different samplers in runMCMC +#' @author Florian Hartig +#' @param settings optional list with parameters that will be used instead of the defaults +#' @param sampler one of the samplers in \code{\link{runMCMC}} +#' @param check logical determines whether parameters should be checked for consistency +#' @details see \code{\link{runMCMC}} +#' @export +applySettingsDefault<-function(settings=NULL, sampler = "DEzs", check = FALSE){ + + if(is.null(settings)) settings = list() + + if(!is.null(sampler)){ + if(!is.null(settings$sampler)) { + # TODO: this is a bit hacky. The best would prabably be to change the Metropolis function to allow AM, DR and DRAM + # arguments and call applySettingsDefault for those + if (settings$sampler %in% c("AM", "DR", "DRAM") && sampler == "Metropolis") { + sampler <- settings$sampler + } + if(settings$sampler != sampler) { + warning("sampler argument overwrites an existing settings$sampler in applySettingsDefault. This only makes sense if one wants to take over settings from one sampler to another") + } + } + settings$sampler = sampler + } + + if(!settings$sampler %in% getPossibleSamplerTypes()$BTname) stop("trying to set values for a sampler that does not exist") + + + mcmcDefaults <- list(startValue = NULL, + iterations = 10000, + burnin = 0, + thin = 1, + consoleUpdates = 100, + parallel = NULL, + message = TRUE) + + #### Metropolis #### + if(settings$sampler %in% c("AM", "DR", "DRAM", "Metropolis")){ + + defaultSettings <- c(mcmcDefaults, list(optimize = T, + proposalGenerator = NULL, + adapt = F, + adaptationInterval = 500, + adaptationNotBefore = 3000, + DRlevels = 1 , + proposalScaling = NULL, + adaptationDepth = NULL, + temperingFunction = NULL, + proposalGenerator = NULL, + gibbsProbabilities = NULL)) + + if (settings$sampler %in% c("AM", "DRAM")) defaultSettings$adapt <- TRUE + if (settings$sampler %in% c("DR", "DRAM")) defaultSettings$DRlevels <- 2 + } + + #### DE Family #### + if(settings$sampler %in% c("DE", "DEzs")){ + defaultSettings <- c(mcmcDefaults, list(eps = 0, + currentChain = 1, + blockUpdate = list("none", + k = NULL, + h = NULL, + pSel = NULL, + pGroup = NULL, + groupStart = 1000, + groupIntervall = 1000) + )) + + if (settings$sampler == "DE"){ + defaultSettings$f <- -2.38 # TODO CHECK + + } + + if (settings$sampler == "DEzs"){ + defaultSettings$f <- 2.38 + defaultSettings <- c(defaultSettings, list(Z = NULL, + zUpdateFrequency = 1, + pSnooker = 0.1, + pGamma1 = 0.1, + eps.mult =0.2, + eps.add = 0)) + } + + } + + #### DREAM Family #### + + if(settings$sampler %in% c("DREAM", "DREAMzs")){ + defaultSettings <- c(mcmcDefaults, list(nCR = 3, + currentChain = 1, + gamma = NULL, + eps = 0, + e = 5e-2, + DEpairs = 2, + adaptation = 0.2, + updateInterval = 10)) + + if (settings$sampler == "DREAM"){ + defaultSettings$pCRupdate <- TRUE + } + + if (settings$sampler == "DREAMzs"){ + defaultSettings = c(defaultSettings, list( + pCRupdate = FALSE, + Z = NULL, + ZupdateFrequency = 10, + pSnooker = 0.1 + )) + } + } + + #### Twalk #### + + if (settings$sampler == "Twalk"){ + defaultSettings = c(mcmcDefaults, + list(at = 6, + aw = 1.5, + pn1 = NULL, + Ptrav = 0.4918, + Pwalk = NULL, + Pblow = NULL)) + defaultSettings$parallel = NULL + } + + #### SMC #### + + if (settings$sampler == "SMC"){ + defaultSettings = list(iterations = 10, + resampling = T, + resamplingSteps = 2, + proposal = NULL, + adaptive = T, + proposalScale = 0.5, + initialParticles = 1000 + ) + } + + + + ## CHECK DEFAULTS + + if(check){ + nam = c(names(defaultSettings), "sampler", "nrChains", + "runtime", "sessionInfo", "parallel") + + ind <- which((names(settings) %in% nam == FALSE)) + + nam_n <- names(settings)[ind] + for(i in 1:length(nam_n)) nam_n[i] <- paste(nam_n[i], " ") + + if(length(ind) > 0){ + message("Parameter(s) ", nam_n , " not used in ", settings$sampler, "\n") + } + } + + defaultSettings$nrChains = 1 + defaultSettings$runtime = 0 + defaultSettings$sessionInfo = utils::sessionInfo() + + nam = names(defaultSettings) + + for (i in 1:length(defaultSettings)){ + if(! nam[i] %in% names(settings)){ + addition = list( defaultSettings[[i]]) + names(addition) = nam[i] + settings = c(settings, addition) + } + } + + + if (! is.null(settings$burnin)){ + if (settings$burnin > settings$iterations) stop("BayesianToools::applySettingsDefault - setting burnin cannnot be larger than setting iteration") + if (! is.null(settings$adaptationNotBefore)){ + if (settings$burnin >= settings$adaptationNotBefore) stop("BayesianToools::applySettingsDefault - setting burnin cannnot be larger than setting adaptationNotBefore") + } + } + + return(settings) +} + + +#' Help function to find starvalues and proposalGenerator settings +#' @author Florian Hartig +#' @param proposalGenerator proposal generator +#' @param bayesianSetup either an object of class bayesianSetup created by \code{\link{createBayesianSetup}} (recommended), or a log target function +#' @param settings list with settings +#' @keywords internal +setupStartProposal <- function(proposalGenerator = NULL, bayesianSetup, settings){ + + # Proposal + range = (bayesianSetup$prior$upper - bayesianSetup$prior$lower) / 50 + + if(is.null(settings$startValue)) settings$startValue = (bayesianSetup$prior$upper + bayesianSetup$prior$lower) / 2 + + if (length(range) != bayesianSetup$numPars) range = rep(1,bayesianSetup$numPars) + + if(is.null(proposalGenerator)){ + proposalGenerator = createProposalGenerator(range, gibbsProbabilities = settings$gibbsProbabilities) + } + + ####### OPTIMIZATION + + if (settings$optimize == T){ + if(is.null(settings$message) || settings$message == TRUE){ + cat("BT runMCMC: trying to find optimal start and covariance values", "\b") + } + + target <- function(x){ + out <- bayesianSetup$posterior$density(x) + if (out == -Inf) out = -1e20 # rnorm(1, mean = -1e20, sd = 1e-20) + return(out) + } + + try( { + if(bayesianSetup$numPars > 1) optresul <- optim(par=settings$startValue,fn=target, method="Nelder-Mead", hessian=F, control=list("fnscale"=-1, "maxit" = 10000)) + else optresul <- optim(par=settings$startValue,fn=target, method="Brent", hessian=F, control=list("fnscale"=-1, "maxit" = 10000), lower = bayesianSetup$prior$lower, upper = bayesianSetup$prior$upper) + settings$startValue = optresul$par + hessian = numDeriv::hessian(target, optresul$par) + + + proposalGenerator$covariance = as.matrix(Matrix::nearPD(MASS::ginv(-hessian))$mat) + #proposalGenerator$covariance = MASS::ginv(-optresul$hessian) + + # Create objects for startValues and covariance to add space between values + startV <-covV <- character() + + for(i in 1:length(settings$startValue)){ + startV[i] <- paste(settings$startValue[i], "") + } + for(i in 1:length( proposalGenerator$covariance)){ + covV[i] <- paste( proposalGenerator$covariance[i], "") + } + + if(is.null(settings$message) || settings$message == TRUE){ + message("BT runMCMC: Optimization finished, setting startValues to " , + startV, " - Setting covariance to " , covV) + } + + proposalGenerator = updateProposalGenerator(proposalGenerator) + + } + , silent = FALSE) + } + out = list(proposalGenerator = proposalGenerator, settings = settings) + return(out) +} + +#' Returns possible sampler types +#' @export +#' @author Florian Hartig +getPossibleSamplerTypes <- function(){ + + out = list( + BTname = c("AM", "DR", "DRAM", "Metropolis", "DE", "DEzs", "DREAM", "DREAMzs", "Twalk", "SMC"), + possibleSettings = list() , + possibleSettingsName = list() , + + univariatePossible = c(T, T, T, T, T, T, T, T, T, F), + restartable = c(T, T, T, T, T, T, T, T, T, F) + ) + + return(out) } \ No newline at end of file diff --git a/BayesianTools/R/mcmcTwalk.R b/BayesianTools/R/mcmcTwalk.R index 63c53c4..7ab1c5d 100644 --- a/BayesianTools/R/mcmcTwalk.R +++ b/BayesianTools/R/mcmcTwalk.R @@ -1,154 +1,155 @@ -#' T-walk MCMC -#' @author Stefan Paul -#' @param bayesianSetup object of class 'bayesianSetup' or 'bayesianOuput'. -#' @param settings list with parameter values. -#' @param iterations number of model evaluations -#' @param at "traverse" move proposal parameter. Default to 6 -#' @param aw "walk" move proposal parameter. Default to 1.5 -#' @param pn1 probability determining the number of parameters that are changed -#' @param Ptrav move probability of "traverse" moves, default to 0.4918 -#' @param Pwalk move probability of "walk" moves, default to 0.4918 -#' @param Pblow move probability of "traverse" moves, default to 0.0082 -#' @param burnin number of iterations treated as burn-in. These iterations are not recorded in the chain. -#' @param thin thinning parameter. Determines the interval in which values are recorded. -#' @param startValue matrix with start values -#' @param consoleUpdates intervall in which the sampling progress is printed to the console -#' @param message logical, determines whether the sampler's progress should be printed -#' @details -##' The probability of "hop" moves is 1 minus the sum of all other probabilities. -#' @return Object of class bayesianOutput. -#' @references Christen, J. Andres, and Colin Fox. "A general purpose sampling algorithm for continuous distributions (the t-walk)." Bayesian Analysis 5.2 (2010): 263-281. -#' @export -Twalk <- function (bayesianSetup, settings = list(iterations = 10000, at = 6, aw = 1.5, - pn1 = NULL, Ptrav = 0.4918, Pwalk = 0.4918, - Pblow = 0.0082, burnin = 0, thin= 1, startValue = NULL, consoleUpdates = 100, - message = TRUE)) -{ - if("bayesianOutput" %in% class(bayesianSetup)){ - restart <- TRUE - setup <- bayesianSetup$setup - }else{ - restart <- FALSE - setup <- bayesianSetup - } - - setup <- checkBayesianSetup(setup, parallel = settings$parallel) # calling parallel will check if requested parallelization in settings is provided by the BayesianSetup - if(is.null(settings$parallel)) settings$parallel = setup$parallel # checking back - if no parallelization is provided, we use the parallelization in the BayesianSetup. We could also set parallel = F, but I feel it makes more sense to use the Bayesiansetup as default - - - aw <- settings$aw - at <- settings$at - Npar <- setup$numPars - iterations <- floor(settings$iterations/2) # Divided by 2 because two chains are run - if(is.null(settings$pn1)) pn1 <- min(Npar,4)/Npar - else pn1 <- settings$pn1 - Ptrav <- settings$Ptrav - if(is.null(settings$Pwalk)) Pwalk <- 0.4918 - else Pwalk <- settings$Pwalk - if(is.null(settings$Pblow)) Pblow <- 0.0082 - else Pblow <- settings$Pblow - - - # Set burnin and thin - burnin <- settings$burnin - thin <- settings$thin - - # Set Phop - Phop <- 1-(Ptrav+Pwalk+Pblow) - - # Check for consistency of move probabilities - if((Pwalk + Ptrav + Pblow) > 1) stop("Move probabilities larger one") - - consoleUpdates <- settings$consoleUpdates - - - FUN <- setup$posterior$density - - if(!restart){ - # Initialize x and x2 - - if(is.null(settings$startValue)){ - settings$startValue = setup$prior$sampler(2) - } - if(is.function(settings$startValue)){ - settings$startValue = settings$startValue(2) - } - x <- settings$startValue[1,] - x2 <- settings$startValue[2,] - - # Evaluate - Eval <- FUN(x, returnAll = T) - Eval2 <- FUN(x2, returnAll = T) - }else{ - x <- bayesianSetup$chain[[1]][nrow(bayesianSetup$chain[[1]]), 1:Npar] - x2 <- bayesianSetup$chain[[2]][nrow(bayesianSetup$chain[[2]]), 1:Npar] - - Eval <- bayesianSetup$chain[[1]][nrow(bayesianSetup$chain[[1]]), (Npar+1):(Npar+3)] - Eval2 <- bayesianSetup$chain[[2]][nrow(bayesianSetup$chain[[2]]), (Npar+1):(Npar+3)] - - } - - # Initialize chains - chain <- matrix(NA, nrow = floor((iterations+1-burnin)/thin), ncol = Npar+3) - chain2 <- matrix(NA, nrow = floor((iterations+1-burnin)/thin), ncol = Npar+3) - - # Fill first values in chain - chain[1,] <- c(x,Eval) - chain2[1,] <- c(x2,Eval2) - - # Initialize counter for acceptance rate - acceptance <- 0 - - # Initialize counter - counter <- 0 - - - for (i in 1:iterations) { - - move <- TwalkMove(Npar = Npar, FUN = FUN, x = x, - Eval = Eval, x2 = x2, Eval2 = Eval2, - at = at, aw = aw, pn1 = pn1, Ptrav = Ptrav, - Pwalk = Pwalk, Pblow = Pblow, Phop = Phop) - - if(!is.na(move$alpha)){ - if (runif(1) < move$alpha) { - x <- move$y - Eval<- move$val - x2 <- move$y2 - Eval2 <- move$val2 - } - } - - if((i > burnin) && (i %% thin == 0) ){ # retain sample - counter <- counter + 1 - chain[counter,] <- c(x, Eval) - chain2[counter,] <- c(x2, Eval2) - } - - if(settings$message){ - if( (i %% consoleUpdates == 0) | (i == iterations)) { - cat("\r","Running Twalk-MCMC, chain ", settings$currentChain , "iteration" ,(i*2),"of",(iterations*2), - ". Current logp ", Eval[1], Eval2[1] ,". Please wait!","\r") - flush.console() - } - } - } - colnames(chain) <- c(setup$names,"LP", "LL", "LPr") - colnames(chain2) <- c(setup$names,"LP", "LL", "LPr") - - if(restart){ # Combine chains - chain <- rbind(bayesianSetup$chain[[1]], chain) - chain2 <- rbind(bayesianSetup$chain[[2]], chain2) - } - - # Make sure chains have the right size - chain <- chain[1:counter,] - chain2 <- chain2[1:counter,] - - chain <- coda::mcmc.list(coda::mcmc(chain), coda::mcmc(chain2)) - - out <- list(chain = chain, settings = settings) - class(out) <- c("mcmcSampler", "bayesianOutput") - return(out) -} - + +#' T-walk MCMC +#' @author Stefan Paul +#' @param bayesianSetup object of class 'bayesianSetup' or 'bayesianOuput'. +#' @param settings list with parameter values. +#' @param iterations number of model evaluations +#' @param at "traverse" move proposal parameter. Default to 6 +#' @param aw "walk" move proposal parameter. Default to 1.5 +#' @param pn1 probability determining the number of parameters that are changed +#' @param Ptrav move probability of "traverse" moves, default to 0.4918 +#' @param Pwalk move probability of "walk" moves, default to 0.4918 +#' @param Pblow move probability of "traverse" moves, default to 0.0082 +#' @param burnin number of iterations treated as burn-in. These iterations are not recorded in the chain. +#' @param thin thinning parameter. Determines the interval in which values are recorded. +#' @param startValue matrix with start values +#' @param consoleUpdates intervall in which the sampling progress is printed to the console +#' @param message logical, determines whether the sampler's progress should be printed +#' @details +##' The probability of "hop" moves is 1 minus the sum of all other probabilities. +#' @return Object of class bayesianOutput. +#' @references Christen, J. Andres, and Colin Fox. "A general purpose sampling algorithm for continuous distributions (the t-walk)." Bayesian Analysis 5.2 (2010): 263-281. +#' @export +Twalk <- function (bayesianSetup, settings = list(iterations = 10000, at = 6, aw = 1.5, + pn1 = NULL, Ptrav = 0.4918, Pwalk = 0.4918, + Pblow = 0.0082, burnin = 0, thin= 1, startValue = NULL, consoleUpdates = 100, + message = TRUE)) +{ + if("bayesianOutput" %in% class(bayesianSetup)){ + restart <- TRUE + setup <- bayesianSetup$setup + }else{ + restart <- FALSE + setup <- bayesianSetup + } + + setup <- checkBayesianSetup(setup, parallel = settings$parallel) # calling parallel will check if requested parallelization in settings is provided by the BayesianSetup + if(is.null(settings$parallel)) settings$parallel = setup$parallel # checking back - if no parallelization is provided, we use the parallelization in the BayesianSetup. We could also set parallel = F, but I feel it makes more sense to use the Bayesiansetup as default + + + aw <- settings$aw + at <- settings$at + Npar <- setup$numPars + iterations <- floor(settings$iterations/2) # Divided by 2 because two chains are run + if(is.null(settings$pn1)) pn1 <- min(Npar,4)/Npar + else pn1 <- settings$pn1 + Ptrav <- settings$Ptrav + if(is.null(settings$Pwalk)) Pwalk <- 0.4918 + else Pwalk <- settings$Pwalk + if(is.null(settings$Pblow)) Pblow <- 0.0082 + else Pblow <- settings$Pblow + + + # Set burnin and thin + burnin <- settings$burnin + thin <- settings$thin + + # Set Phop + Phop <- 1-(Ptrav+Pwalk+Pblow) + + # Check for consistency of move probabilities + if((Pwalk + Ptrav + Pblow) > 1) stop("Move probabilities larger one") + + consoleUpdates <- settings$consoleUpdates + + + FUN <- setup$posterior$density + + if(!restart){ + # Initialize x and x2 + + if(is.null(settings$startValue)){ + settings$startValue = setup$prior$sampler(2) + } + if(is.function(settings$startValue)){ + settings$startValue = settings$startValue(2) + } + x <- settings$startValue[1,] + x2 <- settings$startValue[2,] + + # Evaluate + Eval <- FUN(x, returnAll = T) + Eval2 <- FUN(x2, returnAll = T) + }else{ + x <- bayesianSetup$chain[[1]][nrow(bayesianSetup$chain[[1]]), 1:Npar] + x2 <- bayesianSetup$chain[[2]][nrow(bayesianSetup$chain[[2]]), 1:Npar] + + Eval <- bayesianSetup$chain[[1]][nrow(bayesianSetup$chain[[1]]), (Npar+1):(Npar+3)] + Eval2 <- bayesianSetup$chain[[2]][nrow(bayesianSetup$chain[[2]]), (Npar+1):(Npar+3)] + + } + + # Initialize chains + chain <- matrix(NA, nrow = floor((iterations+1-burnin)/thin), ncol = Npar+3) + chain2 <- matrix(NA, nrow = floor((iterations+1-burnin)/thin), ncol = Npar+3) + + # Fill first values in chain + chain[1,] <- c(x,Eval) + chain2[1,] <- c(x2,Eval2) + + # Initialize counter for acceptance rate + acceptance <- 0 + + # Initialize counter + counter <- 0 + + + for (i in 1:iterations) { + + move <- TwalkMove(Npar = Npar, FUN = FUN, x = x, + Eval = Eval, x2 = x2, Eval2 = Eval2, + at = at, aw = aw, pn1 = pn1, Ptrav = Ptrav, + Pwalk = Pwalk, Pblow = Pblow, Phop = Phop) + + if(!is.na(move$alpha)){ + if (runif(1) < move$alpha) { + x <- move$y + Eval<- move$val + x2 <- move$y2 + Eval2 <- move$val2 + } + } + + if((i > burnin) && (i %% thin == 0) ){ # retain sample + counter <- counter + 1 + chain[counter,] <- c(x, Eval) + chain2[counter,] <- c(x2, Eval2) + } + + if(settings$message){ + if( (i %% consoleUpdates == 0) | (i == iterations)) { + cat("\r","Running Twalk-MCMC, chain ", settings$currentChain , "iteration" ,(i*2),"of",(iterations*2), + ". Current logp ", Eval[1], Eval2[1] ,". Please wait!","\r") + flush.console() + } + } + } + colnames(chain) <- c(setup$names,"LP", "LL", "LPr") + colnames(chain2) <- c(setup$names,"LP", "LL", "LPr") + + if(restart){ # Combine chains + chain <- rbind(bayesianSetup$chain[[1]], chain) + chain2 <- rbind(bayesianSetup$chain[[2]], chain2) + } + + # Make sure chains have the right size + chain <- chain[1:counter,] + chain2 <- chain2[1:counter,] + + chain <- coda::mcmc.list(coda::mcmc(chain), coda::mcmc(chain2)) + + out <- list(chain = chain, settings = settings) + class(out) <- c("mcmcSampler", "bayesianOutput") + return(out) +} + diff --git a/BayesianTools/R/mcmcTwalk_helperFunctions.R b/BayesianTools/R/mcmcTwalk_helperFunctions.R index 9d2c092..438bc22 100644 --- a/BayesianTools/R/mcmcTwalk_helperFunctions.R +++ b/BayesianTools/R/mcmcTwalk_helperFunctions.R @@ -1,299 +1,300 @@ -###### -# Twalk helper functions -###### - -#' Wrapper for step function -#' @param Npar number of parameters -#' @param FUN log posterior density -#' @param x parameter vector of chain 1 -#' @param Eval last evaluation of x -#' @param x2 parameter vector of chain 2 -#' @param Eval2 last evaluation of x -#' @param at "traverse" move proposal parameter. -#' @param aw "walk" move proposal parameter. -#' @param pn1 Probability determining the number of parameters that are changed. -#' @param Ptrav Move probability of "traverse" moves, default to 0.4918 -#' @param Pwalk Move probability of "walk" moves, default to 0.4918 -#' @param Pblow Move probability of "blow" moves, default to 0.0082 -#' @param Phop Move probability of "hop" moves -#' @references Christen, J. Andres, and Colin Fox. "A general purpose sampling algorithm for continuous distributions (the t-walk)." Bayesian Analysis 5.2 (2010): 263-281. -#' @keywords internal -TwalkMove <- function (Npar, FUN, x, Eval, x2, Eval2, at = 6, aw = 1.5, pn1 = min(Npar, 4)/Npar, - Ptrav = 0.4918, Pwalk = 0.4918, Pblow = 0.0082, Phop = 0.0082) -{ - - p <- sample(4,1, prob = c(Ptrav,Pwalk,Pblow,Phop)) - - if(p == 1)case <- "traverse" - else if(p ==2) case <- "walk" - else if(p ==3) case <- "blow" - else case <- "hop" - - - out <- Twalksteps(case = case, Npar = Npar, FUN = FUN, x = x, - Eval = Eval, x2 = x2, Eval2 = Eval2, at = at, aw = aw, pn1 = pn1) - - - return(list(y = out$y, val = out$val, y2 = out$y2, val2 = out$val2, alpha = out$alpha)) -} - - - -#' Main function that is executing and evaluating the moves -#' @param case Type of Twalk move. Either "walk", "traverse", "hop" or "blow" -#' @param Npar number of parameters -#' @param FUN Log posterior density -#' @param x parameter vector of chain 1 -#' @param Eval last evaluation of x -#' @param x2 parameter vector of chain 2 -#' @param Eval2 last evaluation of x -#' @param at "traverse" move proposal parameter. -#' @param aw "walk" move proposal parameter. -#' @param pn1 Probability determining the number of parameters that are changed. -#' @references Christen, J. Andres, and Colin Fox. "A general purpose sampling algorithm for continuous distributions (the t-walk)." Bayesian Analysis 5.2 (2010): 263-281. -#' @keywords internal -Twalksteps <- function(case, Npar, FUN, x, - Eval, x2, Eval2, at, aw, pn1){ - - val <- NULL - val2 <- NULL - p <- runif(1) - - switch(case, - "traverse" = { #Traverse - if (p < 0.5) { - beta <- betaFun(at) - tmp <- propFun(case, Npar = Npar, pn1 = pn1, x2 = x, x = x2, beta = beta) - y2 <- tmp$prop - npSel <- tmp$npSel - y <- x - val <- Eval - val2 <- FUN(y2, returnAll = T) - - if (npSel == 0) alpha <- 1 - else alpha <- exp((- Eval2[1] + val2[1]) + (npSel - 2) * log(beta)) - - }else{ - beta <- betaFun(at) - tmp <- propFun(case, Npar = Npar, pn1 = pn1, x = x, x2 = x2, beta = beta) - y <- tmp$prop - npSel <- tmp$npSel - y2 <- x2 - val2 <- Eval2 - - val <- FUN(y, returnAll = T) - - if (npSel == 0) alpha <- 1 - else alpha <- exp((-Eval[1] + val[1]) + (npSel - 2) * log(beta)) - - }}, # End traverse - "walk" = { # walk - if (p < 0.5) { - tmp <- propFun(case, Npar = Npar, pn1 = pn1, aw = aw, x2 = x, x = x2) - y2 <- tmp$prop - npSel <- tmp$npSel - y <- x - val <- Eval - if ( (all(abs(y2 - y) > 0))) { - val2 <- FUN(y2, returnAll = T) - - alpha <- exp(-Eval2[1] + val2[1]) - } - else { - alpha <- 0 - } - }else{ - tmp <- propFun(case, Npar = Npar, pn1 = pn1, aw = aw, x = x, x2 = x2) - y <- tmp$prop - npSel <- tmp$npSel - y2 <- x2 - val2 <- Eval2 - if ( (all(abs(y2 - y) > 0))) { - val <- FUN(y, returnAll = T) - - alpha <- exp(-Eval[1] + val[1]) - } - else { - alpha <- 0 - } - }}, # End walk - "blow" = { #blow - if (p < 0.5) { - tmp <- propFun(case, Npar = Npar, pn1 = pn1, x = x2, x2 = x) - y2 <- tmp$prop - npSel <- tmp$npSel - pSel <- tmp$pSel - y <- x - val <- Eval - if ( all(y2 != x)) { - val2 <- FUN(y2, returnAll = T) - - G1 <- Gfun(case, npSel, pSel, y2, x2, x) - G2 <- Gfun(case, npSel, pSel, x2, y2, x) - alpha <- exp((-Eval2[1] + val2[1]) + (G1 - G2)) - } - else { - alpha <- 0 - } - }else{ - tmp <- propFun(case, Npar = Npar, pn1 = pn1, x = x, x2 = x2) - y <- tmp$prop - npSel <- tmp$npSel - pSel <- tmp$pSel - y2 <- x2 - val2 <- Eval2 - if (all(y != x2)) { - val <- FUN(y, returnAll = T) - - G1 <- Gfun(case, npSel, pSel, y, x, x2) - G2 <- Gfun(case, npSel, pSel, x, y, x2) - alpha <- exp((-Eval[1] + val[1]) + (G1 - G2)) - } - else { - alpha <- 0 - } - } - }, # End blow - "hop" = { #hop - if (p < 0.5) { - tmp <- propFun(case, Npar = Npar, pn1 = pn1, x2 = x, x = x2) - y2 <- tmp$prop - npSel <- tmp$npSel - pSel <- tmp$pSel - y <- x - val <- Eval - if ( all(y2 != x)) { - val2 <- FUN(y2, returnAll = T) - - G1 <- Gfun(case, npSel, pSel, y2, x2, x) - G2 <- Gfun(case, npSel, pSel, x2, y2, x) - alpha <- exp((-Eval2[1] + val2[1]) + (G1 - G2)) - } - else { - alpha <- 0 - } - }else{ - tmp <- propFun(case, Npar = Npar, pn1 = pn1, x = x, x2 = x2) - y <- tmp$prop - npSel <- tmp$npSel - pSel <- tmp$pSel - y2 <- x2 - val2 <- Eval2 - if ( all(y != x2)) { - val <- FUN(y, returnAll = T) - - G1 <- Gfun(case, npSel, pSel, y, x, x2) - G2 <- Gfun(case, npSel, pSel, x, y, x2) - alpha <- exp((-Eval[1] + val[1]) + (G1 - G2)) - } - else { - alpha <- 0 - } - - }}) # End hop and end switch - return(list(y = y, val = val, y2 = y2, val2 = val2, alpha = alpha, - npSel = npSel)) -} - - - - - - - -################## Helper functions -############################################################### - -#' Helper function for sum of x*x -#' @param x vector of values -#' @keywords internal -sumSquare <- function(x){return(sum(x*x))} - - -#' Helper function to create proposal -#' @param case Type of Twalk move. Either "walk", "traverse", "hop" or "blow" -#' @param Npar number of parameters -#' @param pn1 Probability determining the number of parameters that are changed. -#' @param aw "walk" move proposal parameter. -#' @param beta parameter for "traverse" move proposals. -#' @param x parameter vector of chain 1 -#' @param x2 parameter vector of chain 2 -#' @references Christen, J. Andres, and Colin Fox. "A general purpose sampling algorithm for continuous distributions (the t-walk)." Bayesian Analysis 5.2 (2010): 263-281. -#' @keywords internal -propFun <- function(case, Npar, pn1, x, x2, beta = NULL, aw = NULL){ - - switch(case, - "traverse"={ - pSel <- (runif(Npar) < pn1) - prop <- NULL - for (i in 1:Npar){ - if (pSel[i]) prop <- c( prop, x2[i] + beta*(x2[i] - x[i])) - else prop <- c( prop, x[i]) - } - return(list(prop=prop, npSel=sum(pSel))) - }, - "walk"={ - u <- runif(Npar) - pSel <- (runif(Npar) < pn1) - z <- (aw/(1+aw))*(aw*u^2 + 2*u -1) - z <- z*pSel - return(list( prop=x + (x - x2)*z, npSel=sum(pSel))) - }, - "blow"={ - pSel <- (runif(Npar) < pn1) - sigma <- max(pSel*abs(x2 - x)) - return(list( prop=x2*pSel + sigma*rnorm(Npar)*pSel + x*(1-pSel), npSel=sum(pSel), pSel=pSel)) - - }, - "hop"={ - pSel <- (runif(Npar) < pn1) - sigma <- max(pSel*abs(x2 - x))/3 - prop <- NULL - for (i in 1:Npar){ - if (pSel[i]) prop <- c( prop, x[i] + sigma*rnorm(1)) - else prop <- c( prop, x[i]) - } - return(list( prop=prop, npSel=sum(pSel), pSel=pSel)) - - } - - ) -} - - -#' Helper function for calculating beta -#' @param at "traverse" move proposal parameter. -#' @keywords internal -betaFun <- 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)))) -} - - -#' Helper function for blow and hop moves -#' @param case Type of Twalk move. Either "hop" or "blow" -#' @param npSel number of parameters that are changed. -#' @param pSel vector containing information about which parameters are changed. -#' @param h Parameter for "blow" and hop moves -#' @param x parameter vector of chain 1 -#' @param x2 parameter vector of chain 2 -#' @references Christen, J. Andres, and Colin Fox. "A general purpose sampling algorithm for continuous distributions (the t-walk)." Bayesian Analysis 5.2 (2010): 263-281. -#' @keywords internal -Gfun <- function(case, npSel, pSel, h, x, x2){ - switch(case, - "blow"= { - sigma <- max(pSel*abs(x2 - x)) - if(npSel > 0) return((npSel/2)*log(2*pi) + npSel*log(sigma) + 0.5*sumSquare(h - x2)/(sigma^2)) - else return(0) - }, - "hop" = { - sigma <- max(pSel*abs(x2 - x))/3 - if (npSel > 0) return((npSel/2)*log(2*pi) - npSel*log(3) + npSel*log(sigma) + 0.5*9*sumSquare((h - x))/(sigma^2)) - else return(0) - }) - -} - - - +###### +# Twalk helper functions +###### + + +#' Wrapper for step function +#' @param Npar number of parameters +#' @param FUN log posterior density +#' @param x parameter vector of chain 1 +#' @param Eval last evaluation of x +#' @param x2 parameter vector of chain 2 +#' @param Eval2 last evaluation of x +#' @param at "traverse" move proposal parameter. +#' @param aw "walk" move proposal parameter. +#' @param pn1 Probability determining the number of parameters that are changed. +#' @param Ptrav Move probability of "traverse" moves, default to 0.4918 +#' @param Pwalk Move probability of "walk" moves, default to 0.4918 +#' @param Pblow Move probability of "blow" moves, default to 0.0082 +#' @param Phop Move probability of "hop" moves +#' @references Christen, J. Andres, and Colin Fox. "A general purpose sampling algorithm for continuous distributions (the t-walk)." Bayesian Analysis 5.2 (2010): 263-281. +#' @keywords internal +TwalkMove <- function (Npar, FUN, x, Eval, x2, Eval2, at = 6, aw = 1.5, pn1 = min(Npar, 4)/Npar, + Ptrav = 0.4918, Pwalk = 0.4918, Pblow = 0.0082, Phop = 0.0082) +{ + + p <- sample(4,1, prob = c(Ptrav,Pwalk,Pblow,Phop)) + + if(p == 1)case <- "traverse" + else if(p ==2) case <- "walk" + else if(p ==3) case <- "blow" + else case <- "hop" + + + out <- Twalksteps(case = case, Npar = Npar, FUN = FUN, x = x, + Eval = Eval, x2 = x2, Eval2 = Eval2, at = at, aw = aw, pn1 = pn1) + + + return(list(y = out$y, val = out$val, y2 = out$y2, val2 = out$val2, alpha = out$alpha)) +} + + + +#' Main function that is executing and evaluating the moves +#' @param case Type of Twalk move. Either "walk", "traverse", "hop" or "blow" +#' @param Npar number of parameters +#' @param FUN Log posterior density +#' @param x parameter vector of chain 1 +#' @param Eval last evaluation of x +#' @param x2 parameter vector of chain 2 +#' @param Eval2 last evaluation of x +#' @param at "traverse" move proposal parameter. +#' @param aw "walk" move proposal parameter. +#' @param pn1 Probability determining the number of parameters that are changed. +#' @references Christen, J. Andres, and Colin Fox. "A general purpose sampling algorithm for continuous distributions (the t-walk)." Bayesian Analysis 5.2 (2010): 263-281. +#' @keywords internal +Twalksteps <- function(case, Npar, FUN, x, + Eval, x2, Eval2, at, aw, pn1){ + + val <- NULL + val2 <- NULL + p <- runif(1) + + switch(case, + "traverse" = { #Traverse + if (p < 0.5) { + beta <- betaFun(at) + tmp <- propFun(case, Npar = Npar, pn1 = pn1, x2 = x, x = x2, beta = beta) + y2 <- tmp$prop + npSel <- tmp$npSel + y <- x + val <- Eval + val2 <- FUN(y2, returnAll = T) + + if (npSel == 0) alpha <- 1 + else alpha <- exp((- Eval2[1] + val2[1]) + (npSel - 2) * log(beta)) + + }else{ + beta <- betaFun(at) + tmp <- propFun(case, Npar = Npar, pn1 = pn1, x = x, x2 = x2, beta = beta) + y <- tmp$prop + npSel <- tmp$npSel + y2 <- x2 + val2 <- Eval2 + + val <- FUN(y, returnAll = T) + + if (npSel == 0) alpha <- 1 + else alpha <- exp((-Eval[1] + val[1]) + (npSel - 2) * log(beta)) + + }}, # End traverse + "walk" = { # walk + if (p < 0.5) { + tmp <- propFun(case, Npar = Npar, pn1 = pn1, aw = aw, x2 = x, x = x2) + y2 <- tmp$prop + npSel <- tmp$npSel + y <- x + val <- Eval + if ( (all(abs(y2 - y) > 0))) { + val2 <- FUN(y2, returnAll = T) + + alpha <- exp(-Eval2[1] + val2[1]) + } + else { + alpha <- 0 + } + }else{ + tmp <- propFun(case, Npar = Npar, pn1 = pn1, aw = aw, x = x, x2 = x2) + y <- tmp$prop + npSel <- tmp$npSel + y2 <- x2 + val2 <- Eval2 + if ( (all(abs(y2 - y) > 0))) { + val <- FUN(y, returnAll = T) + + alpha <- exp(-Eval[1] + val[1]) + } + else { + alpha <- 0 + } + }}, # End walk + "blow" = { #blow + if (p < 0.5) { + tmp <- propFun(case, Npar = Npar, pn1 = pn1, x = x2, x2 = x) + y2 <- tmp$prop + npSel <- tmp$npSel + pSel <- tmp$pSel + y <- x + val <- Eval + if ( all(y2 != x)) { + val2 <- FUN(y2, returnAll = T) + + G1 <- Gfun(case, npSel, pSel, y2, x2, x) + G2 <- Gfun(case, npSel, pSel, x2, y2, x) + alpha <- exp((-Eval2[1] + val2[1]) + (G1 - G2)) + } + else { + alpha <- 0 + } + }else{ + tmp <- propFun(case, Npar = Npar, pn1 = pn1, x = x, x2 = x2) + y <- tmp$prop + npSel <- tmp$npSel + pSel <- tmp$pSel + y2 <- x2 + val2 <- Eval2 + if (all(y != x2)) { + val <- FUN(y, returnAll = T) + + G1 <- Gfun(case, npSel, pSel, y, x, x2) + G2 <- Gfun(case, npSel, pSel, x, y, x2) + alpha <- exp((-Eval[1] + val[1]) + (G1 - G2)) + } + else { + alpha <- 0 + } + } + }, # End blow + "hop" = { #hop + if (p < 0.5) { + tmp <- propFun(case, Npar = Npar, pn1 = pn1, x2 = x, x = x2) + y2 <- tmp$prop + npSel <- tmp$npSel + pSel <- tmp$pSel + y <- x + val <- Eval + if ( all(y2 != x)) { + val2 <- FUN(y2, returnAll = T) + + G1 <- Gfun(case, npSel, pSel, y2, x2, x) + G2 <- Gfun(case, npSel, pSel, x2, y2, x) + alpha <- exp((-Eval2[1] + val2[1]) + (G1 - G2)) + } + else { + alpha <- 0 + } + }else{ + tmp <- propFun(case, Npar = Npar, pn1 = pn1, x = x, x2 = x2) + y <- tmp$prop + npSel <- tmp$npSel + pSel <- tmp$pSel + y2 <- x2 + val2 <- Eval2 + if ( all(y != x2)) { + val <- FUN(y, returnAll = T) + + G1 <- Gfun(case, npSel, pSel, y, x, x2) + G2 <- Gfun(case, npSel, pSel, x, y, x2) + alpha <- exp((-Eval[1] + val[1]) + (G1 - G2)) + } + else { + alpha <- 0 + } + + }}) # End hop and end switch + return(list(y = y, val = val, y2 = y2, val2 = val2, alpha = alpha, + npSel = npSel)) +} + + + + + + + +################## Helper functions +############################################################### + +#' Helper function for sum of x*x +#' @param x vector of values +#' @keywords internal +sumSquare <- function(x){return(sum(x*x))} + + +#' Helper function to create proposal +#' @param case Type of Twalk move. Either "walk", "traverse", "hop" or "blow" +#' @param Npar number of parameters +#' @param pn1 Probability determining the number of parameters that are changed. +#' @param aw "walk" move proposal parameter. +#' @param beta parameter for "traverse" move proposals. +#' @param x parameter vector of chain 1 +#' @param x2 parameter vector of chain 2 +#' @references Christen, J. Andres, and Colin Fox. "A general purpose sampling algorithm for continuous distributions (the t-walk)." Bayesian Analysis 5.2 (2010): 263-281. +#' @keywords internal +propFun <- function(case, Npar, pn1, x, x2, beta = NULL, aw = NULL){ + + switch(case, + "traverse"={ + pSel <- (runif(Npar) < pn1) + prop <- NULL + for (i in 1:Npar){ + if (pSel[i]) prop <- c( prop, x2[i] + beta*(x2[i] - x[i])) + else prop <- c( prop, x[i]) + } + return(list(prop=prop, npSel=sum(pSel))) + }, + "walk"={ + u <- runif(Npar) + pSel <- (runif(Npar) < pn1) + z <- (aw/(1+aw))*(aw*u^2 + 2*u -1) + z <- z*pSel + return(list( prop=x + (x - x2)*z, npSel=sum(pSel))) + }, + "blow"={ + pSel <- (runif(Npar) < pn1) + sigma <- max(pSel*abs(x2 - x)) + return(list( prop=x2*pSel + sigma*rnorm(Npar)*pSel + x*(1-pSel), npSel=sum(pSel), pSel=pSel)) + + }, + "hop"={ + pSel <- (runif(Npar) < pn1) + sigma <- max(pSel*abs(x2 - x))/3 + prop <- NULL + for (i in 1:Npar){ + if (pSel[i]) prop <- c( prop, x[i] + sigma*rnorm(1)) + else prop <- c( prop, x[i]) + } + return(list( prop=prop, npSel=sum(pSel), pSel=pSel)) + + } + + ) +} + + +#' Helper function for calculating beta +#' @param at "traverse" move proposal parameter. +#' @keywords internal +betaFun <- 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)))) +} + + +#' Helper function for blow and hop moves +#' @param case Type of Twalk move. Either "hop" or "blow" +#' @param npSel number of parameters that are changed. +#' @param pSel vector containing information about which parameters are changed. +#' @param h Parameter for "blow" and hop moves +#' @param x parameter vector of chain 1 +#' @param x2 parameter vector of chain 2 +#' @references Christen, J. Andres, and Colin Fox. "A general purpose sampling algorithm for continuous distributions (the t-walk)." Bayesian Analysis 5.2 (2010): 263-281. +#' @keywords internal +Gfun <- function(case, npSel, pSel, h, x, x2){ + switch(case, + "blow"= { + sigma <- max(pSel*abs(x2 - x)) + if(npSel > 0) return((npSel/2)*log(2*pi) + npSel*log(sigma) + 0.5*sumSquare(h - x2)/(sigma^2)) + else return(0) + }, + "hop" = { + sigma <- max(pSel*abs(x2 - x))/3 + if (npSel > 0) return((npSel/2)*log(2*pi) - npSel*log(3) + npSel*log(sigma) + 0.5*9*sumSquare((h - x))/(sigma^2)) + else return(0) + }) + +} + + + diff --git a/BayesianTools/R/plotCorrelationDensity.r b/BayesianTools/R/plotCorrelationDensity.r index 9c07bb6..3f4a816 100644 --- a/BayesianTools/R/plotCorrelationDensity.r +++ b/BayesianTools/R/plotCorrelationDensity.r @@ -1,89 +1,90 @@ -#' Flexible function to create correlation density plots -#' @author Florian Hartig -#' @param mat object of class "bayesianOutput" or a matrix or data frame of variables -#' @param density type of plot to do. Either "smooth" (default), "corellipseCor", or "ellipse" -#' @param thin thinning of the matrix to make things faster. Default is to thin to 5000 -#' @param method method for calculating correlations. Possible choices are "pearson" (default), "kendall" and "spearman" -#' @param whichParameters indices of parameters that should be plotted -#' @param scaleCorText should the text to display correlation be scaled to the strength of the correlation? -#' @param ... additional parameters to pass on to the \code{\link{getSample}}, for example parametersOnly = F, or start = 1000 -#' @references The code for the correlation density plot originates from Hartig, F.; Dislich, C.; Wiegand, T. & Huth, A. (2014) Technical Note: Approximate Bayesian parameterization of a process-based tropical forest model. Biogeosciences, 11, 1261-1272. -#' @export -#' @seealso \code{\link{marginalPlot}} \cr -#' \code{\link{plotTimeSeries}} \cr -#' \code{\link{tracePlot}} \cr -#' @example /inst/examples/correlationPlotHelp.R - -correlationPlot<- function(mat, density = "smooth", thin = "auto", method = "pearson", whichParameters = NULL, scaleCorText = T, ...){ - - mat = getSample(mat, thin = thin, whichParameters = whichParameters, ...) - - numPars = ncol(mat) - - if(numPars < 2) stop("BayesianTools::correlationPlot - using this function only makes sense if you have more than 1 parameter") - - names = colnames(mat) - - panel.hist.dens <- function(x, ...) - { - usr <- par("usr"); on.exit(par(usr = usr)) - par(usr = c(usr[1:2], 0, 1.5) ) - h <- hist(x, plot = FALSE) - breaks <- h$breaks; nB <- length(breaks) - y <- h$counts; y <- y/max(y) - rect(breaks[-nB], 0, breaks[-1], y, col="blue4", ...) - } - - # replaced by spearman - panel.cor <- function(x, y, digits = 2, prefix = "", cex.cor, ...) - { - usr <- par("usr"); on.exit(par(usr = usr)) - par(usr = c(0, 1, 0, 1)) - r <- cor(x, y, use = "complete.obs", method = method) - txt <- format(c(r, 0.123456789), digits = digits)[1] - txt <- paste0(prefix, txt) - if(missing(cex.cor)) cex.cor <- 0.8/strwidth(txt) - if(scaleCorText == T) text(0.5, 0.5, txt, cex = cex.cor * abs(r)) - else text(0.5, 0.5, txt, cex = cex.cor) - } - - plotEllipse <- function(x,y){ - usr <- par("usr"); on.exit(par(usr = usr)) - par(usr = c(usr[1:2], 0, 1.5) ) - cor <- cor(x,y) - el = ellipse::ellipse(cor) - polygon(el[,1] + mean(x), el[,2] + mean(y), col = "red") - } - - - correlationEllipse <- function(x){ - cor = cor(x) - ToRGB <- function(x){grDevices::rgb(x[1]/255, x[2]/255, x[3]/255)} - C1 <- ToRGB(c(178, 24, 43)) - C2 <- ToRGB(c(214, 96, 77)) - C3 <- ToRGB(c(244, 165, 130)) - C4 <- ToRGB(c(253, 219, 199)) - C5 <- ToRGB(c(247, 247, 247)) - C6 <- ToRGB(c(209, 229, 240)) - C7 <- ToRGB(c(146, 197, 222)) - C8 <- ToRGB(c(67, 147, 195)) - C9 <- ToRGB(c(33, 102, 172)) - CustomPalette <- grDevices::colorRampPalette(rev(c(C1, C2, C3, C4, C5, C6, C7, C8, C9))) - ord <- order(cor[1, ]) - xc <- cor[ord, ord] - colors <- unlist(CustomPalette(100)) - ellipse::plotcorr(xc, col=colors[xc * 50 + 50]) - } - - if (density == "smooth"){ - return(pairs(mat, lower.panel=function(...) {par(new=TRUE);IDPmisc::ipanel.smooth(...)}, diag.panel=panel.hist.dens, upper.panel=panel.cor)) - }else if (density == "corellipseCor"){ - return(pairs(mat, lower.panel=plotEllipse, diag.panel=panel.hist.dens, upper.panel=panel.cor)) - }else if (density == "ellipse"){ - correlationEllipse(mat) - }else if (density == F){ - return(pairs(mat, lower.panel=panel.cor, diag.panel=panel.hist.dens, upper.panel=panel.cor)) - }else stop("wrong sensity argument") - -} - + +#' Flexible function to create correlation density plots +#' @author Florian Hartig +#' @param mat object of class "bayesianOutput" or a matrix or data frame of variables +#' @param density type of plot to do. Either "smooth" (default), "corellipseCor", or "ellipse" +#' @param thin thinning of the matrix to make things faster. Default is to thin to 5000 +#' @param method method for calculating correlations. Possible choices are "pearson" (default), "kendall" and "spearman" +#' @param whichParameters indices of parameters that should be plotted +#' @param scaleCorText should the text to display correlation be scaled to the strength of the correlation? +#' @param ... additional parameters to pass on to the \code{\link{getSample}}, for example parametersOnly = F, or start = 1000 +#' @references The code for the correlation density plot originates from Hartig, F.; Dislich, C.; Wiegand, T. & Huth, A. (2014) Technical Note: Approximate Bayesian parameterization of a process-based tropical forest model. Biogeosciences, 11, 1261-1272. +#' @export +#' @seealso \code{\link{marginalPlot}} \cr +#' \code{\link{plotTimeSeries}} \cr +#' \code{\link{tracePlot}} \cr +#' @example /inst/examples/correlationPlotHelp.R + +correlationPlot<- function(mat, density = "smooth", thin = "auto", method = "pearson", whichParameters = NULL, scaleCorText = T, ...){ + + mat = getSample(mat, thin = thin, whichParameters = whichParameters, ...) + + numPars = ncol(mat) + + if(numPars < 2) stop("BayesianTools::correlationPlot - using this function only makes sense if you have more than 1 parameter") + + names = colnames(mat) + + panel.hist.dens <- function(x, ...) + { + usr <- par("usr"); on.exit(par(usr = usr)) + par(usr = c(usr[1:2], 0, 1.5) ) + h <- hist(x, plot = FALSE) + breaks <- h$breaks; nB <- length(breaks) + y <- h$counts; y <- y/max(y) + rect(breaks[-nB], 0, breaks[-1], y, col="blue4", ...) + } + + # replaced by spearman + panel.cor <- function(x, y, digits = 2, prefix = "", cex.cor, ...) + { + usr <- par("usr"); on.exit(par(usr = usr)) + par(usr = c(0, 1, 0, 1)) + r <- cor(x, y, use = "complete.obs", method = method) + txt <- format(c(r, 0.123456789), digits = digits)[1] + txt <- paste0(prefix, txt) + if(missing(cex.cor)) cex.cor <- 0.8/strwidth(txt) + if(scaleCorText == T) text(0.5, 0.5, txt, cex = cex.cor * abs(r)) + else text(0.5, 0.5, txt, cex = cex.cor) + } + + plotEllipse <- function(x,y){ + usr <- par("usr"); on.exit(par(usr = usr)) + par(usr = c(usr[1:2], 0, 1.5) ) + cor <- cor(x,y) + el = ellipse::ellipse(cor) + polygon(el[,1] + mean(x), el[,2] + mean(y), col = "red") + } + + + correlationEllipse <- function(x){ + cor = cor(x) + ToRGB <- function(x){grDevices::rgb(x[1]/255, x[2]/255, x[3]/255)} + C1 <- ToRGB(c(178, 24, 43)) + C2 <- ToRGB(c(214, 96, 77)) + C3 <- ToRGB(c(244, 165, 130)) + C4 <- ToRGB(c(253, 219, 199)) + C5 <- ToRGB(c(247, 247, 247)) + C6 <- ToRGB(c(209, 229, 240)) + C7 <- ToRGB(c(146, 197, 222)) + C8 <- ToRGB(c(67, 147, 195)) + C9 <- ToRGB(c(33, 102, 172)) + CustomPalette <- grDevices::colorRampPalette(rev(c(C1, C2, C3, C4, C5, C6, C7, C8, C9))) + ord <- order(cor[1, ]) + xc <- cor[ord, ord] + colors <- unlist(CustomPalette(100)) + ellipse::plotcorr(xc, col=colors[xc * 50 + 50]) + } + + if (density == "smooth"){ + return(pairs(mat, lower.panel=function(...) {par(new=TRUE);IDPmisc::ipanel.smooth(...)}, diag.panel=panel.hist.dens, upper.panel=panel.cor)) + }else if (density == "corellipseCor"){ + return(pairs(mat, lower.panel=plotEllipse, diag.panel=panel.hist.dens, upper.panel=panel.cor)) + }else if (density == "ellipse"){ + correlationEllipse(mat) + }else if (density == F){ + return(pairs(mat, lower.panel=panel.cor, diag.panel=panel.hist.dens, upper.panel=panel.cor)) + }else stop("wrong sensity argument") + +} + diff --git a/BayesianTools/R/plotDiagnostic.R b/BayesianTools/R/plotDiagnostic.R index 27caf6a..b4be268 100644 --- a/BayesianTools/R/plotDiagnostic.R +++ b/BayesianTools/R/plotDiagnostic.R @@ -1,251 +1,248 @@ -#' @author Maximilian Pichler -#' @title Diagnostic Plot -#' @description This function plots the DIC, WAIC, mPSRF, PSRF(with upper C.I.) and traces of the parameters in dependence of iterations. DIC, WAIC are plotted separately for the chains and the trace plots also for the internal chains. -#' @param out object of class "bayesianOutput" -#' @param start start value for calculating DIC, WAIC, mPSRF and PSRF, default = 50 -#' @param numSamples for calculating WAIC, default = 10 because of high computational costs -#' @param window plot range to show, vector of percents or only one value as start value for the window -#' @param plotWAIC logical, whether to calculate WAIC or not, default = T -#' @param plotPSRF logical, whether to calculate and plot mPSRF/PSRF or not, default = T -#' @param plotDIC logical, whether to calculate and plot DIC or not, default = T -#' @param plotTrace logical, whether to show trace plots or not, default = T -#' @param graphicParameters graphic parameters as list for plot function -#' @param ... parameters to give to getSample -#' @example /inst/examples/plotDiagnosticHelp.R -#' @export - - - -plotDiagnostic <- function(out, start = 50, numSamples = 100, window = 0.2, plotWAIC = F, plotPSRF = T, plotDIC = T, plotTrace = T, graphicParameters = NULL, ...){ - - oldpar = NULL - on.exit(par(oldpar)) - - - - if(!"bayesianOutput" %in% class(out)) stop("Wrong input, object of class bayesianOutput required. see runMCMC()") - - calcWAIC <- TRUE - - if("mcmcSamplerList" %in% class(out) && out[[1]]$setup$pwLikelihood) calcWAIC <- FALSE - - if("mcmcSampler" %in% class(out) && out$setup$pwLikelihood) calcWAIC <- FALSE - - if(!plotWAIC) calcWAIC <- FALSE - - - defaultGraphicParameters <- graphicParameters - - - # calculate DIC and WAIC, minimum range: start - start+1 - if("mcmcSamplerList" %in% class(out)){ - - if(is.matrix(out[[1]]$chain)) len <- out[[1]]$settings$iterations - else len <- round(out[[1]]$settings$iterations / length(out[[1]]$chain)) - - iter = out[[1]]$settings$iterations - - internal = length(out[[1]]$chain) - - start = start + 1 - - lenW <- length(seq(start , by = 10, to = len)) - - DICResult <- matrix(NA, nrow = length(out), ncol = len - start) - - WAICResult<- matrix(NA, nrow = length(out), ncol = length(seq(start , by = 10, to = len))) - - numPars <- out[[1]]$setup$numPars - - Wseq <- seq(start , by = 10, to = len) - - for(i in 1:length(out)) { - if(plotDIC) DICResult[i,] <- sapply(start:len, FUN = function(x){return(DIC(out[[i]], start = start - 1 , end = x, ...)$DIC)}) - if(calcWAIC) WAICResult[i,] <- sapply(seq(start , by = 10, to = len), FUN = function(x){return(WAIC(out[[i]], start = start - 1 ,end = x, numSamples = numSamples, ...)$WAIC1)}) - } - - } else { - if(is.matrix(out$chain)) len <- out$settings$iterations - - else len <- round(out$settings$iterations / length(out$chain)) - - internal = length(out$chain) - - iter = out$settings$iterations - - start = start + 1 - - lenW<- length(seq(start, by = 10, to = len)) - - Wseq <- seq(start , by = 10, to = len) - - if(plotDIC) DICResult <- sapply(start:len, FUN = function(x){return(DIC(out, start = start - 1, end = x, ...)$DIC)}) - - if(calcWAIC) WAICResult<- sapply(seq(start, by = 10, to = len), FUN = function(x){return(WAIC(out, end = x, start = start - 1, numSamples = numSamples, ...)$WAIC1)}) - - numPars <- out$setup$numPars - } - - # TODO: missing: check if sampler with multiple chains - # should user call method with plotPSFR=F for one-chain-sampler? - - # calc mPSRF, first checking which low values we could calculate - if(plotPSRF){ - - seq <- vector() - for(i in start:len){ - success <- try(coda::gelman.diag(getSample(out, start = start - 1, parametersOnly = T, coda = T, end = i, ...))$mpsrf, silent = T) - if(!"try-error" %in% class(success)){ - # break - seq[i] <- i - } - } - seq <- seq[complete.cases(seq)] - - # calculate the actual PSRF values - if(numPars > 1) PSRF <- matrix(0, nrow = length(seq), ncol = numPars*2 + 1) - else PSRF <- matrix(0, nrow = length(seq), ncol = numPars*2 ) - - for(i in 1:length(seq)){ - res <- coda::gelman.diag(getSample(out, start = start - 1, parametersOnly = T, coda = T, end = seq[i], ...)) - if(numPars > 1)PSRF[i,] <- c(as.vector(res$psrf), res$mpsrf) - else PSRF[i,] <- c(as.vector(res$psrf)) - } - } - - - # Get number of plots - nrPlots <- 2 - if(calcWAIC) nrPlots <- nrPlots + 1 - if(plotDIC) nrPlots <- nrPlots + 1 - if(plotPSRF) nrPlots <- nrPlots + 2 - if(plotTrace) nrPlots<- numPars*2 + nrPlots - par(mfrow = getPanels(nrPlots)) - - - - - # set graphicParameters - if(is.null(graphicParameters)){ - graphicParameters = list(lty = 1, lwd = 1, type = "l", xlab = "Iterations", ylab = "", col = 1:6) - } else { - if(is.null(graphicParameters$lty)) graphicParameters$lty = 1 - if(is.null(graphicParameters$lwd)) graphicParameters$lwd = 1 - if(is.null(graphicParameters$type)) graphicParameters$type = "l" - if(is.null(graphicParameters$xlab)) graphicParameters$xlab = "Iterations" - if(is.null(graphicParameters$ylab)) graphicParameters$ylab = "" - if(is.null(graphicParameters$col)) graphicParameters$col = 1:6 - } - - - - # plot DIC - if(plotDIC){ - - - if(is.matrix(DICResult)){ - # col <- 1:ncol(DICResult) - if(is.na(window[2])) endV <- nrow(DICResult) - else endV <- window[2]*nrow(DICResult) - startV <- window[1]*nrow(DICResult) - x = nrow(DICResult) - ylim = c(min(DICResult[startV:endV,])*0.99, max(DICResult[startV:endV,])*1.01) - } else { - if(is.na(window[2])) endV <- length(DICResult) - else endV <- window[2]*length(DICResult) - startV <- window[1]*length(DICResult) - x = length(DICResult) - ylim = c(min(DICResult[startV:endV])*0.99, max(DICResult[startV:endV])*1.01) - } - graphicParameters$y = DICResult - graphicParameters$x = 1:x - graphicParameters$main = "DIC" - graphicParameters$xlim = c(startV, endV) - graphicParameters$ylim = ylim - if(is.null(graphicParameters$xaxt)) graphicParameters$xaxt = "n" - do.call(matplot, graphicParameters) - if(graphicParameters$xaxt == "n" ){ - axis(1, at = seq(startV, by = 100, to = endV), labels = seq(startV, by = 100, to = endV)*internal) - graphicParameters$xaxt <- NULL - } - } - - - # plot WAIC - if(calcWAIC){ - if(is.matrix(WAICResult)){ - # col <- 1:ncol(DICResult) - if(is.na(window[2])) endV <- nrow(WAICResult) - else endV <- window[2]*nrow(WAICResult) - startV <- window[1]*nrow(WAICResult) - x = nrow(WAICResult) - ylim = c(min(WAICResult[startV:endV,])*0.99, max(WAICResult[startV:endV,])*1.01) - } else { - if(is.na(window[2])) endV <- length(WAICResult) - else endV <- window[2]*length(WAICResult) - startV <- window[1]*length(WAICResult) - x = length(WAICResult) - ylim = c(min(WAICResult[startV:endV])*0.99, max(WAICResult[startV:endV])*1.01) - } - graphicParameters$y = WAICResult - graphicParameters$x = 1:x - graphicParameters$main = "WAIC" - graphicParameters$xlim = c(startV, endV) - graphicParameters$ylim = ylim - if(is.null(graphicParameters$xaxt)) graphicParameters$xaxt = "n" - do.call(matplot, graphicParameters) - if(graphicParameters$xaxt == "n" ){ - axis(1, at = seq(startV, by = 10, to = endV), labels = seq(startV, by = 10, to = endV)*10*internal) - graphicParameters$xaxt <- NULL - } - - } - - - if(plotPSRF){ - if(is.na(window[2])) endV <- nrow(PSRF) - else endV <- window[2]*nrow(PSRF) - startV <- window[1]*nrow(PSRF) - graphicParameters$xlim = c(startV, endV) - graphicParameters$x = 1:nrow(PSRF) - # plot mPSRF - if(numPars > 1){ - if(!typeof(seq) == "logical" ) { - - graphicParameters$ylim = c(min(PSRF[startV:endV,ncol(PSRF)])*0.99, max(PSRF[startV:endV,ncol(PSRF)])*1.01) - graphicParameters$y = PSRF[,ncol(PSRF)] - graphicParameters$main = "mPSRF" - do.call(plot, graphicParameters) - } - } - - graphicParameters$ylim = c(min(PSRF[startV:endV,-ncol(PSRF)])*0.99, max(PSRF[startV:endV,-ncol(PSRF)])*1.01) - graphicParameters$y = PSRF[,-ncol(PSRF)] - graphicParameters$main = "PSRF" - - lty = NULL - for(i in 1:numPars)lty <- c(lty, c(1,2)) - graphicParameters$lty <- lty - - col = NULL - for(i in 1:6)col <- c(col, c(i,i)) - graphicParameters$col <- col - - do.call(matplot, graphicParameters) - - } - # plot parameter traces - if(plotTrace){ - # if(is.null(defaultGraphicParameters)) defaultGraphicParameters <- list() - # if(is.na(window[2])) endV <- len - # else endV <- window[2]*len - # defaultGraphicParameters$xlim <- c(len*window[1], endV) - # defaultGraphicParameters$ask = F - # defaultGraphicParameters$auto.layout = F - # defaultGraphicParameters$x = getSample(out, start = start, coda = T, parametersOnly = T,...) - # do.call(coda::cumuplot, defaultGraphicParameters) - - coda::cumuplot(getSample(out, start = start, coda = T, parametersOnly = T, ...), ask = F, auto.layout = F) - } -} - +#' @author Maximilian Pichler +#' @title Diagnostic Plot +#' @description This function plots the DIC, WAIC, mPSRF, PSRF(with upper C.I.) and traces of the parameters in dependence of iterations. DIC, WAIC are plotted separately for the chains and the trace plots also for the internal chains. +#' @param out object of class "bayesianOutput" +#' @param start start value for calculating DIC, WAIC, mPSRF and PSRF, default = 50 +#' @param numSamples for calculating WAIC, default = 10 because of high computational costs +#' @param window plot range to show, vector of percents or only one value as start value for the window +#' @param plotWAIC logical, whether to calculate WAIC or not, default = T +#' @param plotPSRF logical, whether to calculate and plot mPSRF/PSRF or not, default = T +#' @param plotDIC logical, whether to calculate and plot DIC or not, default = T +#' @param plotTrace logical, whether to show trace plots or not, default = T +#' @param graphicParameters graphic parameters as list for plot function +#' @param ... parameters to give to getSample +#' @example /inst/examples/plotDiagnosticHelp.R +#' @export +plotDiagnostic <- function(out, start = 50, numSamples = 100, window = 0.2, plotWAIC = F, plotPSRF = T, plotDIC = T, plotTrace = T, graphicParameters = NULL, ...){ + + oldpar = NULL + on.exit(par(oldpar)) + + + + if(!"bayesianOutput" %in% class(out)) stop("Wrong input, object of class bayesianOutput required. see runMCMC()") + + calcWAIC <- TRUE + + if("mcmcSamplerList" %in% class(out) && out[[1]]$setup$pwLikelihood) calcWAIC <- FALSE + + if("mcmcSampler" %in% class(out) && out$setup$pwLikelihood) calcWAIC <- FALSE + + if(!plotWAIC) calcWAIC <- FALSE + + + defaultGraphicParameters <- graphicParameters + + + # calculate DIC and WAIC, minimum range: start - start+1 + if("mcmcSamplerList" %in% class(out)){ + + if(is.matrix(out[[1]]$chain)) len <- out[[1]]$settings$iterations + else len <- round(out[[1]]$settings$iterations / length(out[[1]]$chain)) + + iter = out[[1]]$settings$iterations + + internal = length(out[[1]]$chain) + + start = start + 1 + + lenW <- length(seq(start , by = 10, to = len)) + + DICResult <- matrix(NA, nrow = length(out), ncol = len - start) + + WAICResult<- matrix(NA, nrow = length(out), ncol = length(seq(start , by = 10, to = len))) + + numPars <- out[[1]]$setup$numPars + + Wseq <- seq(start , by = 10, to = len) + + for(i in 1:length(out)) { + if(plotDIC) DICResult[i,] <- sapply(start:len, FUN = function(x){return(DIC(out[[i]], start = start - 1 , end = x, ...)$DIC)}) + if(calcWAIC) WAICResult[i,] <- sapply(seq(start , by = 10, to = len), FUN = function(x){return(WAIC(out[[i]], start = start - 1 ,end = x, numSamples = numSamples, ...)$WAIC1)}) + } + + } else { + if(is.matrix(out$chain)) len <- out$settings$iterations + + else len <- round(out$settings$iterations / length(out$chain)) + + internal = length(out$chain) + + iter = out$settings$iterations + + start = start + 1 + + lenW<- length(seq(start, by = 10, to = len)) + + Wseq <- seq(start , by = 10, to = len) + + if(plotDIC) DICResult <- sapply(start:len, FUN = function(x){return(DIC(out, start = start - 1, end = x, ...)$DIC)}) + + if(calcWAIC) WAICResult<- sapply(seq(start, by = 10, to = len), FUN = function(x){return(WAIC(out, end = x, start = start - 1, numSamples = numSamples, ...)$WAIC1)}) + + numPars <- out$setup$numPars + } + + # TODO: missing: check if sampler with multiple chains + # should user call method with plotPSFR=F for one-chain-sampler? + + # calc mPSRF, first checking which low values we could calculate + if(plotPSRF){ + + seq <- vector() + for(i in start:len){ + success <- try(coda::gelman.diag(getSample(out, start = start - 1, parametersOnly = T, coda = T, end = i, ...))$mpsrf, silent = T) + if(!"try-error" %in% class(success)){ + # break + seq[i] <- i + } + } + seq <- seq[complete.cases(seq)] + + # calculate the actual PSRF values + if(numPars > 1) PSRF <- matrix(0, nrow = length(seq), ncol = numPars*2 + 1) + else PSRF <- matrix(0, nrow = length(seq), ncol = numPars*2 ) + + for(i in 1:length(seq)){ + res <- coda::gelman.diag(getSample(out, start = start - 1, parametersOnly = T, coda = T, end = seq[i], ...)) + if(numPars > 1)PSRF[i,] <- c(as.vector(res$psrf), res$mpsrf) + else PSRF[i,] <- c(as.vector(res$psrf)) + } + } + + + # Get number of plots + nrPlots <- 2 + if(calcWAIC) nrPlots <- nrPlots + 1 + if(plotDIC) nrPlots <- nrPlots + 1 + if(plotPSRF) nrPlots <- nrPlots + 2 + if(plotTrace) nrPlots<- numPars*2 + nrPlots + par(mfrow = getPanels(nrPlots)) + + + + + # set graphicParameters + if(is.null(graphicParameters)){ + graphicParameters = list(lty = 1, lwd = 1, type = "l", xlab = "Iterations", ylab = "", col = 1:6) + } else { + if(is.null(graphicParameters$lty)) graphicParameters$lty = 1 + if(is.null(graphicParameters$lwd)) graphicParameters$lwd = 1 + if(is.null(graphicParameters$type)) graphicParameters$type = "l" + if(is.null(graphicParameters$xlab)) graphicParameters$xlab = "Iterations" + if(is.null(graphicParameters$ylab)) graphicParameters$ylab = "" + if(is.null(graphicParameters$col)) graphicParameters$col = 1:6 + } + + + + # plot DIC + if(plotDIC){ + + + if(is.matrix(DICResult)){ + # col <- 1:ncol(DICResult) + if(is.na(window[2])) endV <- nrow(DICResult) + else endV <- window[2]*nrow(DICResult) + startV <- window[1]*nrow(DICResult) + x = nrow(DICResult) + ylim = c(min(DICResult[startV:endV,])*0.99, max(DICResult[startV:endV,])*1.01) + } else { + if(is.na(window[2])) endV <- length(DICResult) + else endV <- window[2]*length(DICResult) + startV <- window[1]*length(DICResult) + x = length(DICResult) + ylim = c(min(DICResult[startV:endV])*0.99, max(DICResult[startV:endV])*1.01) + } + graphicParameters$y = DICResult + graphicParameters$x = 1:x + graphicParameters$main = "DIC" + graphicParameters$xlim = c(startV, endV) + graphicParameters$ylim = ylim + if(is.null(graphicParameters$xaxt)) graphicParameters$xaxt = "n" + do.call(matplot, graphicParameters) + if(graphicParameters$xaxt == "n" ){ + axis(1, at = seq(startV, by = 100, to = endV), labels = seq(startV, by = 100, to = endV)*internal) + graphicParameters$xaxt <- NULL + } + } + + + # plot WAIC + if(calcWAIC){ + if(is.matrix(WAICResult)){ + # col <- 1:ncol(DICResult) + if(is.na(window[2])) endV <- nrow(WAICResult) + else endV <- window[2]*nrow(WAICResult) + startV <- window[1]*nrow(WAICResult) + x = nrow(WAICResult) + ylim = c(min(WAICResult[startV:endV,])*0.99, max(WAICResult[startV:endV,])*1.01) + } else { + if(is.na(window[2])) endV <- length(WAICResult) + else endV <- window[2]*length(WAICResult) + startV <- window[1]*length(WAICResult) + x = length(WAICResult) + ylim = c(min(WAICResult[startV:endV])*0.99, max(WAICResult[startV:endV])*1.01) + } + graphicParameters$y = WAICResult + graphicParameters$x = 1:x + graphicParameters$main = "WAIC" + graphicParameters$xlim = c(startV, endV) + graphicParameters$ylim = ylim + if(is.null(graphicParameters$xaxt)) graphicParameters$xaxt = "n" + do.call(matplot, graphicParameters) + if(graphicParameters$xaxt == "n" ){ + axis(1, at = seq(startV, by = 10, to = endV), labels = seq(startV, by = 10, to = endV)*10*internal) + graphicParameters$xaxt <- NULL + } + + } + + + if(plotPSRF){ + if(is.na(window[2])) endV <- nrow(PSRF) + else endV <- window[2]*nrow(PSRF) + startV <- window[1]*nrow(PSRF) + graphicParameters$xlim = c(startV, endV) + graphicParameters$x = 1:nrow(PSRF) + # plot mPSRF + if(numPars > 1){ + if(!typeof(seq) == "logical" ) { + + graphicParameters$ylim = c(min(PSRF[startV:endV,ncol(PSRF)])*0.99, max(PSRF[startV:endV,ncol(PSRF)])*1.01) + graphicParameters$y = PSRF[,ncol(PSRF)] + graphicParameters$main = "mPSRF" + do.call(plot, graphicParameters) + } + } + + graphicParameters$ylim = c(min(PSRF[startV:endV,-ncol(PSRF)])*0.99, max(PSRF[startV:endV,-ncol(PSRF)])*1.01) + graphicParameters$y = PSRF[,-ncol(PSRF)] + graphicParameters$main = "PSRF" + + lty = NULL + for(i in 1:numPars)lty <- c(lty, c(1,2)) + graphicParameters$lty <- lty + + col = NULL + for(i in 1:6)col <- c(col, c(i,i)) + graphicParameters$col <- col + + do.call(matplot, graphicParameters) + + } + # plot parameter traces + if(plotTrace){ + # if(is.null(defaultGraphicParameters)) defaultGraphicParameters <- list() + # if(is.na(window[2])) endV <- len + # else endV <- window[2]*len + # defaultGraphicParameters$xlim <- c(len*window[1], endV) + # defaultGraphicParameters$ask = F + # defaultGraphicParameters$auto.layout = F + # defaultGraphicParameters$x = getSample(out, start = start, coda = T, parametersOnly = T,...) + # do.call(coda::cumuplot, defaultGraphicParameters) + + coda::cumuplot(getSample(out, start = start, coda = T, parametersOnly = T, ...), ask = F, auto.layout = F) + } +} + diff --git a/BayesianTools/R/plotMarginals.R b/BayesianTools/R/plotMarginals.R index d58359e..e8f05de 100644 --- a/BayesianTools/R/plotMarginals.R +++ b/BayesianTools/R/plotMarginals.R @@ -1,324 +1,325 @@ -#' @export -marginalPlot <- function(x, ...) UseMethod("marginalPlot") - -#' Plot MCMC marginals -#' @param x bayesianOutput, or matrix or data.frame with samples as rows and parameters as columns -#' @param prior if x is a bayesianOutput, T/F will determines whether the prior is drawn (default = T). If x is matrix or data.frame, a prior can be drawn if a matrix of prior draws with values as rows and parameters as columns can be provided here. -#' @param xrange vector or matrix of plot ranges for the x-axis. If matrix, the rows must be parameters and the columns must be min and max values. -#' @param type character, determes the plot type. Either 'd' for density plot, or 'v' for violin plot -#' @param singlePanel logical, determines whether the parameter should be plotted in a single panel or each in its own panel -#' @param settings optional, list of additional settings for \code{\link{marginalPlotDensity}}, and \code{\link{marginalPlotViolin}}, respectively -#' @param nPriorDraws number of draws from the prior, if x is bayesianOutput -#' @param ... additional arguments passed to \code{\link{getSample}}. If you have a high number of draws from the posterior it is advised to set numSamples (to e.g. 5000) for performance reasons. -#' @example /inst/examples/marginalPlotHelp.R -#' @author Tankred Ott, Florian Hartig -marginalPlot <- function(x, prior = NULL, xrange = NULL, type = 'd', singlePanel = FALSE, settings = NULL, - nPriorDraws = 10000, ...) { - - posteriorMat <- getSample(x, parametersOnly = TRUE, ...) - - # checking for which - args <- list(...) - if("which" %in% names(args)) - which = args$which - else - which = 1:ncol(posteriorMat) - - # check prior - if ('bayesianOutput' %in% class(x)) { - - # default T if NULL and BayesianOutput provide - if (is.null(prior)) prior = TRUE - - if (any(c('data.frame', 'matrix') %in% class(prior))) priorMat = prior - else if (is.logical(prior)){ - if (prior == TRUE) priorMat = getSetup(x)$prior$sampler(nPriorDraws) # draw prior from bayesianSetup - else if (prior == F) priorMat = NULL - } - else stop('wrong argument to prior') - } else { - - # default F - if (is.null(prior)) prior = FALSE - - if (any(c('data.frame', 'matrix') %in% class(prior))) priorMat = prior - else if (is.logical(prior)){ - priorMat = NULL - if (prior == TRUE) message("prior = T will only have an effect if x is of class BayesianOutput") - } - else stop('wrong argument to prior') - } - - if (!is.null(priorMat)) { - priorMat = priorMat[,which,drop=F] - if (ncol(posteriorMat) != ncol(priorMat)) stop("wrong dimensions of prior") - colnames(priorMat) <- colnames(posteriorMat) - } - - nPar <- ncol(posteriorMat) - - # check xrange - if (!is.null(xrange)) { - if (!any(c('numeric', 'matrix') %in% class(xrange))) stop('xrange must be numeric or matrix, or NULL') - if ('numeric' %in% class(xrange)) xrange <- matrix(rep(xrange), nPar, nrow = 2) - else if ('matrix' %in% class(xrange)) { - if (ncol(xrange) != ncol(posteriorMat)) stop('xrange must have as many colums as there are parameterss') - else if (nrow(xrange) != 2) stop('xrange must have two rows (min, max)') - } - } else { - posteriorRanges <- apply(posteriorMat, 2, range) - priorRanges <- if(!is.null(priorMat)) apply(priorMat, 2, range) else NULL - - xrange <- if (is.null(priorRanges)) posteriorRanges else apply(rbind(priorRanges, posteriorRanges), 2, range) - } - - # check type - if (any(c('d', 'dens', 'density') == type)) type <- 'd' - # else if (any(c('h', 'hist', 'histogram') == type)) type <- 'h' - else if (any(c('v', 'violin') == type)) type <- 'v' - # else stop('type must be one of "d", "h", "v"') - else stop('type must be one of "d", "v"') - - # check parameter names - if (is.null(colnames(posteriorMat))) colnames(posteriorMat) <- paste('par', 1:nPar, sep = '') - if (!is.null(priorMat)) colnames(priorMat) <- colnames(posteriorMat) - - # prepare arguments for sub-functions - .args <- c(list(posteriorMat = posteriorMat, priorMat = priorMat, xrange = xrange, singlePanel = singlePanel), - settings) - - if (type == 'd') do.call(marginalPlotDensity, .args) - # else if (type == 'h') do.call(marginalPlotHistogram, .args) - else if (type == 'v') do.call(marginalPlotViolin, .args) -} - - -#' Plot marginals as densities -#' @param posteriorMat matrix with samples as rows and parameters as columns -#' @param priorMat matrix (optional) with samples as rows and parameters as columns -#' @param xrange vector or matrix (optional), determining the plotting range, with parameters as columns and min, max as rows -#' @param col vector of colors for posterior and -#' @param singlePanel logical, determining whether the parameter should be plotted in a single panel or each in its own panel -# #' @param ... further options -#' @author Tankred Ott -#' @keywords internal -# TODO: this could be simplified. It is verbose for now to be able to change stuff easily -marginalPlotDensity <- function(posteriorMat, priorMat = NULL, xrange = NULL, col=c('#FC006299','#00BBAA30'), - singlePanel = TRUE, ...) { - - nPar <- ncol(posteriorMat) - parNames <- colnames(posteriorMat) - - if (is.null(xrange)) { - posteriorRanges <- apply(posteriorMat, 2, range) - priorRanges <- if(!is.null(priorMat)) apply(priorMat, 2, range) else NULL - - xrange <- if (is.null(priorRanges)) posteriorRanges else apply(rbind(priorRanges, posteriorRanges), 2, range) - } - - posteriorDensities <- lapply(1:ncol(posteriorMat), - function(i) density(posteriorMat[,i], from = xrange[1,i], to = xrange[2,i], ...)) - priorDensities <- if (!is.null(priorMat)) lapply(1:ncol(priorMat), - function(i) density(priorMat[,i], from = xrange[1,i], to = xrange[2,i], ...)) - else NULL - - postXY <- lapply(posteriorDensities, function(d) { - xy <- cbind(c(d$x[1], d$x, d$x[length(d$x)]), - c(0, d$y, 0)) - colnames(xy) <- c('x', 'y') - xy - }) - - priorXY <- if (!is.null(priorDensities)) lapply(priorDensities, function(d) { - xy <- cbind(c(d$x[1], d$x, d$x[length(d$x)]), - c(0, d$y, 0)) - colnames(xy) <- c('x', 'y') - xy - }) else NULL - - - if (singlePanel) { - op <- par(mfrow = c(nPar,1), mar = c(2, 5, 2, 2), oma = c(5, 4, 4, 0)) - on.exit(par(op)) - - - for (i in 1:length(posteriorDensities)) { - postX <- postXY[[i]][,1] - postY <- postXY[[i]][,2] - - priorX <- if (!is.null(priorXY[[i]])) priorXY[[i]][,1] else NULL - priorY <- if (!is.null(priorXY[[i]])) priorXY[[i]][,2] else NULL - - yrange <- if (is.null(priorX)) range(postY) else range(c(postY, priorY)) - - plot(NULL, NULL, xlim = xrange[,i], ylim = yrange, main = NA, - xlab = NA, ylab = NA, bty = 'n', yaxt = 'n', xaxt = 'n') - axis(1, at = xrange[,i], labels = NA, lwd.ticks=0) - xticks <- axTicks(1) - xticks <- xticks[xticks >= xrange[1,i] & xticks <= xrange[2,i]] - - axis(1, at = xticks) - - mtext(sprintf('%20s', parNames[i]), 2, las = 1, adj = 1.25) - - - polygon(postX, postY, col = col[1], border = 1) - if (!is.null(priorX)) polygon(priorX, priorY, col = col[2], border = 1) - - } - - mtext('Marginal parameter uncertainty', outer = TRUE, cex = 1.5) - - } else { - mfrow <- if (nPar < 16) getPanels(nPar) else c(4,4) - - op <- par(mfrow = mfrow, mar = c(4.5, 4, 5, 3), oma=c(3, 1.5, 2, 0), xpd=TRUE) - on.exit(par(op)) - - for (i in 1:length(posteriorDensities)) { - postX <- postXY[[i]][,1] - postY <- postXY[[i]][,2] - - priorX <- if (!is.null(priorXY[[i]])) priorXY[[i]][,1] else NULL - priorY <- if (!is.null(priorXY[[i]])) priorXY[[i]][,2] else NULL - - yrange <- if (is.null(priorX)) range(postY) else range(c(postY, priorY)) - - plot(NULL, NULL, xlim = xrange[,i], ylim = yrange, main = parNames[i], - xlab = NA, ylab = 'density') - - polygon(postX, postY, col = col[1], border = 1) - if (!is.null(priorX)) polygon(priorX, priorY, col = col[2], border = 1) - - if (i %% 16 == 1) mtext('Marginal parameter uncertainty', outer = TRUE, cex = 1.5) - } - } - - # overlay plot with empty plot to be able to place the legends freely - par(fig = c(0, 1, 0, 1), oma = c(0, 0, 0, 0), mar = c(0, 0, 0, 0), new = TRUE) - plot(0, 0, type = 'n', bty = 'n', xaxt = 'n', yaxt = 'n') - - legend('bottom', if (!is.null(priorX)) c('posterior', 'prior') else 'posterior', xpd = TRUE, horiz = TRUE, inset = c(0, 0), - bty = 'n', pch = 15, col = col, cex = 1.5) -} - - -#' Plot marginals as violin plot -#' @param posteriorMat matrix with samples as rows and parameters as columns -#' @param priorMat matrix (optional) with samples as rows and parameters as columns -#' @param xrange vector or matrix (optional), determining the plotting range, with parameters as columns and min, max as rows -#' @param col vector of colors for posterior and -#' @param singlePanel logical, determining whether the parameter should be plotted in a single panel or each in its own panel -# #' @param ... further options -#' @author Tankred Ott -#' @keywords internal -# TODO: this could be simplified. It is verbose for now to be able to change stuff easily -marginalPlotViolin <- function(posteriorMat, priorMat = NULL, xrange = NULL, col=c('#FC006299','#00BBAA88'), - singlePanel = TRUE, ...) { - - nPar <- ncol(posteriorMat) - parNames <- colnames(posteriorMat) - - if (is.null(xrange)) { - posteriorRanges <- apply(posteriorMat, 2, range) - priorRanges <- if(!is.null(priorMat)) apply(priorMat, 2, range) else NULL - - xrange <- if (is.null(priorRanges)) posteriorRanges else apply(rbind(priorRanges, posteriorRanges), 2, range) - } - - posteriorDensities <- lapply(1:ncol(posteriorMat), - function(i) density(posteriorMat[,i], from = xrange[1,i], to = xrange[2,i], ...)) - priorDensities <- if (!is.null(priorMat)) lapply(1:ncol(priorMat), - function(i) density(priorMat[,i], from = xrange[1,i], to = xrange[2,i], ...)) - else NULL - - - postXY <- lapply(posteriorDensities, function(d) { - xy <- cbind(c(d$x[1], d$x, d$x[length(d$x)]), - c(0, d$y, 0)) - colnames(xy) <- c('x', 'y') - if (is.null(priorDensities)) xy <- rbind(xy, - cbind(rev(xy[,1]), rev(-xy[,2]))) - xy - }) - - priorXY <- if (!is.null(priorDensities)) lapply(priorDensities, function(d) { - xy <- cbind(c(d$x[1], d$x, d$x[length(d$x)]), - -c(0, d$y, 0)) - colnames(xy) <- c('x', 'y') - xy - }) else NULL - - - if (singlePanel) { - nChar <- max(nchar(parNames)) - op <- par(mfrow = c(nPar,1), mar = c(2, min(nChar, 20), 2, 2), oma = c(5, 0, 4, 0)) - on.exit(par(op)) - - for (i in 1:length(posteriorDensities)) { - postX <- postXY[[i]][,1] - postY <- postXY[[i]][,2] - - priorX <- if (!is.null(priorXY[[i]])) priorXY[[i]][,1] else NULL - priorY <- if (!is.null(priorXY[[i]])) priorXY[[i]][,2] else NULL - - yrange <- if (is.null(priorX)) range(postY) else range(c(postY, priorY)) - - plot(NULL, NULL, xlim = xrange[,i], ylim = yrange, main = NA, - xlab = NA, ylab = NA, bty = 'n', yaxt = 'n', xaxt = 'n') - - axis(1, at = xrange[,i], labels = NA, lwd.ticks=0) - xticks <- axTicks(1) - xticks <- xticks[xticks >= xrange[1,i] & xticks <= xrange[2,i]] - - axis(1, at = xticks) - mtext(sprintf('%20s', parNames[i]), 2, las = 1, adj = 1) - - polygon(postX, postY, col = col[1], border = 1) - if (!is.null(priorX)) polygon(priorX, priorY, col = col[2], border = 1) - - } - - mtext('Marginal parameter uncertainty', outer = TRUE, cex = 1.5) - - } else { - mfrow <- if (nPar < 16) getPanels(nPar) else c(4,4) - - op <- par(mfrow = mfrow, mar = c(4.5, 4.5, 5, 3), oma=c(3, 0, 2, 0), xpd=TRUE) - - on.exit(par(op)) - for (i in 1:length(posteriorDensities)) { - postX <- postXY[[i]][,1] - postY <- postXY[[i]][,2] - - priorX <- if (!is.null(priorXY[[i]])) priorXY[[i]][,1] else NULL - priorY <- if (!is.null(priorXY[[i]])) priorXY[[i]][,2] else NULL - - yrange <- if (is.null(priorX)) range(postY) else range(c(postY, priorY)) - - plot(NULL, NULL, xlim = xrange[,i], ylim = yrange, main = parNames[i], - xlab = NA, ylab = 'density', yaxt = 'n') - yticks <- sort(c(0, axTicks(2))) - axis(2, at = yticks, labels = abs(yticks)) - - - polygon(postX, postY, col = col[1], border = 1) - if (!is.null(priorX)) polygon(priorX, priorY, col = col[2], border = 1) - - if (i %% 16 == 1) mtext('Marginal parameter uncertainty', outer = TRUE, cex = 1.5) - } - } - - # overlay plot with empty plot to be able to place the legends freely - par(fig = c(0, 1, 0, 1), oma = c(0, 0, 0, 0), mar = c(0, 0, 0, 0), new = TRUE) - plot(0, 0, type = 'n', bty = 'n', xaxt = 'n', yaxt = 'n') - - legend('bottom', if (!is.null(priorX)) c('posterior', 'prior') else 'posterior', xpd = TRUE, horiz = TRUE, - inset = c(0, 0), bty = 'n', pch = 15, col = col, cex = 1.5) -} - -#' #' @keywords internal -#' marginalPlotHistogram <- function(posteriorMat, priorMat = NULL, xrange = NULL, col=c('#FF5000A0','#4682B4A0'), -#' singlePanel = TRUE, breaks = NULL, ...) { -#' -#' } +#' @export +marginalPlot <- function(x, ...) UseMethod("marginalPlot") + + +#' Plot MCMC marginals +#' @param x bayesianOutput, or matrix or data.frame with samples as rows and parameters as columns +#' @param prior if x is a bayesianOutput, T/F will determines whether the prior is drawn (default = T). If x is matrix or data.frame, a prior can be drawn if a matrix of prior draws with values as rows and parameters as columns can be provided here. +#' @param xrange vector or matrix of plot ranges for the x-axis. If matrix, the rows must be parameters and the columns must be min and max values. +#' @param type character, determes the plot type. Either 'd' for density plot, or 'v' for violin plot +#' @param singlePanel logical, determines whether the parameter should be plotted in a single panel or each in its own panel +#' @param settings optional, list of additional settings for \code{\link{marginalPlotDensity}}, and \code{\link{marginalPlotViolin}}, respectively +#' @param nPriorDraws number of draws from the prior, if x is bayesianOutput +#' @param ... additional arguments passed to \code{\link{getSample}}. If you have a high number of draws from the posterior it is advised to set numSamples (to e.g. 5000) for performance reasons. +#' @example /inst/examples/marginalPlotHelp.R +#' @author Tankred Ott, Florian Hartig +marginalPlot <- function(x, prior = NULL, xrange = NULL, type = 'd', singlePanel = FALSE, settings = NULL, + nPriorDraws = 10000, ...) { + + posteriorMat <- getSample(x, parametersOnly = TRUE, ...) + + # checking for which + args <- list(...) + if("which" %in% names(args)) + which = args$which + else + which = 1:ncol(posteriorMat) + + # check prior + if ('bayesianOutput' %in% class(x)) { + + # default T if NULL and BayesianOutput provide + if (is.null(prior)) prior = TRUE + + if (any(c('data.frame', 'matrix') %in% class(prior))) priorMat = prior + else if (is.logical(prior)){ + if (prior == TRUE) priorMat = getSetup(x)$prior$sampler(nPriorDraws) # draw prior from bayesianSetup + else if (prior == F) priorMat = NULL + } + else stop('wrong argument to prior') + } else { + + # default F + if (is.null(prior)) prior = FALSE + + if (any(c('data.frame', 'matrix') %in% class(prior))) priorMat = prior + else if (is.logical(prior)){ + priorMat = NULL + if (prior == TRUE) message("prior = T will only have an effect if x is of class BayesianOutput") + } + else stop('wrong argument to prior') + } + + if (!is.null(priorMat)) { + priorMat = priorMat[,which,drop=F] + if (ncol(posteriorMat) != ncol(priorMat)) stop("wrong dimensions of prior") + colnames(priorMat) <- colnames(posteriorMat) + } + + nPar <- ncol(posteriorMat) + + # check xrange + if (!is.null(xrange)) { + if (!any(c('numeric', 'matrix') %in% class(xrange))) stop('xrange must be numeric or matrix, or NULL') + if ('numeric' %in% class(xrange)) xrange <- matrix(rep(xrange), nPar, nrow = 2) + else if ('matrix' %in% class(xrange)) { + if (ncol(xrange) != ncol(posteriorMat)) stop('xrange must have as many colums as there are parameterss') + else if (nrow(xrange) != 2) stop('xrange must have two rows (min, max)') + } + } else { + posteriorRanges <- apply(posteriorMat, 2, range) + priorRanges <- if(!is.null(priorMat)) apply(priorMat, 2, range) else NULL + + xrange <- if (is.null(priorRanges)) posteriorRanges else apply(rbind(priorRanges, posteriorRanges), 2, range) + } + + # check type + if (any(c('d', 'dens', 'density') == type)) type <- 'd' + # else if (any(c('h', 'hist', 'histogram') == type)) type <- 'h' + else if (any(c('v', 'violin') == type)) type <- 'v' + # else stop('type must be one of "d", "h", "v"') + else stop('type must be one of "d", "v"') + + # check parameter names + if (is.null(colnames(posteriorMat))) colnames(posteriorMat) <- paste('par', 1:nPar, sep = '') + if (!is.null(priorMat)) colnames(priorMat) <- colnames(posteriorMat) + + # prepare arguments for sub-functions + .args <- c(list(posteriorMat = posteriorMat, priorMat = priorMat, xrange = xrange, singlePanel = singlePanel), + settings) + + if (type == 'd') do.call(marginalPlotDensity, .args) + # else if (type == 'h') do.call(marginalPlotHistogram, .args) + else if (type == 'v') do.call(marginalPlotViolin, .args) +} + + +#' Plot marginals as densities +#' @param posteriorMat matrix with samples as rows and parameters as columns +#' @param priorMat matrix (optional) with samples as rows and parameters as columns +#' @param xrange vector or matrix (optional), determining the plotting range, with parameters as columns and min, max as rows +#' @param col vector of colors for posterior and +#' @param singlePanel logical, determining whether the parameter should be plotted in a single panel or each in its own panel +# #' @param ... further options +#' @author Tankred Ott +#' @keywords internal +# TODO: this could be simplified. It is verbose for now to be able to change stuff easily +marginalPlotDensity <- function(posteriorMat, priorMat = NULL, xrange = NULL, col=c('#FC006299','#00BBAA30'), + singlePanel = TRUE, ...) { + + nPar <- ncol(posteriorMat) + parNames <- colnames(posteriorMat) + + if (is.null(xrange)) { + posteriorRanges <- apply(posteriorMat, 2, range) + priorRanges <- if(!is.null(priorMat)) apply(priorMat, 2, range) else NULL + + xrange <- if (is.null(priorRanges)) posteriorRanges else apply(rbind(priorRanges, posteriorRanges), 2, range) + } + + posteriorDensities <- lapply(1:ncol(posteriorMat), + function(i) density(posteriorMat[,i], from = xrange[1,i], to = xrange[2,i], ...)) + priorDensities <- if (!is.null(priorMat)) lapply(1:ncol(priorMat), + function(i) density(priorMat[,i], from = xrange[1,i], to = xrange[2,i], ...)) + else NULL + + postXY <- lapply(posteriorDensities, function(d) { + xy <- cbind(c(d$x[1], d$x, d$x[length(d$x)]), + c(0, d$y, 0)) + colnames(xy) <- c('x', 'y') + xy + }) + + priorXY <- if (!is.null(priorDensities)) lapply(priorDensities, function(d) { + xy <- cbind(c(d$x[1], d$x, d$x[length(d$x)]), + c(0, d$y, 0)) + colnames(xy) <- c('x', 'y') + xy + }) else NULL + + + if (singlePanel) { + op <- par(mfrow = c(nPar,1), mar = c(2, 5, 2, 2), oma = c(5, 4, 4, 0)) + on.exit(par(op)) + + + for (i in 1:length(posteriorDensities)) { + postX <- postXY[[i]][,1] + postY <- postXY[[i]][,2] + + priorX <- if (!is.null(priorXY[[i]])) priorXY[[i]][,1] else NULL + priorY <- if (!is.null(priorXY[[i]])) priorXY[[i]][,2] else NULL + + yrange <- if (is.null(priorX)) range(postY) else range(c(postY, priorY)) + + plot(NULL, NULL, xlim = xrange[,i], ylim = yrange, main = NA, + xlab = NA, ylab = NA, bty = 'n', yaxt = 'n', xaxt = 'n') + axis(1, at = xrange[,i], labels = NA, lwd.ticks=0) + xticks <- axTicks(1) + xticks <- xticks[xticks >= xrange[1,i] & xticks <= xrange[2,i]] + + axis(1, at = xticks) + + mtext(sprintf('%20s', parNames[i]), 2, las = 1, adj = 1.25) + + + polygon(postX, postY, col = col[1], border = 1) + if (!is.null(priorX)) polygon(priorX, priorY, col = col[2], border = 1) + + } + + mtext('Marginal parameter uncertainty', outer = TRUE, cex = 1.5) + + } else { + mfrow <- if (nPar < 16) getPanels(nPar) else c(4,4) + + op <- par(mfrow = mfrow, mar = c(4.5, 4, 5, 3), oma=c(3, 1.5, 2, 0), xpd=TRUE) + on.exit(par(op)) + + for (i in 1:length(posteriorDensities)) { + postX <- postXY[[i]][,1] + postY <- postXY[[i]][,2] + + priorX <- if (!is.null(priorXY[[i]])) priorXY[[i]][,1] else NULL + priorY <- if (!is.null(priorXY[[i]])) priorXY[[i]][,2] else NULL + + yrange <- if (is.null(priorX)) range(postY) else range(c(postY, priorY)) + + plot(NULL, NULL, xlim = xrange[,i], ylim = yrange, main = parNames[i], + xlab = NA, ylab = 'density') + + polygon(postX, postY, col = col[1], border = 1) + if (!is.null(priorX)) polygon(priorX, priorY, col = col[2], border = 1) + + if (i %% 16 == 1) mtext('Marginal parameter uncertainty', outer = TRUE, cex = 1.5) + } + } + + # overlay plot with empty plot to be able to place the legends freely + par(fig = c(0, 1, 0, 1), oma = c(0, 0, 0, 0), mar = c(0, 0, 0, 0), new = TRUE) + plot(0, 0, type = 'n', bty = 'n', xaxt = 'n', yaxt = 'n') + + legend('bottom', if (!is.null(priorX)) c('posterior', 'prior') else 'posterior', xpd = TRUE, horiz = TRUE, inset = c(0, 0), + bty = 'n', pch = 15, col = col, cex = 1.5) +} + + +#' Plot marginals as violin plot +#' @param posteriorMat matrix with samples as rows and parameters as columns +#' @param priorMat matrix (optional) with samples as rows and parameters as columns +#' @param xrange vector or matrix (optional), determining the plotting range, with parameters as columns and min, max as rows +#' @param col vector of colors for posterior and +#' @param singlePanel logical, determining whether the parameter should be plotted in a single panel or each in its own panel +# #' @param ... further options +#' @author Tankred Ott +#' @keywords internal +# TODO: this could be simplified. It is verbose for now to be able to change stuff easily +marginalPlotViolin <- function(posteriorMat, priorMat = NULL, xrange = NULL, col=c('#FC006299','#00BBAA88'), + singlePanel = TRUE, ...) { + + nPar <- ncol(posteriorMat) + parNames <- colnames(posteriorMat) + + if (is.null(xrange)) { + posteriorRanges <- apply(posteriorMat, 2, range) + priorRanges <- if(!is.null(priorMat)) apply(priorMat, 2, range) else NULL + + xrange <- if (is.null(priorRanges)) posteriorRanges else apply(rbind(priorRanges, posteriorRanges), 2, range) + } + + posteriorDensities <- lapply(1:ncol(posteriorMat), + function(i) density(posteriorMat[,i], from = xrange[1,i], to = xrange[2,i], ...)) + priorDensities <- if (!is.null(priorMat)) lapply(1:ncol(priorMat), + function(i) density(priorMat[,i], from = xrange[1,i], to = xrange[2,i], ...)) + else NULL + + + postXY <- lapply(posteriorDensities, function(d) { + xy <- cbind(c(d$x[1], d$x, d$x[length(d$x)]), + c(0, d$y, 0)) + colnames(xy) <- c('x', 'y') + if (is.null(priorDensities)) xy <- rbind(xy, + cbind(rev(xy[,1]), rev(-xy[,2]))) + xy + }) + + priorXY <- if (!is.null(priorDensities)) lapply(priorDensities, function(d) { + xy <- cbind(c(d$x[1], d$x, d$x[length(d$x)]), + -c(0, d$y, 0)) + colnames(xy) <- c('x', 'y') + xy + }) else NULL + + + if (singlePanel) { + nChar <- max(nchar(parNames)) + op <- par(mfrow = c(nPar,1), mar = c(2, min(nChar, 20), 2, 2), oma = c(5, 0, 4, 0)) + on.exit(par(op)) + + for (i in 1:length(posteriorDensities)) { + postX <- postXY[[i]][,1] + postY <- postXY[[i]][,2] + + priorX <- if (!is.null(priorXY[[i]])) priorXY[[i]][,1] else NULL + priorY <- if (!is.null(priorXY[[i]])) priorXY[[i]][,2] else NULL + + yrange <- if (is.null(priorX)) range(postY) else range(c(postY, priorY)) + + plot(NULL, NULL, xlim = xrange[,i], ylim = yrange, main = NA, + xlab = NA, ylab = NA, bty = 'n', yaxt = 'n', xaxt = 'n') + + axis(1, at = xrange[,i], labels = NA, lwd.ticks=0) + xticks <- axTicks(1) + xticks <- xticks[xticks >= xrange[1,i] & xticks <= xrange[2,i]] + + axis(1, at = xticks) + mtext(sprintf('%20s', parNames[i]), 2, las = 1, adj = 1) + + polygon(postX, postY, col = col[1], border = 1) + if (!is.null(priorX)) polygon(priorX, priorY, col = col[2], border = 1) + + } + + mtext('Marginal parameter uncertainty', outer = TRUE, cex = 1.5) + + } else { + mfrow <- if (nPar < 16) getPanels(nPar) else c(4,4) + + op <- par(mfrow = mfrow, mar = c(4.5, 4.5, 5, 3), oma=c(3, 0, 2, 0), xpd=TRUE) + + on.exit(par(op)) + for (i in 1:length(posteriorDensities)) { + postX <- postXY[[i]][,1] + postY <- postXY[[i]][,2] + + priorX <- if (!is.null(priorXY[[i]])) priorXY[[i]][,1] else NULL + priorY <- if (!is.null(priorXY[[i]])) priorXY[[i]][,2] else NULL + + yrange <- if (is.null(priorX)) range(postY) else range(c(postY, priorY)) + + plot(NULL, NULL, xlim = xrange[,i], ylim = yrange, main = parNames[i], + xlab = NA, ylab = 'density', yaxt = 'n') + yticks <- sort(c(0, axTicks(2))) + axis(2, at = yticks, labels = abs(yticks)) + + + polygon(postX, postY, col = col[1], border = 1) + if (!is.null(priorX)) polygon(priorX, priorY, col = col[2], border = 1) + + if (i %% 16 == 1) mtext('Marginal parameter uncertainty', outer = TRUE, cex = 1.5) + } + } + + # overlay plot with empty plot to be able to place the legends freely + par(fig = c(0, 1, 0, 1), oma = c(0, 0, 0, 0), mar = c(0, 0, 0, 0), new = TRUE) + plot(0, 0, type = 'n', bty = 'n', xaxt = 'n', yaxt = 'n') + + legend('bottom', if (!is.null(priorX)) c('posterior', 'prior') else 'posterior', xpd = TRUE, horiz = TRUE, + inset = c(0, 0), bty = 'n', pch = 15, col = col, cex = 1.5) +} + +#' #' @keywords internal +#' marginalPlotHistogram <- function(posteriorMat, priorMat = NULL, xrange = NULL, col=c('#FF5000A0','#4682B4A0'), +#' singlePanel = TRUE, breaks = NULL, ...) { +#' +#' } diff --git a/BayesianTools/R/plotSensitivityOAT.R b/BayesianTools/R/plotSensitivityOAT.R index fa723e5..66a3c4a 100644 --- a/BayesianTools/R/plotSensitivityOAT.R +++ b/BayesianTools/R/plotSensitivityOAT.R @@ -1,57 +1,58 @@ -#' Performs a one-factor-at-a-time sensitivity analysis for the posterior of a given bayesianSetup within the prior range. -#' @author Florian Hartig -#' @param bayesianSetup an object of class BayesianSetup -#' @param selection indices of selected parameters -#' @param equalScale if T, y-axis of all plots will have the same scale -#' @note This function can also be used for sensitivity analysis of an arbitrary output - just create a BayesianSetup with this output. -#' @example /inst/examples/plotSensitivityHelp.R -#' @export -plotSensitivity <- function(bayesianSetup, selection = NULL, equalScale = T){ - - if (is.null(selection)) selection = 1:bayesianSetup$numPars - n = length(selection) - - post = list() - lowS = bayesianSetup$prior$lower[selection] - upS = bayesianSetup$prior$upper[selection] - refPar = bayesianSetup$prior$best[selection] - names = bayesianSetup$names[selection] - fullRefPar <- bayesianSetup$prior$best - - minR = Inf - maxR = -Inf - - for (j in 1:n){ - post[[j]] <- data.frame(par = seq(lowS[j], upS[j], len = 20), resp = rep(NA, 20)) - - for (i in 1:20){ - parS <- refPar - parS[j] = post[[j]]$par[i] - parS2 = fullRefPar - parS2[selection] = parS - post[[j]]$resp[i] = bayesianSetup$posterior$density(parS2) - } - minR = min(minR, post[[j]]$resp) - maxR = max(maxR, post[[j]]$resp) - } - - oldPar = par(mfrow = getPanels(n)) - - - for (i in 1:n){ - if(equalScale == T) plot(resp~par, xlab = names[i], type = "l", col = "red", data = post[[i]], ylim = c(minR, maxR), ylab = "Response") - else plot(resp~par, xlab = names[i], type = "l", col = "red", data = post[[i]], ylab = "Response") - - abline(v = refPar[i]) - } - - names(post) = names - post$reference = refPar - - par(oldPar) - return(post) -} - - - - + +#' Performs a one-factor-at-a-time sensitivity analysis for the posterior of a given bayesianSetup within the prior range. +#' @author Florian Hartig +#' @param bayesianSetup an object of class BayesianSetup +#' @param selection indices of selected parameters +#' @param equalScale if T, y-axis of all plots will have the same scale +#' @note This function can also be used for sensitivity analysis of an arbitrary output - just create a BayesianSetup with this output. +#' @example /inst/examples/plotSensitivityHelp.R +#' @export +plotSensitivity <- function(bayesianSetup, selection = NULL, equalScale = T){ + + if (is.null(selection)) selection = 1:bayesianSetup$numPars + n = length(selection) + + post = list() + lowS = bayesianSetup$prior$lower[selection] + upS = bayesianSetup$prior$upper[selection] + refPar = bayesianSetup$prior$best[selection] + names = bayesianSetup$names[selection] + fullRefPar <- bayesianSetup$prior$best + + minR = Inf + maxR = -Inf + + for (j in 1:n){ + post[[j]] <- data.frame(par = seq(lowS[j], upS[j], len = 20), resp = rep(NA, 20)) + + for (i in 1:20){ + parS <- refPar + parS[j] = post[[j]]$par[i] + parS2 = fullRefPar + parS2[selection] = parS + post[[j]]$resp[i] = bayesianSetup$posterior$density(parS2) + } + minR = min(minR, post[[j]]$resp) + maxR = max(maxR, post[[j]]$resp) + } + + oldPar = par(mfrow = getPanels(n)) + + + for (i in 1:n){ + if(equalScale == T) plot(resp~par, xlab = names[i], type = "l", col = "red", data = post[[i]], ylim = c(minR, maxR), ylab = "Response") + else plot(resp~par, xlab = names[i], type = "l", col = "red", data = post[[i]], ylab = "Response") + + abline(v = refPar[i]) + } + + names(post) = names + post$reference = refPar + + par(oldPar) + return(post) +} + + + + diff --git a/BayesianTools/R/plotTrace.R b/BayesianTools/R/plotTrace.R index 519a439..45f2216 100644 --- a/BayesianTools/R/plotTrace.R +++ b/BayesianTools/R/plotTrace.R @@ -1,13 +1,14 @@ -#' Trace plot for MCMC class -#' @param sampler an object of class MCMC sampler -#' @param thin determines the thinning interval of the chain -#' @param ... additional parameters to pass on to the \code{\link{getSample}}, for example parametersOnly = F, or start = 1000 -#' @export -#' @seealso \code{\link{marginalPlot}} \cr -#' \code{\link{plotTimeSeries}} \cr -#' \code{\link{correlationPlot}} -#' @example /inst/examples/tracePlotHelp.R -tracePlot <- function(sampler, thin = "auto", ...){ - codaChain = getSample(sampler, coda = T, thin = thin, ...) - plot(codaChain) -} + +#' Trace plot for MCMC class +#' @param sampler an object of class MCMC sampler +#' @param thin determines the thinning interval of the chain +#' @param ... additional parameters to pass on to the \code{\link{getSample}}, for example parametersOnly = F, or start = 1000 +#' @export +#' @seealso \code{\link{marginalPlot}} \cr +#' \code{\link{plotTimeSeries}} \cr +#' \code{\link{correlationPlot}} +#' @example /inst/examples/tracePlotHelp.R +tracePlot <- function(sampler, thin = "auto", ...){ + codaChain = getSample(sampler, coda = T, thin = thin, ...) + plot(codaChain) +} diff --git a/BayesianTools/man/updateGroups.Rd b/BayesianTools/man/updateGroups.Rd index b41d85c..188180a 100644 --- a/BayesianTools/man/updateGroups.Rd +++ b/BayesianTools/man/updateGroups.Rd @@ -7,7 +7,7 @@ updateGroups(chain, blockSettings) } \arguments{ -\item{chain}{MCMC chain including only the parameters (not logP,ll, logP)} +\item{chain}{MCMC chain including only the parameters (not logP, ll, logP)} \item{blockSettings}{a list with settings} } From 3ee1d8ec7a4262b7ba0cdb763abc66b6b8a37a1d Mon Sep 17 00:00:00 2001 From: TahminaMojumder Date: Fri, 27 Oct 2023 12:36:17 +0200 Subject: [PATCH 11/13] update --- BayesianTools/R/classSmcSampler.R | 1 + BayesianTools/R/convertCoda.R | 1 + 2 files changed, 2 insertions(+) diff --git a/BayesianTools/R/classSmcSampler.R b/BayesianTools/R/classSmcSampler.R index 2eb931a..ab47c45 100644 --- a/BayesianTools/R/classSmcSampler.R +++ b/BayesianTools/R/classSmcSampler.R @@ -1,3 +1,4 @@ + #' @author Florian Hartig #' @export getSample.smcSampler <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = 1, numSamples = NULL, whichParameters = NULL, reportDiagnostics = FALSE, ...){ diff --git a/BayesianTools/R/convertCoda.R b/BayesianTools/R/convertCoda.R index c269ac0..2805073 100644 --- a/BayesianTools/R/convertCoda.R +++ b/BayesianTools/R/convertCoda.R @@ -1,3 +1,4 @@ + #' Convert coda::mcmc objects to BayesianTools::mcmcSampler #' @description Function to support plotting and diagnostic functions for coda::mcmc objects. #' @param sampler an object of class mcmc or mcmc.list From 0f6ef730f0028cd9dbea85da5a7e99b30a886e63 Mon Sep 17 00:00:00 2001 From: TahminaMojumder Date: Fri, 27 Oct 2023 14:57:30 +0200 Subject: [PATCH 12/13] update --- BayesianTools/R/classMcmcSamplerList.R | 303 +++++++++++++------------ BayesianTools/R/classSMCSamplerList.R | 117 +++++----- 2 files changed, 211 insertions(+), 209 deletions(-) diff --git a/BayesianTools/R/classMcmcSamplerList.R b/BayesianTools/R/classMcmcSamplerList.R index ec69547..cadba14 100644 --- a/BayesianTools/R/classMcmcSamplerList.R +++ b/BayesianTools/R/classMcmcSamplerList.R @@ -1,151 +1,152 @@ -#' Convenience function to create an object of class mcmcSamplerList from a list of mcmc samplers -#' @author Florian Hartig -#' @param mcmcList list of objects, each of which is an mcmcSampler -#' @return object of class "mcmcSamplerList" -#' @export -createMcmcSamplerList <- function(mcmcList){ - # mcmcList <- list(mcmcList) -> This line didn't make any sense at all. Better would be to allow the user to simply provide several inputs without a list, but I guess the list option should be maintained, as this is convenient when scripting. - for (i in 1:length(mcmcList)){ - if (! ("mcmcSampler" %in% class(mcmcList[[i]])) ) stop("list objects are not of class mcmcSampler") - } - class(mcmcList) = c("mcmcSamplerList", "bayesianOutput") - return(mcmcList) -} - -#' @author Stefan Paul -#' @method summary mcmcSamplerList -#' @export -summary.mcmcSamplerList <- function(object, ...){ - #codaChain = getSample(sampler, parametersOnly = parametersOnly, coda = T, ...) - #summary(codaChain) - #rejectionRate(sampler$codaChain) - #effectiveSize(sampler$codaChain) - #DIC(sampler) - #max() - - sampler <- object - - DInf <- DIC(sampler) - MAPvals <- round(MAP(sampler)$parametersMAP,3) - - gelDiag <- gelmanDiagnostics(sampler) - psf <- round(gelDiag$psrf[,1], 3) - - mcmcsampler <- sampler[[1]]$settings$sampler - - runtime <- 0 - for(i in 1:length(sampler)) runtime <- runtime+sampler[[i]]$settings$runtime[3] - - correlations <- round(cor(getSample(sampler)),3) - - - sampler <- getSample(sampler, parametersOnly = T, coda = T, ...) - if("mcmc.list" %in% class(sampler)){ - nrChain <- length(sampler) - nrIter <- nrow(sampler[[1]]) - conv <- round(gelDiag$mpsrf,3) - npar <- ncol(sampler[[1]]) - lowerq <- upperq <- numeric(npar) - medi <- numeric(npar) - parnames <- colnames(sampler[[1]]) - for(i in 1:npar){ - tmp <- unlist(sampler[,i]) - tmp <- quantile(tmp, probs = c(0.025, 0.5, 0.975)) - lowerq[i] <- round(tmp[1],3) - medi[i] <- round(tmp[2],3) - upperq[i] <- round(tmp[3],3) - } - - }else{ - nrChain <- 1 - nrIter <- nrow(sampler) - npar <- ncol(sampler) - conv <- "Only one chain; convergence cannot be determined!" - medi <- numeric(npar) - lowerq <- upperq <- numeric(npar) - parnames <- colnames(sampler) - for(i in 1:npar){ - tmp <- quantile(sampler[,i], probs = c(0.025, 0.5, 0.975)) - lowerq[i] <- round(tmp[1],3) - medi[i] <- round(tmp[2],3) - upperq[i] <- round(tmp[3],3) - } - - } - - # output for parameter metrics - parOutDF <- cbind(psf, MAPvals, lowerq, medi, upperq) - colnames(parOutDF) <- c("psf", "MAP", "2.5%", "median", "97.5%") - row.names(parOutDF) <- parnames - - - cat(rep("#", 25), "\n") - cat("## MCMC chain summary ##","\n") - cat(rep("#", 25), "\n", "\n") - cat("# MCMC sampler: ",mcmcsampler, "\n") - cat("# Nr. Chains: ", nrChain, "\n") - cat("# Iterations per chain: ", nrIter, "\n") - cat("# Rejection rate: ", ifelse(object[[1]]$setup$numPars == 1, # this is a hack because coda::rejectionRate does not work for 1-d MCMC lists - round(mean(sapply(sampler, coda::rejectionRate)),3), - round(mean(coda::rejectionRate(sampler)),3) ), "\n") - cat("# Effective sample size: ", round(mean(coda::effectiveSize(sampler)),0), "\n") - cat("# Runtime: ", runtime, " sec.","\n", "\n") - cat("# Parameters\n") - print(parOutDF) - cat("\n") - cat("## DIC: ", round(DInf$DIC,3), "\n") - cat("## Convergence" ,"\n", "Gelman Rubin multivariate psrf: ", conv, "\n","\n") - cat("## Correlations", "\n") - print(correlations) - -} - -#' @author Florian Hartig -#' @method print mcmcSamplerList -#' @export -print.mcmcSamplerList <- function(x, ...){ - print("mcmcSamplerList - you can use the following methods to summarize, plot or reduce this class:") - print(methods(class ="mcmcSamplerList")) - #codaChain = getSample(sampler, coda = T, ...) - #rejectionRate(sampler$codaChain) - #effectiveSize(sampler$codaChain) -} - -#' @method plot mcmcSamplerList -#' @export -plot.mcmcSamplerList <- function(x, ...){ - tracePlot(x, ...) -} - -#' @author Florian Hartig -#' @export -getSample.mcmcSamplerList <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = 1, numSamples = NULL, whichParameters = NULL, reportDiagnostics, ...){ - - if(!is.null(numSamples)) numSamples = ceiling(numSamples/length(sampler)) - - if(coda == F){ - # out = NULL - out <- rep(list(NA), length(sampler)) - for (i in 1:length(sampler)){ - # out = rbind(out, getSample(sampler[[i]], parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics= F)) - out[[i]] <- getSample(sampler[[i]], parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics= F) - } - out <- combineChains(out) - } - - if(coda == T){ - - out = list() - - for (i in 1:length(sampler)){ - - out[[i]] = getSample(sampler[[i]], parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics= F) - } - - if(inherits(out[[1]], "mcmc.list")) out = unlist(out, recursive = F) - class(out) = "mcmc.list" - out = out - } - - return(out) -} + +#' Convenience function to create an object of class mcmcSamplerList from a list of mcmc samplers +#' @author Florian Hartig +#' @param mcmcList list of objects, each of which is an mcmcSampler +#' @return object of class "mcmcSamplerList" +#' @export +createMcmcSamplerList <- function(mcmcList){ + # mcmcList <- list(mcmcList) -> This line didn't make any sense at all. Better would be to allow the user to simply provide several inputs without a list, but I guess the list option should be maintained, as this is convenient when scripting. + for (i in 1:length(mcmcList)){ + if (! ("mcmcSampler" %in% class(mcmcList[[i]])) ) stop("list objects are not of class mcmcSampler") + } + class(mcmcList) = c("mcmcSamplerList", "bayesianOutput") + return(mcmcList) +} + +#' @author Stefan Paul +#' @method summary mcmcSamplerList +#' @export +summary.mcmcSamplerList <- function(object, ...){ + #codaChain = getSample(sampler, parametersOnly = parametersOnly, coda = T, ...) + #summary(codaChain) + #rejectionRate(sampler$codaChain) + #effectiveSize(sampler$codaChain) + #DIC(sampler) + #max() + + sampler <- object + + DInf <- DIC(sampler) + MAPvals <- round(MAP(sampler)$parametersMAP,3) + + gelDiag <- gelmanDiagnostics(sampler) + psf <- round(gelDiag$psrf[,1], 3) + + mcmcsampler <- sampler[[1]]$settings$sampler + + runtime <- 0 + for(i in 1:length(sampler)) runtime <- runtime+sampler[[i]]$settings$runtime[3] + + correlations <- round(cor(getSample(sampler)),3) + + + sampler <- getSample(sampler, parametersOnly = T, coda = T, ...) + if("mcmc.list" %in% class(sampler)){ + nrChain <- length(sampler) + nrIter <- nrow(sampler[[1]]) + conv <- round(gelDiag$mpsrf,3) + npar <- ncol(sampler[[1]]) + lowerq <- upperq <- numeric(npar) + medi <- numeric(npar) + parnames <- colnames(sampler[[1]]) + for(i in 1:npar){ + tmp <- unlist(sampler[,i]) + tmp <- quantile(tmp, probs = c(0.025, 0.5, 0.975)) + lowerq[i] <- round(tmp[1],3) + medi[i] <- round(tmp[2],3) + upperq[i] <- round(tmp[3],3) + } + + }else{ + nrChain <- 1 + nrIter <- nrow(sampler) + npar <- ncol(sampler) + conv <- "Only one chain; convergence cannot be determined!" + medi <- numeric(npar) + lowerq <- upperq <- numeric(npar) + parnames <- colnames(sampler) + for(i in 1:npar){ + tmp <- quantile(sampler[,i], probs = c(0.025, 0.5, 0.975)) + lowerq[i] <- round(tmp[1],3) + medi[i] <- round(tmp[2],3) + upperq[i] <- round(tmp[3],3) + } + + } + + # output for parameter metrics + parOutDF <- cbind(psf, MAPvals, lowerq, medi, upperq) + colnames(parOutDF) <- c("psf", "MAP", "2.5%", "median", "97.5%") + row.names(parOutDF) <- parnames + + + cat(rep("#", 25), "\n") + cat("## MCMC chain summary ##","\n") + cat(rep("#", 25), "\n", "\n") + cat("# MCMC sampler: ",mcmcsampler, "\n") + cat("# Nr. Chains: ", nrChain, "\n") + cat("# Iterations per chain: ", nrIter, "\n") + cat("# Rejection rate: ", ifelse(object[[1]]$setup$numPars == 1, # this is a hack because coda::rejectionRate does not work for 1-d MCMC lists + round(mean(sapply(sampler, coda::rejectionRate)),3), + round(mean(coda::rejectionRate(sampler)),3) ), "\n") + cat("# Effective sample size: ", round(mean(coda::effectiveSize(sampler)),0), "\n") + cat("# Runtime: ", runtime, " sec.","\n", "\n") + cat("# Parameters\n") + print(parOutDF) + cat("\n") + cat("## DIC: ", round(DInf$DIC,3), "\n") + cat("## Convergence" ,"\n", "Gelman Rubin multivariate psrf: ", conv, "\n","\n") + cat("## Correlations", "\n") + print(correlations) + +} + +#' @author Florian Hartig +#' @method print mcmcSamplerList +#' @export +print.mcmcSamplerList <- function(x, ...){ + print("mcmcSamplerList - you can use the following methods to summarize, plot or reduce this class:") + print(methods(class ="mcmcSamplerList")) + #codaChain = getSample(sampler, coda = T, ...) + #rejectionRate(sampler$codaChain) + #effectiveSize(sampler$codaChain) +} + +#' @method plot mcmcSamplerList +#' @export +plot.mcmcSamplerList <- function(x, ...){ + tracePlot(x, ...) +} + +#' @author Florian Hartig +#' @export +getSample.mcmcSamplerList <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = 1, numSamples = NULL, whichParameters = NULL, reportDiagnostics, ...){ + + if(!is.null(numSamples)) numSamples = ceiling(numSamples/length(sampler)) + + if(coda == F){ + # out = NULL + out <- rep(list(NA), length(sampler)) + for (i in 1:length(sampler)){ + # out = rbind(out, getSample(sampler[[i]], parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics= F)) + out[[i]] <- getSample(sampler[[i]], parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics= F) + } + out <- combineChains(out) + } + + if(coda == T){ + + out = list() + + for (i in 1:length(sampler)){ + + out[[i]] = getSample(sampler[[i]], parametersOnly = parametersOnly, coda = coda, start = start, end = end, thin = thin, numSamples = numSamples, whichParameters = whichParameters, reportDiagnostics= F) + } + + if(inherits(out[[1]], "mcmc.list")) out = unlist(out, recursive = F) + class(out) = "mcmc.list" + out = out + } + + return(out) +} diff --git a/BayesianTools/R/classSMCSamplerList.R b/BayesianTools/R/classSMCSamplerList.R index fa55d09..d693e45 100644 --- a/BayesianTools/R/classSMCSamplerList.R +++ b/BayesianTools/R/classSMCSamplerList.R @@ -1,58 +1,59 @@ -#' Convenience function to create an object of class SMCSamplerList from a list of mcmc samplers -#' @author Florian Hartig -#' @param ... a list of MCMC samplers -#' @return a list of class smcSamplerList with objects of smcSampler -#' @export -createSmcSamplerList <- function(...){ - smcList <- list(...) - for (i in 1:length(smcList)){ - if (! ("mcmcSampler" %in% class(smcList[[i]])) ) stop("list objects are not of class mcmcSampler") - } - class(smcList) = c("smcSamplerList", "bayesianOutput") - return(smcList) -} - - -#' @method summary smcSamplerList -#' @author Florian Hartig -#' @export -summary.smcSamplerList <- function(object, ...){ - sample = getSample(object, parametersOnly = T, ...) - summary(sample) -} - -#' @method print smcSamplerList -#' @author Florian Hartig -#' @export -print.smcSamplerList <- function(x, ...){ - print("smcSamplerList - you can use the following methods to summarize, plot or reduce this class:") - print(methods(class ="smcSamplerList")) -} - -#' @method plot smcSamplerList -#' @export -plot.smcSamplerList <- function(x, ...){ - marginalPlot(x, ...) -} - -#' @export -getSample.smcSamplerList <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = 1, - numSamples = NULL, whichParameters = NULL, reportDiagnostics = FALSE, ...){ - - out = list() - - for (i in 1:length(sampler)){ - - out[[i]] = getSample(sampler[[i]], parametersOnly = parametersOnly, whichParameters = whichParameters, start = start, end = end, thin = thin, - numSamples = numSamples, coda = F, reportDiagnostics = F) - - } - out = combineChains(out, merge =F) - - return(out) -} - - - - - + +#' Convenience function to create an object of class SMCSamplerList from a list of mcmc samplers +#' @author Florian Hartig +#' @param ... a list of MCMC samplers +#' @return a list of class smcSamplerList with objects of smcSampler +#' @export +createSmcSamplerList <- function(...){ + smcList <- list(...) + for (i in 1:length(smcList)){ + if (! ("mcmcSampler" %in% class(smcList[[i]])) ) stop("list objects are not of class mcmcSampler") + } + class(smcList) = c("smcSamplerList", "bayesianOutput") + return(smcList) +} + + +#' @method summary smcSamplerList +#' @author Florian Hartig +#' @export +summary.smcSamplerList <- function(object, ...){ + sample = getSample(object, parametersOnly = T, ...) + summary(sample) +} + +#' @method print smcSamplerList +#' @author Florian Hartig +#' @export +print.smcSamplerList <- function(x, ...){ + print("smcSamplerList - you can use the following methods to summarize, plot or reduce this class:") + print(methods(class ="smcSamplerList")) +} + +#' @method plot smcSamplerList +#' @export +plot.smcSamplerList <- function(x, ...){ + marginalPlot(x, ...) +} + +#' @export +getSample.smcSamplerList <- function(sampler, parametersOnly = T, coda = F, start = 1, end = NULL, thin = 1, + numSamples = NULL, whichParameters = NULL, reportDiagnostics = FALSE, ...){ + + out = list() + + for (i in 1:length(sampler)){ + + out[[i]] = getSample(sampler[[i]], parametersOnly = parametersOnly, whichParameters = whichParameters, start = start, end = end, thin = thin, + numSamples = numSamples, coda = F, reportDiagnostics = F) + + } + out = combineChains(out, merge =F) + + return(out) +} + + + + + From 9fc99dfd67f1035307e4fc31b1f23d296b87ef3e Mon Sep 17 00:00:00 2001 From: TahminaMojumder Date: Fri, 10 Nov 2023 13:55:32 +0100 Subject: [PATCH 13/13] Update MAP.R --- BayesianTools/R/MAP.R | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/BayesianTools/R/MAP.R b/BayesianTools/R/MAP.R index c07efc4..c500161 100644 --- a/BayesianTools/R/MAP.R +++ b/BayesianTools/R/MAP.R @@ -1,20 +1,20 @@ -#' calculates the Maxiumum APosteriori value (MAP) -#' @author Florian Hartig -#' @param bayesianOutput an object of class BayesianOutput (mcmcSampler, smcSampler, or mcmcList) -#' @param ... optional values to be passed on the the getSample function -#' @details Currently, this function simply returns the parameter combination with the highest posterior in the chain. A more refined option would be to take the MCMC sample and do additional calculations, e.g. use an optimizer, a kernel density estimator, or some other tool to search / interpolate around the best value in the chain. -#' @seealso \code{\link{WAIC}}, \code{\link{DIC}}, \code{\link{marginalLikelihood}} -#' @export -MAP <- function(bayesianOutput, ...){ - - samples = getSample(bayesianOutput, parametersOnly = F, ...) - - if("mcmcSamplerList" %in% class(bayesianOutput)) nPars <- bayesianOutput[[1]]$setup$numPars - else nPars = bayesianOutput$setup$numPars - - best = which.max(samples[,nPars + 1]) - - return(list(parametersMAP = samples[best, 1:nPars], valuesMAP = samples[best, (nPars + 1):(nPars + 3)] )) - -} +#' calculates the Maxiumum APosteriori value (MAP) +#' @author Florian Hartig +#' @param bayesianOutput an object of class BayesianOutput (mcmcSampler, smcSampler, or mcmcList) +#' @param ... optional values to be passed on the the getSample function +#' @details Currently, this function simply returns the parameter combination with the highest posterior in the chain. A more refined option would be to take the MCMC sample and do additional calculations, e.g. use an optimizer, a kernel density estimator, or some other tool to search / interpolate around the best value in the chain. +#' @seealso \code{\link{WAIC}}, \code{\link{DIC}}, \code{\link{marginalLikelihood}} +#' @export +MAP <- function(bayesianOutput, ...){ + + samples = getSample(bayesianOutput, parametersOnly = F, ...) + + if("mcmcSamplerList" %in% class(bayesianOutput)) nPars <- bayesianOutput[[1]]$setup$numPars + else nPars = bayesianOutput$setup$numPars + + best = which.max(samples[,nPars + 1]) + + return(list(parametersMAP = samples[best, 1:nPars], valuesMAP = samples[best, (nPars + 1):(nPars + 3)] )) + +} \ No newline at end of file