R/RcppExports.R

In zhenkewu/lotR: Latent class analysis with Observed Trees in R (lotR)

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

#' xlogx
#'
#' utility function
#'
#' @param x a positive number or zero
#'
#' @useDynLib lotR
#' @importFrom Rcpp sourceCpp
#' @export
xlogx <- function(x) {
    .Call('_lotR_xlogx', PACKAGE = 'lotR', x)
}

logsumexp <- function(logv_arma) {
    .Call('_lotR_logsumexp', PACKAGE = 'lotR', logv_arma)
}

#' logexpit to avoid numerical underflow
#'
#' @param x a number
#' @useDynLib lotR
#' @importFrom Rcpp sourceCpp
logexpit_cpp <- function(x) {
    .Call('_lotR_logexpit_cpp', PACKAGE = 'lotR', x)
}

logsumexp_row <- function(logv_arma) {
    .Call('_lotR_logsumexp_row', PACKAGE = 'lotR', logv_arma)
}

#' Calculate variational moments during the updates
#'
#' Get all moments that need update when iterating over a total of p internal and leaf nodes
#'
#' @param prob variational probabilities for \code{s_u}; length p
#' @param prob_gamma should be fixed: \code{c(1,rep(0,p-1))}
#' @param mu_gamma variational Gaussian means (for \code{s_u=1} component) for J*K
#' logit(class-specific response probabilities); (J,K,p) array; In R, we used a list of p (J,K) matrices
#' @param sigma_gamma variational Gaussian variances (for \code{s_u=1} component)
#' for J*K logit(class-specific response probabilities); (J,K,p) array
#' @param mu_alpha variational Gaussian mean vectors (for \code{s_u=1} component) -
#' this is a p by K-1 matrix; in R, we used a list of p vectors (each of length K-1)
#' @param Sigma_alpha variational Gaussian variances (for \code{s_u=1} component)
#' - this is an array of dimension (K-1, K-1, p); in R, we used a list of p matrices,
#' each of dimension K-1 by K-1.
#' @param anc a list of pL vectors, each vector has the node ids of the ancestors;
#' lengths may differ. The ancestors include the node concerned.
#' @param cardanc a numeric vector of length pL; integers. The number
#' of ancestors for each leaf node
#'
#' @return a List
#'
#' \describe{
#'   return List::create(Named("E_beta")=E_beta,
#'    Named("E_beta_sq")=E_beta_sq,
#'    Named("E_eta")=E_eta,
#'    Named("E_eta_sq")=E_eta_sq);
#'}
#'
#' @example
#' inst/example/variance_ss.R
#'
#' @useDynLib lotR
#' @importFrom Rcpp sourceCpp
#' @export
get_moments_cpp <- function(prob, prob_gamma, mu_gamma, sigma_gamma, mu_alpha, Sigma_alpha, anc, cardanc) {
    .Call('_lotR_get_moments_cpp', PACKAGE = 'lotR', prob, prob_gamma, mu_gamma, sigma_gamma, mu_alpha, Sigma_alpha, anc, cardanc)
}

#' Calculate variational moments during the updates (only for node u)
#'
#' update only selected moments that need update when iterating over u (except for \code{rmat})
#'
#' (one-node version of \code{\link{get_moments_cpp}})
#' @param leaves_u the leaf descendant node ids for node u
#' @param E_beta,E_beta_sq,E_eta,E_eta_sq moment updates produced by \code{\link{get_moments_cpp}}
#' @param prob variational probabilities for \code{s_u}; length p
#' @param prob_gamma should be fixed: \code{c(1,rep(0,p-1))}
#' @inheritParams get_moments_cpp
#' @return a List
#'
#' \describe{
#'   return List::create(Named("E_beta")=E_beta,
#'    Named("E_beta_sq")=E_beta_sq,
#'    Named("E_eta")=E_eta,
#'    Named("E_eta_sq")=E_eta_sq);
#'}
#'
#' @example
#' inst/example/variance_ss.R
#'
#' @useDynLib lotR
#' @importFrom Rcpp sourceCpp
get_moments_cpp_eco <- function(leaves_u, E_beta, E_beta_sq, E_eta, E_eta_sq, prob, prob_gamma, mu_gamma, sigma_gamma, mu_alpha, Sigma_alpha, anc, cardanc) {
    .Call('_lotR_get_moments_cpp_eco', PACKAGE = 'lotR', leaves_u, E_beta, E_beta_sq, E_eta, E_eta_sq, prob, prob_gamma, mu_gamma, sigma_gamma, mu_alpha, Sigma_alpha, anc, cardanc)
}

