R/RcppExports.R

In hdtg: Generate Samples from Multivariate Truncated Normal Distributions

# Generated by using Rcpp::compileAttributes() -> do not edit by hand
# Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393

#' Efficient Cholesky decomposition
#' 
#' Compute Cholesky decomposition of a matrix.
#'
#' @param A matrix to decompose
#' @return upper triangular matrix R such that A = U'U.
#' @export
#' @examples
#' # Larger example
#' set.seed(123)
#' B <- matrix(rnorm(16), 4, 4)
#' B <- t(B) %*% B  # Make symmetric positive definite
#' U <- cholesky(B)
#' U
#' # Verify decomposition
#' all.equal(B, t(U) %*% U)
#' @seealso [harmonicHMC()]
cholesky <- function(A) {
    .Call(`_hdtg_cholesky`, A)
}

applyWhitenTransform <- function(constraintDirec, constraintBound, choleskyFactor, unconstrainedMean, precParametrized) {
    .Call(`_hdtg_applyWhitenTransform`, constraintDirec, constraintBound, choleskyFactor, unconstrainedMean, precParametrized)
}

whitenPosition <- function(position, constraintDirec, constraintBound, choleskyFactor, unconstrainedMean, precParametrized) {
    .Call(`_hdtg_whitenPosition`, position, constraintDirec, constraintBound, choleskyFactor, unconstrainedMean, precParametrized)
}

unwhitenPosition <- function(position, choleskyFactor, unconstrainedMean, precParametrized) {
    .Call(`_hdtg_unwhitenPosition`, position, choleskyFactor, unconstrainedMean, precParametrized)
}

simulateWhitenedDynamics <- function(initialPosition, constraintDirec, constraintRowNormSq, constraintBound, integrationTime, diagnosticMode, seed = 0L) {
    .Call(`_hdtg_simulateWhitenedDynamics`, initialPosition, constraintDirec, constraintRowNormSq, constraintBound, integrationTime, diagnosticMode, seed)
}

#' Create a Zigzag-HMC engine object
#' 
#' Create the C++ object to set up SIMD vectorization for speeding up calculations
#' for Zigzag-HMC ("Zigzag-HMC engine"). 
#'
#' @param dimension the dimension of MTN.
#' @param lowerBounds a vector specifying the lower bounds.
#' @param upperBounds a vector specifying the upper bounds.
#' @param seed random seed.
#' @param mean the mean vector.
#' @param precision the precision matrix.
#' @param flags which SIMD instruction set to use. 128 = SSE, 256 = AVX.
#' @return a list whose only element is the Zigzag-HMC engine object.
#' @examples
#' # Create a 2D engine with simple bounds
#' dimension <- 2
#' lowerBounds <- c(-1, -1)
#' upperBounds <- c(1, 1)
#' mean <- c(0, 0)
#' precision <- matrix(c(1, 0.5, 0.5, 1), nrow = 2)
#' engine <- createEngine(dimension, lowerBounds, upperBounds, 
#'                        seed = 123, mean, precision, flags = 128)
#' # Check the engine structure
#' str(engine)
#' @seealso [setMean()], [setPrecision()], [zigzagHMC()], [markovianZigzag()]
#' @export
createEngine <- function(dimension, lowerBounds, upperBounds, seed, mean, precision, flags = 128L) {
    .Call(`_hdtg_createEngine`, dimension, lowerBounds, upperBounds, seed, mean, precision, flags)
}

#' Create a Zigzag-NUTS engine object
#' 
#' Create the C++ object to set up SIMD vectorization for speeding up calculations
#' for Zigzag-NUTS ("Zigzag-NUTS engine"). 
#'
#' @param dimension the dimension of MTN.
#' @param lowerBounds a vector specifying the lower bounds.
#' @param upperBounds a vector specifying the upper bounds.
#' @param seed random seed.
#' @param stepSize the base step size for Zigzag-NUTS.
#' @param mean the mean vector.
#' @param precision the precision matrix.
#' @param flags which SIMD instruction set to use. 128 = SSE, 256 = AVX.
#' @return a list whose only element is the Zigzag-NUTS engine object.
#' @examples
#' # Create a Zigzag-NUTS engine for a 2D problem
#' dimension <- 2
#' lowerBounds <- c(-2, -2)
#' upperBounds <- c(2, 2)
#' stepSize <- 0.1
#' mean <- c(0.5, -0.5)
#' precision <- matrix(c(2, 0.3, 0.3, 2), nrow = 2)
#' nuts_engine <- createNutsEngine(dimension, lowerBounds, upperBounds,
#'                                 seed = 456, stepSize, mean, precision)
#' str(nuts_engine)
#' @seealso [setMean()], [setPrecision()], [zigzagHMC()], [createEngine()]
#' @export
createNutsEngine <- function(dimension, lowerBounds, upperBounds, seed, stepSize, mean, precision, flags = 128L) {
    .Call(`_hdtg_createNutsEngine`, dimension, lowerBounds, upperBounds, seed, stepSize, mean, precision, flags)
}

#' Set the mean for the target MTN
#'
#' Set the mean vector for a given Zigzag-HMC engine object.
#'
#' @param engine A Zigzag-HMC engine container object.
#' @param mean the mean vector.
#' @examples
#' # First create an engine
#' engine <- createEngine(dimension = 2, 
#'                        lowerBounds = c(-1, -1),
#'                        upperBounds = c(1, 1),
#'                        seed = 123,
#'                        mean = c(0, 0),
#'                        precision = diag(2))
#' # Update the mean
#' setMean(engine, mean = c(0.5, 0.5))
#' @seealso [createEngine()], [createNutsEngine()]
#' @export
setMean <- function(engine, mean) {
    invisible(.Call(`_hdtg_setMean`, engine, mean))
}

#' Set the precision matrix for the target MTN
#' 
#' Set the precision matrix for a given Zigzag-HMC engine object.
#'
#' @param engine A Zigzag-HMC engine container object.
#' @param precision the precision matrix.
#' @examples
#' # First create an engine
#' engine <- createEngine(dimension = 2,
#'                        lowerBounds = c(-1, -1),
#'                        upperBounds = c(1, 1),
#'                        seed = 123,
#'                        mean = c(0, 0),
#'                        precision = diag(2))
#' # Update with a correlated precision matrix
#' new_precision <- matrix(c(2, 0.8, 0.8, 2), nrow = 2)
#' setPrecision(engine, precision = new_precision)
#' @seealso [createEngine()], [createNutsEngine()]
#' @export
setPrecision <- function(engine, precision) {
    invisible(.Call(`_hdtg_setPrecision`, engine, precision))
}

getNextEvent <- function(sexp, position, velocity, action, logpdfGradient, momentum) {
    .Call(`_hdtg_getNextEvent`, sexp, position, velocity, action, logpdfGradient, momentum)
}

.oneIteration <- function(sexp, position, momentum, time) {
    .Call(`_hdtg_oneIteration`, sexp, position, momentum, time)
}

.oneIrreversibleIteration <- function(sexp, position, velocity, time) {
    .Call(`_hdtg_oneIrreversibleIteration`, sexp, position, velocity, time)
}

.oneNutsIteration <- function(sexp, position, momentum) {
    .Call(`_hdtg_oneNutsIteration`, sexp, position, momentum)
}