R/RcppExports.R

In regmhmm: 'regmhmm' Fits Hidden Markov Models with Regularization

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

#' @title Fit Hidden Markov Model (HMM)
#'
#' @description
#' Employ this function to fit a Hidden Markov Model (HMM) to the provided data. It iteratively estimates model parameters using the EM algorithm.
#'
#' @param delta a vector of length S specifying the initial probabilities.
#' @param A a matrix of size S x S specifying the transition probabilities.
#' @param B a matrix of size S x (p + 1) specifying the GLM parameters of the emission probabilities.
#' @param Y_mat a matrix of observations of size N x T.
#' @param X_cube a design array of size T x p x N.
#' @param family the family of the response.
#' @param eps convergence tolerance in the EM algorithm for fitting HMM.
#' @param eps_IRLS convergence tolerance in the iteratively reweighted least squares step.
#' @param N_iter the maximal number of the EM algorithm for fitting HMM.
#' @param max_N_IRLS the maximal number of IRLS iterations.
#' @param trace logical indicating if detailed output should be produced during the fitting process.
#'
#' @returns
#' A list object with the following slots:
#'
#' \item{delta_hat}{the estimate of delta.}
#'
#' \item{A_hat}{the estimate of A.}
#'
#' \item{B_hat}{the estimate of B.}
#'
#' \item{log_likelihood}{the log-likelihood of the model.}
#'
#' @examples
#' # Example usage of the function
#' seed_num <- 1
#' p_noise <- 2
#' N <- 100
#' N_persub <- 10
#' parameters_setting <- list(
#'   init_vec = c(0.5, 0.5),
#'   trans_mat = matrix(c(0.7, 0.3, 0.2, 0.8), nrow = 2, byrow = TRUE),
#'   emis_mat = matrix(c(1, 0.5, 0.5, 2), nrow = 2, byrow = TRUE)
#' )
#' simulated_data <- simulate_HMM_data(seed_num, p_noise, N, N_persub, parameters_setting)
#' init_start = c(0.5, 0.5)
#' trans_start = matrix(c(0.5, 0.5, 0.5, 0.5), nrow = 2)
#' emis_start = matrix(rep(1, 8), nrow = 2)
#' HMM_fit_raw <- HMM_C_raw(delta=as.matrix(init_start),
#'                Y_mat=simulated_data$y_mat,
#'                A=trans_start,
#'                B=emis_start,
#'                X_cube=simulated_data$X_array,
#'                family="P",
#'                eps=1e-4,
#'                trace = 0
#' )
#'
#' @export
HMM_C_raw <- function(delta, Y_mat, A, B, X_cube, family, eps = 1e-5, eps_IRLS = 1e-4, N_iter = 1000L, max_N_IRLS = 300L, trace = 0L) {
    .Call(`_regmhmm_HMM_C_raw`, delta, Y_mat, A, B, X_cube, family, eps, eps_IRLS, N_iter, max_N_IRLS, trace)
}

#' @title Single EM Iteration for Fitting Hidden Markov Models (HMM)
#'
#' @description
#' Execute a single iteration of the Expectation-Maximization (EM) algorithm tailored for fitting Hidden Markov Models (HMMs).
#'
#' @param delta a vector of length S specifying the initial probabilities.
#' @param A a matrix of size S x S specifying the transition probabilities.
#' @param B a matrix of size S x (p + 1) specifying the GLM parameters of the emission probabilities.
#' @param Y_mat a matrix of observations of size N x T.
#' @param X_cube a design array of size T x p x N.
#' @param family the family of the response.
#' @param eps_IRLS convergence tolerance in the iteratively reweighted least squares step.
#' @param max_N_IRLS the maximal number of IRLS iterations.
#'
#' @returns
#' A list object with the following slots:
#'
#' \item{delta_hat}{the estimate of delta.}
#'
#' \item{A_hat}{the estimate of A.}
#'
#' \item{B_hat}{the estimate of B.}
#'
#' \item{log_likelihood}{the log-likelihood of the model.}
#'
#' @examples
#' # Example usage of the function
#' seed_num <- 1
#' p_noise <- 2
#' N <- 100
#' N_persub <- 10
#' parameters_setting <- list(
#'   init_vec = c(0.5, 0.5),
#'   trans_mat = matrix(c(0.7, 0.3, 0.2, 0.8), nrow = 2, byrow = TRUE),
#'   emis_mat = matrix(c(1, 0.5, 0.5, 2), nrow = 2, byrow = TRUE)
#' )
#' simulated_data <- simulate_HMM_data(seed_num, p_noise, N, N_persub, parameters_setting)
#' init_start = c(0.5, 0.5)
#' trans_start = matrix(c(0.5, 0.5, 0.5, 0.5), nrow = 2)
#' emis_start = matrix(rep(1, 8), nrow = 2)
#' HMM_fit_raw_one_step <- HMM_one_step(delta=as.matrix(init_start),
#'                Y_mat=simulated_data$y_mat,
#'                A=trans_start,
#'                B=emis_start,
#'                X_cube=simulated_data$X_array,
#'                family="P")
#'
#' @export
HMM_one_step <- function(delta, Y_mat, A, B, X_cube, family, eps_IRLS = 1e-4, max_N_IRLS = 300L) {
    .Call(`_regmhmm_HMM_one_step`, delta, Y_mat, A, B, X_cube, family, eps_IRLS, max_N_IRLS)
}