#' Summarize the posterior mean, sd and confidence interval (grouped or individual leaf nodes)
#'
#' @param prob a vector of variational probability. Length = p.
#' At the extremes, it can also be a vector of zeros and ones, indicating which nodes
#' are selected based on variational probability (prob > 0.5).
#' @param mu_gamma variational Gaussian means (for \code{s_u=1} component) for J*K
#' logit(class-specific response probabilities); (J,K,p) array; In R, we used a list of p (J,K) matrices
#' @param sigma_gamma variational Gaussian variances (for \code{s_u=1} component)
#' for J*K logit(class-specific response probabilities); (J,K,p) array
#' @param mu_alpha variational Gaussian mean vectors (for \code{s_u=1} component) -
#' this is a p by K-1 matrix; in R, we used a list of p vectors (each of length K-1)
#' @param Sigma_alpha variational Gaussian variances (for \code{s_u=1} component)
#' - this is an array of dimension (K-1, K-1, p); in R, we used a list of p matrices,
#' each of dimension K-1 by K-1.
#' @param anc a list of pL vectors, each vector has the node ids of the ancestors;
#' lengths may differ. The ancestors include the node concerned.
#' @param cardanc a numeric vector of length pL; integers. The number
#' of ancestors for each leaf node
#' @param z  = \code{ ci_level+(1-ci_level)/2}
#'
#' @return a list
#' \describe{
#'
#' Named("beta_est")=beta_est,
#' Named("beta_sd_est")=beta_sd_est,
#' Named("beta_cil")=beta_cil,
#' Named("beta_ciu")=beta_ciu,
#'
#'
#' Named("eta_est")=eta_est,
#' Named("eta_var_est")=eta_var_est,
#' Named("eta_cil")=eta_cil,
#' Named("eta_ciu")=eta_ciu
#'
#' }
#' @export
get_est_cpp <- function(prob, mu_gamma, sigma_gamma, mu_alpha, Sigma_alpha, anc, cardanc, z) {
    .Call('_lotR_get_est_cpp', PACKAGE = 'lotR', prob, mu_gamma, sigma_gamma, mu_alpha, Sigma_alpha, anc, cardanc, z)
}

#' Update the variational probabilities of each observation in one of K classes
#'
#' This function updates the N by K matrix \code{rmat} in the package
#'
#' @param psi,g_psi,phi,g_phi local variational parameters
#' @param X transformed data: 2Y-1
#' @param E_beta,E_eta,E_beta_sq,E_eta_sq moment updates produced by \code{\link{get_moments_cpp}}
#' @param v_lookup a vector of length equal to the total number of rows in \code{X};
#' each element is an integer, indicating which leaf does the observation belong to.
#'
#' @return  N by K variational multinomial probabilities; row sums are 1s.
#'
#' @useDynLib lotR
#' @importFrom Rcpp sourceCpp
#' @export
update_rmat <- function(psi, g_psi, phi, g_phi, X, E_beta, E_eta, E_beta_sq, E_eta_sq, v_lookup) {
    .Call('_lotR_update_rmat', PACKAGE = 'lotR', psi, g_psi, phi, g_phi, X, E_beta, E_eta, E_beta_sq, E_eta_sq, v_lookup)
}

