R/RcppExports.R

In fourPNO: Bayesian 4 Parameter Item Response Model

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

#' Initialize Thresholds
#'
#' Internal function for initializing item thresholds.
#'
#' @param Ms A `vector` with the number of scale values.
#'
#' @return
#' A `matrix` that is a Multivariate Normal distribution
#'
#' @author
#' Steven Andrew Culpepper
#'
#' @seealso
#' [Gibbs_4PNO()]
#'
#' @noRd
NULL

#' Internal Function for Updating Theta in Gibbs Sampler
#'
#' Update theta in Gibbs sampler
#'
#' @param N               An `int`, which gives the number of observations.
#'                        (> 0)
#' @param Z               A `matrix` N by J of continuous augmented data.
#' @param as              A `vector` of item discrimination parameters.
#' @param bs              A `vector` of item threshold parameters.
#' @param theta           A `vector` of prior thetas.
#' @param mu_theta        The prior mean for theta.
#' @param Sigma_theta_inv The prior inverse variance for theta.
#'
#' @return
#' A `vector` of thetas.
#'
#' @author
#' Steven Andrew Culpepper
#'
#' @seealso
#' [Gibbs_4PNO()]
#'
#' @noRd
NULL

#' Update a and b Parameters of 2PNO, 3PNO, 4PNO
#'
#' Update item slope and threshold
#'
#' @param N            An `int`, which gives the number of observations. (> 0)
#' @param J            An `int`, which gives the number of items. (> 0)
#' @param Z            A `matrix` N by J of continuous augmented data.
#' @param as           A `vector` of item discrimination parameters.
#' @param bs           A `vector` of item threshold parameters.
#' @param theta        A `vector` of prior thetas.
#' @param mu_xi        A two dimensional `vector` of prior item parameter
#'                     means.
#' @param Sigma_xi_inv A two dimensional identity `matrix` of prior item
#'                     parameter VC matrix.
#'
#' @return
#' A `list` of item parameters.
#'
#' @author
#' Steven Andrew Culpepper
#'
#' @seealso
#' [Gibbs_4PNO()]
#'
#' @noRd
NULL

#' Update a and b Parameters of 4pno without alpha > 0 Restriction
#'
#' Update item slope and threshold
#'
#' @param N            An `int`, which gives the number of observations. (> 0)
#' @param J            An `int`, which gives the number of items. (> 0)
#' @param Z            A `matrix` N by J of continuous augmented data.
#' @param as           A `vector` of item discrimination parameters.
#' @param bs           A `vector` of item threshold parameters.
#' @param theta        A `vector` of prior thetas.
#' @param mu_xi        A two dimensional `vector` of prior item parameter
#'                     means.
#' @param Sigma_xi_inv A two dimensional identity `matrix` of prior item
#'                     parameter VC matrix.
#'
#' @return
#' A `list` of item parameters.
#'
#' @author
#' Steven Andrew Culpepper
#'
#' @seealso
#' [Gibbs_4PNO()]
#'
#' @noRd
NULL

#' Update Lower and Upper Asymptote Parameters of 4PNO
#'
#' Internal function to update item lower and upper asymptote
#'
#' @param Y        A N by J `matrix` of item responses.
#' @param Ysum     A `vector` of item total scores.
#' @param Z        A `matrix` N by J of continuous augmented data.
#' @param as       A `vector` of item discrimination parameters.
#' @param bs       A `vector` of item threshold parameters.
#' @param gs       A `vector` of item lower asymptote parameters.
#' @param ss       A `vector` of item upper asymptote parameters.
#' @param theta    A `vector` of prior thetas.
#' @param Kaps     A `matrix` for item thresholds
#'                 (used for internal computations).
#' @param alpha_c  The lower asymptote prior 'a' parameter.
#' @param beta_c   The lower asymptote prior 'b' parameter.
#' @param alpha_s  The upper asymptote prior 'a' parameter.
#' @param beta_s   The upper asymptote prior 'b' parameter.
#' @param gwg_reps The number of Gibbs within Gibbs MCMC samples for
#'                 marginal distribution of gamma.
#'
#' @return
#' A `list` of item threshold parameters.
#'
#' @author
#' Steven Andrew Culpepper
#'
#' @seealso
#' [Gibbs_4PNO()]
#'
#' @noRd
NULL