#' Iterative Reweighted Least Squares algorithm for optimizing the parameters in the M-step of the EM algorithm.
#'
#' @title Iterative Reweighted Least Squares for the EM algorithm
#'
#' @param Y A vector of observations of size n.
#' @param X A design matrix of size n x p.
#' @param gamma A vector of size n specifying the posterior probability of the hidden states.
#' @param beta A vector of size p + 1 specifying the GLM parameters.
#' @param family The family of the response.
#' @param eps_IRLS convergence tolerance in the iteratively reweighted least squares step.
#' @param max_N the maximal number of IRLS iterations.
#'
#' @returns
#' A vector representing the estimates of beta.
#'
#' @examples
#' \dontrun{
#' # Example usage of the function
#' IRLS_EM_one_step <- IRLS_EM_one(X,
#'                                 gamma,
#'                                 Y,
#'                                 beta,
#'                                 family)
#' }
#' @export
IRLS_EM <- function(X, gamma, Y, beta, family, eps_IRLS, max_N) {
    .Call(`_regmhmm_IRLS_EM`, X, gamma, Y, beta, family, eps_IRLS, max_N)
}

#' @title Probability Calculation using the Backward Algorithm for Hidden Markov Models
#'
#' @description
#' Calculate the probability given parameters of a hidden Markov model utilizing the backward algorithm.
#'
#' @param delta a vector of length S specifying the initial probabilities.
#' @param Y a vector of observations of size T.
#' @param X a design matrix of size T x p.
#' @param A a matrix of size S x S specifying the transition probabilities.
#' @param B a matrix of size S x (p + 1) specifying the GLM parameters of the emission probabilities.
#' @param family the family of the response.
#' @returns
#'
#' A matrix of size S x T that is the backward probabilities in log scale.
#'
#' @examples
#' # Example usage of the function
#' parameters_setting <- list()
#' parameters_setting$emis_mat <- matrix(NA, nrow = 2, ncol = 4)
#' parameters_setting$emis_mat[1, 1] <- 0.1
#' parameters_setting$emis_mat[1, 2] <- 0.5
#' parameters_setting$emis_mat[1, 3] <- -0.75
#' parameters_setting$emis_mat[1, 4] <- 0.75
#' parameters_setting$emis_mat[2, 1] <- -0.1
#' parameters_setting$emis_mat[2, 2] <- -0.5
#' parameters_setting$emis_mat[2, 3] <- 0.75
#' parameters_setting$emis_mat[2, 4] <- 1
#' parameters_setting$trans_mat <- matrix(NA, nrow = 2, ncol = 2)
#' parameters_setting$trans_mat[1, 1] <- 0.65
#' parameters_setting$trans_mat[1, 2] <- 0.35
#' parameters_setting$trans_mat[2, 1] <- 0.2
#' parameters_setting$trans_mat[2, 2] <- 0.8
#' parameters_setting$init_vec <- c(0.65, 0.35)
#' simulated_data <- simulate_HMM_data(
#'   seed_num = 1,
#'   p_noise = 7,
#'   N = 100,
#'   N_persub = 10,
#'   parameters_setting = parameters_setting
#' )
#' backward_C <- backward(
#'   delta = parameters_setting$init_vec,
#'   Y = simulated_data$y_mat[1, ],
#'   A = parameters_setting$trans_mat,
#'   B = parameters_setting$emis_mat,
#'   X = simulated_data$X_array[, 1:4, 1],
#'   family = "P"
#' )
#'
#' @export
backward <- function(delta, Y, A, B, X, family) {
    .Call(`_regmhmm_backward`, delta, Y, A, B, X, family)
}