#' Update the variational probabilities of each observation in one of K classes
#'
#' This function updates the N by K matrix \code{rmat} in the package
#'
#' @param unknown_ids a vector of integers representing subject ids with unknown class memberships
#' @param psi,g_psi,phi,g_phi local variational parameters
#' @param X transformed data: 2Y-1
#' @param E_beta,E_eta,E_beta_sq,E_eta_sq moment updates produced by \code{\link{get_moments_cpp}}
#' @param v_lookup a vector of length equal to the total number of rows in \code{X};
#' each element is an integer, indicating which leaf does the observation belong to.
#'
#' @return  N by K variational multinomial probabilities; row sums are 1s.
#'
#' @useDynLib lotR
#' @importFrom Rcpp sourceCpp
#' @export
update_rmat_partial <- function(unknown_ids, psi, g_psi, phi, g_phi, X, E_beta, E_eta, E_beta_sq, E_eta_sq, v_lookup) {
    .Call('_lotR_update_rmat_partial', PACKAGE = 'lotR', unknown_ids, psi, g_psi, phi, g_phi, X, E_beta, E_eta, E_beta_sq, E_eta_sq, v_lookup)
}

#' Update gamma and alpha together. Update the variational mean and variance for logit of
#' class-specific response probabilities (for the \code{s_u=1} component)
#'
#' shared tau's
#'
#' @param u node id (internal or leaf node
#' @param g_psi,g_phi g of local variational parameters
#' @param tau_2_t_u,tau_1_t_u variational Gaussian variances for gamma and alpha
#' @param E_beta,E_zeta_u moment updates produced by \code{\link{get_moments_cpp}};
#' \code{E_zeta_u} is directly calculated: \code{prob[u]*sigma_gamma[u,,]}
#' @param X transformed data: 2Y-1
#' @param E_eta leaves' expected eta
#' @param E_xi_u node u's expected xi
#' @param rmat a matrix of variational probabilities of all observations
#' belong to K classes; N by K; each row sums to 1
#' @param h_pau a numeric vector of length p indicating the branch length
#' between a node and its parent
#' @param levels a vector of possibly repeating integers from 1 to Fg, or L,
#' @param subject_ids the ids of subjects in the leaf descendants of node u
#' @param v_lookup a vector of length equal to the total number of rows in X;
#' each element is an integer, indicating which leaf does the observation belong to.
#'
#' @return  a list
#' \describe{
#'   \item{resA}{actually 1/A in the paper, this is variance}
#'   \item{resB}{}
#'   \item{logresBsq_o_A}{}
#'   \item{resC}{actually 1/C in the paper, this is variance}
#'   \item{resD}{}
#'   \item{logresDsq_o_C}{}
#' }
#'
#' @useDynLib lotR
#' @importFrom Rcpp sourceCpp
#' @export
update_gamma_alpha_subid <- function(u, g_psi, g_phi, tau_2_t_u, tau_1_t_u, E_beta, E_zeta_u, X, E_eta, E_xi_u, rmat, h_pau, levels, subject_ids, v_lookup) {
    .Call('_lotR_update_gamma_alpha_subid', PACKAGE = 'lotR', u, g_psi, g_phi, tau_2_t_u, tau_1_t_u, E_beta, E_zeta_u, X, E_eta, E_xi_u, rmat, h_pau, levels, subject_ids, v_lookup)
}

