R/bridge_sampler_tools.R

In bridgesampling: Bridge Sampling for Marginal Likelihoods and Bayes Factors

#--------------------------------------------------------------------------
# functions for Stan support via rstan
#--------------------------------------------------------------------------

# taken from rstan:
.rstan_relist <- function(x, skeleton) {
  lst <- utils::relist(x, skeleton)
  for (i in seq_along(skeleton)) {
    dim(lst[[i]]) <- dim(skeleton[[i]])
  }
  lst
}

# taken from rstan:
.create_skeleton <- function(pars, dims) {
  lst <- lapply(seq_along(pars), function(i) {
    len_dims <- length(dims[[i]])
    if (len_dims < 1) {
      return(0)
    }
    return(array(0, dim = dims[[i]]))
  })
  names(lst) <- pars
  lst
}

.stan_log_posterior <- function(s.row, data) {
  out <- tryCatch(
    rstan::log_prob(object = data$stanfit, upars = s.row),
    error = function(e) -Inf
  )
  if (is.na(out)) {
    out <- -Inf
  }
  return(out)
}

.cmdstan_log_posterior <- function(s.row, data) {
  if ("lp__" %in% names(s.row)) {
    s.row <- s.row[!names(s.row) %in% "lp__"]
  }

  if (!is.numeric(s.row)) {
    s.row <- as.numeric(s.row)
  }
  out <- tryCatch(
    {
      log_prob <- data$log_prob(s.row, jacobian = TRUE)
      log_prob
    },
    error = function(e) {
      print(e)
      -Inf
    }
  )

  if (is.na(out)) {
    out <- -Inf
  }
  result <- data.frame(matrix(s.row, nrow = 1))
  result$log_posterior <- out

  return(out)
}