#' @title Posterior Joint Probability Calculation for Hidden States in a Hidden Markov Model
#'
#' @description
#' Calculate the posterior joint probability of hidden states given parameters of a hidden Markov model.
#'
#' @param delta a vector of length S specifying the initial probabilities.
#' @param Y a vector of observations of size T.
#' @param X a design matrix of size T x p.
#' @param A a matrix of size S x S specifying the transition probabilities.
#' @param B a matrix of size S x (p + 1) specifying the GLM parameters of the emission probabilities.
#' @param family the family of the response.
#'
#' @returns
#' An array of size S x S x T that represents the posterior joint probability of hidden states.
#'
#' @examples
#' # Example usage of the function
#' parameters_setting <- list()
#' parameters_setting$emis_mat <- matrix(NA, nrow = 2, ncol = 4)
#' parameters_setting$emis_mat[1, 1] <- 0.1
#' parameters_setting$emis_mat[1, 2] <- 0.5
#' parameters_setting$emis_mat[1, 3] <- -0.75
#' parameters_setting$emis_mat[1, 4] <- 0.75
#' parameters_setting$emis_mat[2, 1] <- -0.1
#' parameters_setting$emis_mat[2, 2] <- -0.5
#' parameters_setting$emis_mat[2, 3] <- 0.75
#' parameters_setting$emis_mat[2, 4] <- 1
#' parameters_setting$trans_mat <- matrix(NA, nrow = 2, ncol = 2)
#' parameters_setting$trans_mat[1, 1] <- 0.65
#' parameters_setting$trans_mat[1, 2] <- 0.35
#' parameters_setting$trans_mat[2, 1] <- 0.2
#' parameters_setting$trans_mat[2, 2] <- 0.8
#' parameters_setting$init_vec <- c(0.65, 0.35)
#' dat <- simulate_HMM_data(
#'   seed_num = 1,
#'   p_noise = 7,
#'   N = 100,
#'   N_persub = 10,
#'   parameters_setting = parameters_setting
#' )
#' compute_joint_state_get <- compute_joint_state(
#'     delta = parameters_setting$init_vec,
#'     Y = dat$y_mat[1, ],
#'     A = parameters_setting$trans_mat,
#'     B = parameters_setting$emis_mat,
#'     X = dat$X_array[, 1:4, 1],
#'     family = "P"
#'   )
#'
#' @export
compute_joint_state <- function(delta, Y, A, B, X, family) {
    .Call(`_regmhmm_compute_joint_state`, delta, Y, A, B, X, family)
}

#' @title Log-Likelihood Calculation for Hidden Markov Models (Forward Algorithm)
#'
#' @description
#' Calculate the log-likelihood given parameters of a hidden Markov model using the forward algorithm. This function aids in assessing the likelihood of the observed data under the specified model.
#'
#' @param delta a vector of length S specifying the initial probabilities.
#' @param Y a vector of observations of size T.
#' @param X a design matrix of size T x p.
#' @param A a matrix of size S x S specifying the transition probabilities.
#' @param B a matrix of size S x (p + 1) specifying the GLM parameters of the emission probabilities.
#' @param family the family of the response.
#'
#' @returns
#'
#' A value that is the likelihood in log scale.
#'
#' @examples
#' # Example usage of the function
#' parameters_setting <- list()
#' parameters_setting$emis_mat <- matrix(NA, nrow = 2, ncol = 4)
#' parameters_setting$emis_mat[1, 1] <- 0.1
#' parameters_setting$emis_mat[1, 2] <- 0.5
#' parameters_setting$emis_mat[1, 3] <- -0.75
#' parameters_setting$emis_mat[1, 4] <- 0.75
#' parameters_setting$emis_mat[2, 1] <- -0.1
#' parameters_setting$emis_mat[2, 2] <- -0.5
#' parameters_setting$emis_mat[2, 3] <- 0.75
#' parameters_setting$emis_mat[2, 4] <- 1
#' parameters_setting$trans_mat <- matrix(NA, nrow = 2, ncol = 2)
#' parameters_setting$trans_mat[1, 1] <- 0.65
#' parameters_setting$trans_mat[1, 2] <- 0.35
#' parameters_setting$trans_mat[2, 1] <- 0.2
#' parameters_setting$trans_mat[2, 2] <- 0.8
#' parameters_setting$init_vec <- c(0.65, 0.35)
#' dat <- simulate_HMM_data(
#'   seed_num = 1,
#'   p_noise = 7,
#'   N = 100,
#'   N_persub = 10,
#'   parameters_setting = parameters_setting
#' )
#' llh_C <- compute_loglikelihood(
#'   delta = parameters_setting$init_vec,
#'   Y = dat$y_mat[1, ],
#'   A = parameters_setting$trans_mat,
#'   B = parameters_setting$emis_mat,
#'   X = dat$X_array[, 1:4, 1],
#'   family = "P"
#' )
#'
#' @export
compute_loglikelihood <- function(delta, Y, A, B, X, family) {
    .Call(`_regmhmm_compute_loglikelihood`, delta, Y, A, B, X, family)
}