#' Update 2PNO Model Parameters
#'
#' Internal function to update 2PNO parameters
#'
#' @param N               The number of observations.
#' @param J               The number of items.
#' @param Y               A N by J `matrix` of item responses.
#' @param Z               A `matrix` N by J of continuous augmented data.
#' @param as              A `vector` of item discrimination parameters.
#' @param bs              A `vector` of item threshold parameters.
#' @param theta           A `vector` of prior thetas.
#' @param Kaps            A `matrix` for item thresholds
#'                        (used for internal computations).
#' @param mu_xi           Prior mean for item parameters.
#' @param Sigma_xi_inv    Prior item parameter inverse variance-covariance
#'                        matrix.
#' @param mu_theta        Prior mean for theta.
#' @param Sigma_theta_inv Prior inverse variance for theta.
#'
#' @return
#' A `list` of item parameters.
#'
#' @author
#' Steven Andrew Culpepper
#'
#' @seealso
#' [Gibbs_2PNO()]
#'
#' @noRd
NULL

#' Generate Random Multivariate Normal Distribution
#'
#' Creates a random Multivariate Normal when given number of
#' obs, mean, and sigma.
#'
#' @param n     An `int`, which gives the number of observations.  (> 0)
#' @param mu    A `vector` length m that represents the means of
#'              the normals.
#' @param sigma A `matrix` with dimensions m x m that provides the
#'              covariance matrix.
#'
#' @return
#' A `matrix` that is a Multivariate Normal distribution
#'
#' @author
#' James J Balamuta
#'
#' @export
#' @examples
#' # Call with the following data:
#' rmvnorm(2, c(0,0), diag(2))
rmvnorm <- function(n, mu, sigma) {
    .Call(`_fourPNO_rmvnorm`, n, mu, sigma)
}

#' Compute 4PNO Deviance
#'
#' Internal function to -2LL
#'
#' @param N     An `int`, which gives the number of observations.  (> 0)
#' @param J     An `int`, which gives the number of items.  (> 0)
#' @param Y     A N by J `matrix` of item responses.
#' @param as    A `vector` of item discrimination parameters.
#' @param bs    A `vector` of item threshold parameters.
#' @param gs    A `vector` of item lower asymptote parameters.
#' @param ss    A `vector` of item upper asymptote parameters.
#' @param theta A `vector` of prior thetas.
#'
#' @return
#' -2LL.
#' @author
#' Steven Andrew Culpepper
#'
#' @seealso
#' [Gibbs_4PNO()]
#'
#' @export
min2LL_4pno <- function(N, J, Y, as, bs, gs, ss, theta) {
    .Call(`_fourPNO_min2LL_4pno`, N, J, Y, as, bs, gs, ss, theta)
}

#' Simulate from 4PNO Model
#'
#' Generate item responses under the 4PNO
#'
#' @param N     An `int`, which gives the number of observations. (> 0)
#' @param J     An `int`, which gives the number of items. (> 0)
#' @param as    A `vector` of item discrimination parameters.
#' @param bs    A `vector` of item threshold parameters.
#' @param gs    A `vector` of item lower asymptote parameters.
#' @param ss    A `vector` of item upper asymptote parameters.
#' @param theta A `vector` of prior thetas.
#'
#' @return
#' A N by J `matrix` of dichotomous item responses.
#'
#' @author
#' Steven Andrew Culpepper
#'
#' @seealso
#' [Gibbs_4PNO()]
#'
#' @export
Y_4pno_simulate <- function(N, J, as, bs, gs, ss, theta) {
    .Call(`_fourPNO_Y_4pno_simulate`, N, J, as, bs, gs, ss, theta)
}

