4.2-121

Author: alexanderrobitzsch

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: sirt
 Type: Package
 Title: Supplementary Item Response Theory Models
-Version: 4.2-114
-Date: 2025-04-07 15:44:35
+Version: 4.2-121
+Date: 2025-05-12 12:25:44
 Author: Alexander Robitzsch [aut,cre] (<https://orcid.org/0000-0002-8226-3132>)
 Maintainer: Alexander Robitzsch <robitzsch@ipn.uni-kiel.de>
 Description: 

R/RcppExports.R

@@ -1,5 +1,5 @@
 ## File Name: RcppExports.R
-## File Version: 4.002114
+## File Version: 4.002121
 # Generated by using Rcpp::compileAttributes() -> do not edit by hand
 # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
 
@@ -399,12 +399,20 @@ sirt_rcpp_xxirt_compute_likelihood <- function(dat, dat_resp_bool, probs, TP, ma
     .Call('_sirt_sirt_rcpp_xxirt_compute_likelihood', PACKAGE='sirt', dat, dat_resp_bool, probs, TP, maxK)
 }
 
+sirt_rcpp_xxirt_compute_likelihood_person_covariates <- function(dat, dat_resp_bool, probs, TP, maxK) {
+    .Call('_sirt_sirt_rcpp_xxirt_compute_likelihood_person_covariates', PACKAGE='sirt', dat, dat_resp_bool, probs, TP, maxK)
+}
+
+sirt_rcpp_xxirt_compute_loglike_case_theta_covariates <- function(dat, dat_resp_bool, logprobs, TP, maxK) {
+    .Call('_sirt_sirt_rcpp_xxirt_compute_loglike_case_theta_covariates', PACKAGE='sirt', dat, dat_resp_bool, logprobs, TP, maxK)
+}
+
 sirt_rcpp_xxirt_hessian_reduced_probs <- function(dat, dat_resp_bool, probs_ratio, TP, maxK, itemnr, itemnr2, use_itemnr2, p_xi_aj) {
     .Call('_sirt_sirt_rcpp_xxirt_hessian_reduced_probs', PACKAGE='sirt', dat, dat_resp_bool, probs_ratio, TP, maxK, itemnr, itemnr2, use_itemnr2, p_xi_aj)
 }
 
-sirt_rcpp_xxirt_newton_raphson_derivative_par <- function(dat, dat_resp_bool, ratio, p_xi_aj, item, prior_Theta, group0, weights, ll_case0, eps) {
-    .Call('_sirt_sirt_rcpp_xxirt_newton_raphson_derivative_par', PACKAGE='sirt', dat, dat_resp_bool, ratio, p_xi_aj, item, prior_Theta, group0, weights, ll_case0, eps)
+sirt_rcpp_xxirt_newton_raphson_derivative_par <- function(dat, dat_resp_bool, ratio, p_xi_aj, item, prior_Theta, group0, weights, ll_case0, eps, person_covariates, person_covariates_items) {
+    .Call('_sirt_sirt_rcpp_xxirt_newton_raphson_derivative_par', PACKAGE='sirt', dat, dat_resp_bool, ratio, p_xi_aj, item, prior_Theta, group0, weights, ll_case0, eps, person_covariates, person_covariates_items)
 }
 
 sirt_rcpp_xxirt_nr_pml_opt_fun <- function(prior_Theta, probs_items, freq1, freq2, W1, W2_long, G, K, I, TP, NI2, eps) {

R/mcmc_3pno_testlet_draw_itempars.R

@@ -1,5 +1,5 @@
 ## File Name: mcmc_3pno_testlet_draw_itempars.R
-## File Version: 0.12
+## File Version: 0.137
 
 
 #---- draw item parameters a and b
@@ -8,14 +8,18 @@ mcmc_3pno_testlet_draw_itempars <- function( theta, Z, I, N, weights,
 {
     # define adjusted Z values
     gamma.testletM <- gamma.testlet[, testletgroups ]
-    if (param==1){ Z <- Z - gamma.testletM }
-    if (param==3){ Z <- Z - a.testletM*gamma.testletM }
+    if (param==1){
+        Z <- Z - gamma.testletM
+    }
+    if (param==3){
+        Z <- Z - a.testletM*gamma.testletM
+    }
     if (param==2){ # Z <- Z
         theta0 <- theta
         Z0 <- Z
     }
     # for parametrization 2, this function must be rewritten
-    # because "the theta" is now item specific
+    # because 'the theta' is now item specific
     # loop over testlets tt=1,...,TT
     # maybe for TT+1 some adjustment has to be done
     #--- parametrization param=1
@@ -57,9 +61,10 @@ mcmc_3pno_testlet_draw_itempars <- function( theta, Z, I, N, weights,
         b <- rep(NA,I)
         TTT <- TT
         if ( sum( testletgroups==TT+1 ) > 0 ){
-                TTT <- TT + 1 }
-        for (tt in 1:TTT){
-            #tt <- 1
+            TTT <- TT + 1
+        }
+        for (tt in 1L:TTT){
+
             theta <- theta0
             Z <- Z0
             ind.tt <- which( testletgroups==tt)
@@ -91,16 +96,16 @@ mcmc_3pno_testlet_draw_itempars <- function( theta, Z, I, N, weights,
                 # compute t(Xast) %*% Z (weighted)
                 mj <- Sigma %*% crossprod( Xast * weights, Z )
                 mj <- as.matrix( t(mj))
-                    }
+            }
             #--------------
             # draw item parameters
             ipars <- sirt_rmvnorm( Itt, sigma=Sigma ) + mj
             a[ind.tt] <- ipars[,1]
             b[ind.tt] <- ipars[,2]
-        }            # end testlet tt
-    } # end param=2
+        }  # end testlet tt
+    }  # end param=2
     #-- output
-    res <- list( "a"=a, "b"=b)
+    res <- list( a=a, b=b)
     return(res)
 }
 

R/mcmc_as_formula.R

@@ -1,10 +1,10 @@
 ## File Name: mcmc_as_formula.R
-## File Version: 0.11
+## File Version: 0.121
 
 mcmc_as_formula <- function( string )
 {
-    string <- paste0( string, collapse=" " )
-    string <- gsub("___ ", "___", string, fixed=TRUE )
+    string <- paste0( string, collapse=' ' )
+    string <- gsub('___ ', '___', string, fixed=TRUE )
     form <- stats::as.formula(string)
     return(form)
 }

R/mcmc_confint.R

@@ -1,8 +1,8 @@
 ## File Name: mcmc_confint.R
-## File Version: 0.11
+## File Version: 0.121
 
-###########################################
-# confidence interval
+
+#*** confidence interval
 mcmc_confint <- function( mcmcobj, parm, level=.95, exclude="deviance" )
 {
     mcmcobj <- mcmcobj[, ! ( colnames(mcmcobj) %in% exclude ) ]
@@ -14,9 +14,8 @@ mcmc_confint <- function( mcmcobj, parm, level=.95, exclude="deviance" )
     q2 <- 1 - ( 1 - level ) / 2
     h2 <- apply( mcmcobj, 2, stats::quantile, q2 )
     res <- data.frame( h1, h2)
-    colnames(res)[1] <- paste0( round( 100*q1,1 ), " %")
-    colnames(res)[2] <- paste0( round( 100*q2,1 ), " %")
+    colnames(res)[1] <- paste0( round( 100*q1,1 ), ' %')
+    colnames(res)[2] <- paste0( round( 100*q2,1 ), ' %')
     rownames(res) <- colnames(mcmcobj)
     return(res)
 }
-###############################################

R/mcmc_rename_define_symbols.R

@@ -1,10 +1,10 @@
 ## File Name: mcmc_rename_define_symbols.R
-## File Version: 0.05
+## File Version: 0.061
 
 mcmc_rename_define_symbols <- function()
 {
-    trans <- c("X", "Z", "M")
-    orig <- c("[", "]", ",")
+    trans <- c('X', 'Z', 'M')
+    orig <- c('[', ']', ',')
     res <- list(trans=trans, orig=orig)
     return(res)
 }

R/xxirt.R

@@ -1,5 +1,5 @@
 ## File Name: xxirt.R
-## File Version: 1.172
+## File Version: 1.188
 
 
 #--- user specified item response model
@@ -62,7 +62,6 @@ xxirt <- function( dat, Theta=NULL, itemtype=NULL, customItems=NULL,
     item_index <- res$item_index
     dat <- as.matrix(dat)
 
-
     # create item list
     item_list <- xxirt_createItemList( customItems=customItems, itemtype=itemtype,
                         items=items, partable=partable )
@@ -97,7 +96,6 @@ xxirt <- function( dat, Theta=NULL, itemtype=NULL, customItems=NULL,
     do_cv <- cv_kfold>0
     em_count <- 1
 
-
     while(em_iterate){
 
         #--- create list with arguments for EM algorithm
@@ -250,6 +248,7 @@ xxirt <- function( dat, Theta=NULL, itemtype=NULL, customItems=NULL,
 
     #--- output
     s2 <- Sys.time()
+    time_diff <- s2-s1
     res <- list( partable=partable, par_items=par_items,
                 par_items_summary=par_items_summary, par_items_bounds=par_items_bounds,
                 par_Theta=par_Theta, Theta=Theta, probs_items=probs_items,
@@ -268,7 +267,7 @@ xxirt <- function( dat, Theta=NULL, itemtype=NULL, customItems=NULL,
                 res_opt_nr=res_opt_nr, opt_values_nr=opt_values_nr, maxit_nr=maxit_nr,
                 iter=iter-1, iter_em=iter_em-1, iter_nr=iter_nr,
                 estimator=estimator, pml_args=pml_args, em_args=em_args,
-                CALL=CALL, s1=s1, s2=s2 )
+                CALL=CALL, s1=s1, s2=s2, time_diff=time_diff )
     class(res) <- 'xxirt'
     return(res)
 }

R/xxirt_compute_casewise_likelihood.R

@@ -1,9 +1,17 @@
 ## File Name: xxirt_compute_casewise_likelihood.R
-## File Version: 0.01
+## File Version: 0.085
 
-xxirt_compute_casewise_likelihood <- function(prior_Theta, group, p.xi.aj)
+xxirt_compute_casewise_likelihood <- function(prior_Theta, group, p.xi.aj,
+        customTheta=NULL)
 {
-    prior1 <- t( prior_Theta[, group ] )
+    if (is.null(customTheta)){
+        customTheta <- list(person_covariates=FALSE)
+    }
+    if (customTheta$person_covariates){
+        prior1 <- t( prior_Theta )
+    } else {
+        prior1 <- t( prior_Theta[, group ] )
+    }
     p.aj.xi <- prior1 * p.xi.aj
     ll_case <- rowSums(p.aj.xi)
     return(ll_case)

R/xxirt_compute_itemprobs.R

@@ -1,11 +1,12 @@
 ## File Name: xxirt_compute_itemprobs.R
-## File Version: 0.215
+## File Version: 0.226
 
 
 # compute item probabilities
 xxirt_compute_itemprobs <- function( item_list, items, Theta, ncat,
         partable, partable_index, item_index=NULL )
 {
+    person_covariates <- attr(partable, 'person_covariates')
     TP <- nrow(Theta)
     maxK <- max(ncat)
     if ( is.null(item_index) ){
@@ -14,16 +15,29 @@ xxirt_compute_itemprobs <- function( item_list, items, Theta, ncat,
     }
     I <- length(item_index)
     # compute item probabilities as a function of theta
-    probs <- array( 0, dim=c(I,maxK,TP) )
+    if (person_covariates){
+        N <- nrow( (item_list[[1]])$X )
+        dim_probs <- c(I,maxK,TP,N)
+    } else {
+        dim_probs <- c(I,maxK,TP)
+    }
+    probs <- array( 0, dim=dim_probs )
     for (jj in 1L:I){
         ii <- item_index[jj]
         item_ii <- item_list[[ii]]
         par_ii <- partable[ partable_index[[ii]], 'value' ]
         ncat_ii <- ncat[ii]
         arg_ii <- list( par=par_ii, Theta=Theta, ncat=ncat_ii )
-        probs_ii <- do.call( item_ii$P, arg_ii )
-        probs[ jj, 1L:ncat_ii,] <- t(probs_ii)
-    }
+        if (person_covariates){
+            arg_ii$X <- item_ii$X
+        }
+        probs_ii <- do.call( what=item_ii$P, args=arg_ii )
+        if (!person_covariates){
+            probs[ jj, 1L:ncat_ii,] <- t(probs_ii)
+        } else {
+            probs[jj,,,] <- aperm(probs_ii, perm=c(2,1,3) )
+        }
+    }  # end jj
     return(probs)
 }
 

R/xxirt_compute_likelihood.R

@@ -1,19 +1,27 @@
 ## File Name: xxirt_compute_likelihood.R
-## File Version: 0.271
+## File Version: 0.290
 
 
 ##-- xxirt compute likelihood
 xxirt_compute_likelihood <- function( probs_items, dat, resp_index=NULL,
-        dat_resp_bool=NULL )
+        dat_resp_bool=NULL, person_covariates_items=FALSE )
 {
     N <- nrow(dat)
     TP <- dim(probs_items)[3]
     I <- dim(probs_items)[1]
     maxK <- dim(probs_items)[2]
-    p.xi.aj <- matrix( 1, nrow=N, ncol=TP )
-    probs <- matrix( probs_items, nrow=I, ncol=maxK*TP )
-    p.xi.aj <- sirt_rcpp_xxirt_compute_likelihood( dat=dat, dat_resp_bool=dat_resp_bool,
-                    probs=probs, TP=TP, maxK=maxK )
+    # p.xi.aj <- matrix( 1, nrow=N, ncol=TP )
+    if (!person_covariates_items){
+        probs <- matrix( probs_items, nrow=I, ncol=maxK*TP )
+        p.xi.aj <- sirt_rcpp_xxirt_compute_likelihood( dat=dat,
+                            dat_resp_bool=dat_resp_bool,
+                            probs=probs, TP=TP, maxK=maxK )
+    } else {
+        probs <- as.vector( probs_items )
+        p.xi.aj <- sirt_rcpp_xxirt_compute_likelihood_person_covariates( dat=dat,
+                        dat_resp_bool=dat_resp_bool, probs=probs, TP=TP, maxK=maxK )
+    }
+    #-- output
     return(p.xi.aj)
 }