#' @title Posterior Probability Estimation for Hidden States in Hidden Markov Models
#'
#' @description
#' Calculate the posterior probability of hidden states given parameters of a hidden Markov model.
#'
#' @param delta a vector of length S specifying the initial probabilities.
#' @param Y a vector of observations of size T.
#' @param X a design matrix of size T x p.
#' @param A a matrix of size S x S specifying the transition probabilities.
#' @param B a matrix of size S x (p + 1) specifying the GLM parameters of the emission probabilities.
#' @param family the family of the response.
#'
#' @returns
#' A matrix of size S x T that represents the posterior probability of hidden states.
#'
#' @examples
#' # Example usage of the function
#' parameters_setting <- list()
#' parameters_setting$emis_mat <- matrix(NA, nrow = 2, ncol = 4)
#' parameters_setting$emis_mat[1, 1] <- 0.1
#' parameters_setting$emis_mat[1, 2] <- 0.5
#' parameters_setting$emis_mat[1, 3] <- -0.75
#' parameters_setting$emis_mat[1, 4] <- 0.75
#' parameters_setting$emis_mat[2, 1] <- -0.1
#' parameters_setting$emis_mat[2, 2] <- -0.5
#' parameters_setting$emis_mat[2, 3] <- 0.75
#' parameters_setting$emis_mat[2, 4] <- 1
#' parameters_setting$trans_mat <- matrix(NA, nrow = 2, ncol = 2)
#' parameters_setting$trans_mat[1, 1] <- 0.65
#' parameters_setting$trans_mat[1, 2] <- 0.35
#' parameters_setting$trans_mat[2, 1] <- 0.2
#' parameters_setting$trans_mat[2, 2] <- 0.8
#' parameters_setting$init_vec <- c(0.65, 0.35)
#' simulated_data <- simulate_HMM_data(
#'   seed_num = 1,
#'   p_noise = 7,
#'   N = 100,
#'   N_persub = 10,
#'   parameters_setting = parameters_setting
#' )
#' compute_state_get <- compute_state(
#'   delta = parameters_setting$init_vec,
#'   Y = simulated_data$y_mat[1, ],
#'   A = parameters_setting$trans_mat,
#'   B = parameters_setting$emis_mat,
#'   X = simulated_data$X_array[, 1:4, 1],
#'  family = "P")
#'
#' @export
compute_state <- function(delta, Y, A, B, X, family) {
    .Call(`_regmhmm_compute_state`, delta, Y, A, B, X, family)
}