#' Update gamma and alpha together. Update the variational mean and variance for logit of
#' class-specific response probabilities (for the \code{s_u=1} component)
#'
#' separate tau's
#'
#' @param u node id (internal or leaf node
#' @param g_psi,g_phi g of local variational parameters
#' @param tau_2_t_u,tau_1_t_u variational Gaussian variances for gamma and alpha
#' @param E_beta,E_zeta_u moment updates produced by \code{\link{get_moments_cpp}};
#' \code{E_zeta_u} is directly calculated: \code{prob[u]*sigma_gamma[u,,]}
#' @param X transformed data: 2Y-1
#' @param E_eta leaves' expected eta
#' @param E_xi_u node u's expected xi
#' @param rmat a matrix of variational probabilities of all observations
#' belong to K classes; N by K; each row sums to 1
#' @param h_pau a numeric vector of length p indicating the branch length
#' between a node and its parent
#' @param levels a vector of possibly repeating integers from 1 to Fg, or L,
#' @param subject_ids the ids of subjects in the leaf descendants of node u
#' @param v_lookup a vector of length equal to the total number of rows in X;
#' each element is an integer, indicating which leaf does the observation belong to.
#'
#' @return  a list
#' \describe{
#'   \item{resA}{actually 1/A in the paper, this is variance}
#'   \item{resB}{}
#'   \item{logresBsq_o_A}{}
#'   \item{resC}{actually 1/C in the paper, this is variance}
#'   \item{resD}{}
#'   \item{logresDsq_o_C}{}
#' }
#'
#' @useDynLib lotR
#' @importFrom Rcpp sourceCpp
#' @export
update_gamma_alpha_subid_separate_tau <- function(u, g_psi, g_phi, tau_2_t_u, tau_1_t_u, E_beta, E_zeta_u, X, E_eta, E_xi_u, rmat, h_pau, levels, subject_ids, v_lookup) {
    .Call('_lotR_update_gamma_alpha_subid_separate_tau', PACKAGE = 'lotR', u, g_psi, g_phi, tau_2_t_u, tau_1_t_u, E_beta, E_zeta_u, X, E_eta, E_xi_u, rmat, h_pau, levels, subject_ids, v_lookup)
}

#' Initialize sigma alpha for shared tau
#'
#' @param u,g_phi,rmat,tau_1_t,h_pau,subject_ids,v_lookup NB: lazy now, see other functions.
#'
#' @useDynLib lotR
#' @importFrom Rcpp sourceCpp
getC <- function(u, g_phi, rmat, tau_1_t, h_pau, subject_ids, v_lookup) {
    .Call('_lotR_getC', PACKAGE = 'lotR', u, g_phi, rmat, tau_1_t, h_pau, subject_ids, v_lookup)
}

#' Initialize sigma alpha for distinct tau
#'
#' @param u,g_phi,rmat,tau_1_t,h_pau,subject_ids,v_lookup see \code{\link{getC}}
#'
#' @useDynLib lotR
#' @importFrom Rcpp sourceCpp
getC_separate_tau <- function(u, g_phi, rmat, tau_1_t, h_pau, subject_ids, v_lookup) {
    .Call('_lotR_getC_separate_tau', PACKAGE = 'lotR', u, g_phi, rmat, tau_1_t, h_pau, subject_ids, v_lookup)
}

#' calculate line 1 and 2 and 13 of ELBO to assess convergence
#' and choose among converged estimates from many restarts
#'
#' @param psi,g_psi,phi,g_phi see \code{\link{update_hyperparams}}
#' @param rmat a matrix of variational probabilities of all observations
#' belong to K classes; N by K; each row sums to 1
#' @param E_beta,E_beta_sq,E_eta,E_eta_sq moments during
#' VI updates from \code{\link{get_moments_cpp}}
#' @param X transformed data: 2Y-1
#' @param v_lookup a vector of indicators; of size N, each indicating the leaf id (from 1 to pL)
#' for each sample.
#'
#' @return line 1, 2, 13 of the ELBO
#'
#' @useDynLib lotR
#' @importFrom Rcpp sourceCpp
get_line1_2_13_subid <- function(psi, g_psi, phi, g_phi, rmat, E_beta, E_beta_sq, E_eta, E_eta_sq, X, v_lookup) {
    .Call('_lotR_get_line1_2_13_subid', PACKAGE = 'lotR', psi, g_psi, phi, g_phi, rmat, E_beta, E_beta_sq, E_eta, E_eta_sq, X, v_lookup)
}