#' Calculate Tabulated Total Scores
#'
#' Internal function to -2LL
#'
#' @param N  An `int`, which gives the number of observations. (> 0)
#' @param J  An `int`, which gives the number of items. (> 0)
#' @param Y  A N by J `matrix` of item responses.
#'
#' @return
#' A vector of tabulated total scores.
#'
#' @author
#' Steven Andrew Culpepper
#'
#' @seealso
#' [Gibbs_4PNO()]
#'
#' @export
Total_Tabulate <- function(N, J, Y) {
    .Call(`_fourPNO_Total_Tabulate`, N, J, Y)
}

#' Gibbs Implementation of 4PNO
#'
#' Internal function to -2LL
#'
#' @param Y               A N by J `matrix` of item responses.
#' @param mu_xi           A two dimensional `vector` of prior item parameter
#'                        means.
#' @param Sigma_xi_inv    A two dimensional identity `matrix` of prior item
#'                        parameter VC matrix.
#' @param mu_theta        The prior mean for theta.
#' @param Sigma_theta_inv The prior inverse variance for theta.
#' @param alpha_c         The lower asymptote prior 'a' parameter.
#' @param beta_c          The lower asymptote prior 'b' parameter.
#' @param alpha_s         The upper asymptote prior 'a' parameter.
#' @param beta_s          The upper asymptote prior 'b' parameter.
#' @param burnin          The number of MCMC samples to discard.
#' @param cTF             A J dimensional `vector` indicating which
#'                        lower asymptotes to estimate.
#'                        0 = exclude lower asymptote and
#'                        1 = include lower asymptote.
#' @param sTF             A J dimensional `vector` indicating which
#'                        upper asymptotes to estimate.
#'                        0 = exclude upper asymptote and
#'                        1 = include upper asymptote.
#' @param gwg_reps        The number of Gibbs within Gibbs MCMC samples for
#'                        marginal distribution of gamma. Values between
#'                        5 to 10 are adequate.
#' @param chain_length    The number of MCMC samples.
#'
#' @return
#' Samples from posterior.
#'
#' @author
#' Steven Andrew Culpepper
#'
#' @export
#' @examples
#' # Simulate small 4PNO dataset to demonstrate function
#' J = 5
#' N = 100
#'
#' # Population item parameters
#' as_t = rnorm(J,mean=2,sd=.5)
#' bs_t = rnorm(J,mean=0,sd=.5)
#'
#' # Sampling gs and ss with truncation
#' gs_t = rbeta(J,1,8)
#' ps_g = pbeta(1-gs_t,1,8)
#' ss_t = qbeta(runif(J)*ps_g,1,8)
#' theta_t <- rnorm(N)
#' Y_t = Y_4pno_simulate(N,J,as=as_t,bs=bs_t,gs=gs_t,ss=ss_t,theta=theta_t)
#'
#' # Setting prior parameters
#' mu_theta=0
#' Sigma_theta_inv=1
#' mu_xi = c(0,0)
#' alpha_c=alpha_s=beta_c=beta_s=1
#' Sigma_xi_inv = solve(2*matrix(c(1,0,0,1),2,2))
#' burnin = 1000
#'
#' # Execute Gibbs sampler
#' out_t = Gibbs_4PNO(Y_t,mu_xi,Sigma_xi_inv,mu_theta,
#'                    Sigma_theta_inv,alpha_c,beta_c,alpha_s,
#'                    beta_s,burnin,rep(1,J),rep(1,J),
#'                    gwg_reps=5,chain_length=burnin*2)
#'
#' # Summarizing posterior distribution
#' OUT = cbind(apply(out_t$AS[,-c(1:burnin)],1,mean),
#'             apply(out_t$BS[,-c(1:burnin)],1,mean),
#'             apply(out_t$GS[,-c(1:burnin)],1,mean),
#'             apply(out_t$SS[,-c(1:burnin)],1,mean),
#'             apply(out_t$AS[,-c(1:burnin)],1,sd),
#'             apply(out_t$BS[,-c(1:burnin)],1,sd),
#'             apply(out_t$GS[,-c(1:burnin)],1,sd),
#'             apply(out_t$SS[,-c(1:burnin)],1,sd) )
#'
#' OUT = cbind(1:J,OUT)
#' colnames(OUT) = c('Item', 'as', 'bs', 'gs', 'ss', 'as_sd', 'bs_sd',
#'                   'gs_sd', 'ss_sd')
#' print(OUT, digits = 3)
Gibbs_4PNO <- function(Y, mu_xi, Sigma_xi_inv, mu_theta, Sigma_theta_inv, alpha_c, beta_c, alpha_s, beta_s, burnin, cTF, sTF, gwg_reps, chain_length = 10000L) {
    .Call(`_fourPNO_Gibbs_4PNO`, Y, mu_xi, Sigma_xi_inv, mu_theta, Sigma_theta_inv, alpha_c, beta_c, alpha_s, beta_s, burnin, cTF, sTF, gwg_reps, chain_length)
}