#' @title Forward Algorithm for Probability Calculation in Hidden Markov Models
#'
#' @description
#' Calculate the probability given parameters of a hidden Markov model using the forward algorithm. This function is essential for estimating the likelihood of observing a particular sequence of observations in the context of a Hidden Markov Model (HMM).
#'
#' @param delta a vector of length S specifying the initial probabilities.
#' @param Y a vector of observations of size T.
#' @param X a design matrix of size T x p.
#' @param A a matrix of size S x S specifying the transition probabilities.
#' @param B a matrix of size S x (p + 1) specifying the GLM parameters of the emission probabilities.
#' @param family the family of the response.
#' @returns
#'
#' A matrix of size S x T that is the forward probabilities in log scale.
#'
#' @examples
#' # Example usage of the function
#' parameters_setting <- list()
#' parameters_setting$emis_mat <- matrix(NA, nrow = 2, ncol = 4)
#' parameters_setting$emis_mat[1, 1] <- 0.1
#' parameters_setting$emis_mat[1, 2] <- 0.5
#' parameters_setting$emis_mat[1, 3] <- -0.75
#' parameters_setting$emis_mat[1, 4] <- 0.75
#' parameters_setting$emis_mat[2, 1] <- -0.1
#' parameters_setting$emis_mat[2, 2] <- -0.5
#' parameters_setting$emis_mat[2, 3] <- 0.75
#' parameters_setting$emis_mat[2, 4] <- 1
#' parameters_setting$trans_mat <- matrix(NA, nrow = 2, ncol = 2)
#' parameters_setting$trans_mat[1, 1] <- 0.65
#' parameters_setting$trans_mat[1, 2] <- 0.35
#' parameters_setting$trans_mat[2, 1] <- 0.2
#' parameters_setting$trans_mat[2, 2] <- 0.8
#' parameters_setting$init_vec <- c(0.65, 0.35)
#' dat <- simulate_HMM_data(
#'   seed_num = 1,
#'   p_noise = 7,
#'   N = 100,
#'   N_persub = 10,
#'   parameters_setting = parameters_setting
#' )
#' forward_C <- forward(
#'   delta = parameters_setting$init_vec,
#'   Y = dat$y_mat[1, ],
#'   A = parameters_setting$trans_mat,
#'   B = parameters_setting$emis_mat,
#'   X = dat$X_array[, 1:4, 1],
#'   family = "P"
#' )
#'
#' @export
forward <- function(delta, Y, A, B, X, family) {
    .Call(`_regmhmm_forward`, delta, Y, A, B, X, family)
}

#' @title Probability Calculation in Hidden Markov Models using Forward-Backward Algorithm
#'
#' @description
#' Calculate the probability given parameters of a hidden Markov model using a combination of the forward and backward algorithms.
#'
#' @param delta a vector of length S specifying the initial probabilities.
#' @param Y a vector of observations of size T.
#' @param X a design matrix of size T x p.
#' @param A a matrix of size S x S specifying the transition probabilities.
#' @param B a matrix of size S x (p + 1) specifying the GLM parameters of the emission probabilities.
#' @param family the family of the response.
#'
#' @returns
#' A list object with the following slots:
#'
#' \item{log_alpha}{a matrix of size S x T that is the forward probabilities in log scale.}
#'
#' \item{log_beta}{a matrix of size S x T that is the backward probabilities in log scale.}
#'
#' @examples
#' # Example usage of the function
#' parameters_setting <- list()
#' parameters_setting$emis_mat <- matrix(NA, nrow = 2, ncol = 4)
#' parameters_setting$emis_mat[1, 1] <- 0.1
#' parameters_setting$emis_mat[1, 2] <- 0.5
#' parameters_setting$emis_mat[1, 3] <- -0.75
#' parameters_setting$emis_mat[1, 4] <- 0.75
#' parameters_setting$emis_mat[2, 1] <- -0.1
#' parameters_setting$emis_mat[2, 2] <- -0.5
#' parameters_setting$emis_mat[2, 3] <- 0.75
#' parameters_setting$emis_mat[2, 4] <- 1
#' parameters_setting$trans_mat <- matrix(NA, nrow = 2, ncol = 2)
#' parameters_setting$trans_mat[1, 1] <- 0.65
#' parameters_setting$trans_mat[1, 2] <- 0.35
#' parameters_setting$trans_mat[2, 1] <- 0.2
#' parameters_setting$trans_mat[2, 2] <- 0.8
#' parameters_setting$init_vec <- c(0.65, 0.35)
#' simulated_data <- simulate_HMM_data(
#'   seed_num = 1,
#'   p_noise = 7,
#'   N = 100,
#'   N_persub = 10,
#'   parameters_setting = parameters_setting
#' )
#' forward_backward_C <- forward_backward(
#'   delta = parameters_setting$init_vec,
#'   Y = simulated_data$y_mat[1, ],
#'   A = parameters_setting$trans_mat,
#'   B = parameters_setting$emis_mat,
#'   X = simulated_data$X_array[, 1:4, 1],
#'   family = "P"
#' )
#'
#' @export
forward_backward <- function(delta, Y, A, B, X, family) {
    .Call(`_regmhmm_forward_backward`, delta, Y, A, B, X, family)
}