#' Gibbs Implementation of 2PNO
#'
#' Implement Gibbs 2PNO Sampler
#'
#' @param Y                A N by J `matrix` of item responses.
#' @param mu_xi            A two dimensional `vector` of prior item parameter
#'                         means.
#' @param Sigma_xi_inv     A two dimensional identity `matrix` of prior item
#'                         parameter VC matrix.
#' @param mu_theta         The prior mean for theta.
#' @param Sigma_theta_inv  The prior inverse variance for theta.
#' @param burnin           The number of MCMC samples to discard.
#' @param chain_length     The number of MCMC samples.
#'
#' @return
#' Samples from posterior.
#'
#' @author
#' Steven Andrew Culpepper
#'
#' @export
#' @examples
#' # simulate small 2PNO dataset to demonstrate function
#' J = 5
#' N = 100
#'
#' # Population item parameters
#' as_t = rnorm(J,mean=2,sd=.5)
#' bs_t = rnorm(J,mean=0,sd=.5)
#'
#' # Sampling gs and ss with truncation
#' gs_t = rbeta(J,1,8)
#' ps_g = pbeta(1-gs_t,1,8)
#' ss_t = qbeta(runif(J)*ps_g,1,8)
#' theta_t = rnorm(N)
#' Y_t = Y_4pno_simulate(N,J,as=as_t,bs=bs_t,gs=gs_t,ss=ss_t,theta=theta_t)
#'
#' # Setting prior parameters
#' mu_theta = 0
#' Sigma_theta_inv = 1
#' mu_xi = c(0,0)
#' alpha_c = alpha_s = beta_c = beta_s = 1
#' Sigma_xi_inv = solve(2*matrix(c(1,0,0,1), 2, 2))
#' burnin = 1000
#'
#' # Execute Gibbs sampler. This should take about 15.5 minutes
#' out_t = Gibbs_4PNO(Y_t,mu_xi,Sigma_xi_inv,mu_theta,Sigma_theta_inv,
#'                     alpha_c,beta_c,alpha_s, beta_s,burnin,
#'                     rep(1,J),rep(1,J),gwg_reps=5,chain_length=burnin*2)
#'
#' # Summarizing posterior distribution
#' OUT = cbind(
#'     apply(out_t$AS[, -c(1:burnin)], 1, mean),
#'     apply(out_t$BS[, -c(1:burnin)], 1, mean),
#'     apply(out_t$GS[, -c(1:burnin)], 1, mean),
#'     apply(out_t$SS[, -c(1:burnin)], 1, mean),
#'     apply(out_t$AS[, -c(1:burnin)], 1, sd),
#'     apply(out_t$BS[, -c(1:burnin)], 1, sd),
#'     apply(out_t$GS[, -c(1:burnin)], 1, sd),
#'     apply(out_t$SS[, -c(1:burnin)], 1, sd)
#' )
#' OUT = cbind(1:J, OUT)
#' colnames(OUT) = c('Item','as','bs','gs','ss','as_sd','bs_sd',
#'                   'gs_sd','ss_sd')
#' print(OUT, digits = 3)
Gibbs_2PNO <- function(Y, mu_xi, Sigma_xi_inv, mu_theta, Sigma_theta_inv, burnin, chain_length = 10000L) {
    .Call(`_fourPNO_Gibbs_2PNO`, Y, mu_xi, Sigma_xi_inv, mu_theta, Sigma_theta_inv, burnin, chain_length)
}