4.3-4

alexanderrobitzsch · Sep 9, 2024 · e47c6ae · e47c6ae
1 parent 65d709b
commit e47c6ae
Show file tree

Hide file tree

Showing 90 changed files with 11,810 additions and 16,645 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,8 +1,8 @@
 Package: TAM
 Type: Package
 Title: Test Analysis Modules
-Version: 4.3-2
-Date: 2024-02-20 00:16:18
+Version: 4.3-4
+Date: 2024-09-09 14:17:19
 Author:
     Alexander Robitzsch [aut,cre] (<https://orcid.org/0000-0002-8226-3132>),
     Thomas Kiefer [aut], 

diff --git a/R/RcppExports.R b/R/RcppExports.R
@@ -1,5 +1,5 @@
 ## File Name: RcppExports.R
-## File Version: 4.003002
+## File Version: 4.003004
 # Generated by using Rcpp::compileAttributes() -> do not edit by hand
 # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
 

diff --git a/R/tam.jml.R b/R/tam.jml.R
@@ -1,11 +1,11 @@
 ## File Name: tam.jml.R
-## File Version: 9.367
+## File Version: 9.373
 
 
 tam.jml <- function( resp, group=NULL, adj=.3, disattenuate=FALSE,
-            bias=TRUE, xsi.fixed=NULL,  xsi.inits=NULL,  theta.fixed=NULL,
+            bias=TRUE, xsi.fixed=NULL, xsi.inits=NULL, theta.fixed=NULL,
             A=NULL, B=NULL, Q=NULL, ndim=1,
-            pweights=NULL, constraint="cases",
+            pweights=NULL, constraint="cases", theta_proc=NULL,
             verbose=TRUE, control=list(), version=3 )
 {
     CALL <- match.call()
@@ -23,13 +23,19 @@ tam.jml <- function( resp, group=NULL, adj=.3, disattenuate=FALSE,
         }
     }
 
+    #*** theta_proc
+    if (!is.null(theta_proc)){
+        version <- 1
+    }
+
     #**** version=1
     if (version==1){
         constraint <- "cases"
         res <- tam_jml_version1( resp=resp, group=group, adj=adj,
                     disattenuate=disattenuate, bias=bias, xsi.fixed=xsi.fixed,
                     xsi.inits=xsi.inits, A=A, B=B, Q=Q, ndim=ndim,
-                    theta.fixed=theta.fixed, pweights=pweights, control=control )
+                    theta.fixed=theta.fixed, pweights=pweights, control=control,
+                    theta_proc=theta_proc)
     }
     #**** version=2
     if (version>=2){

diff --git a/R/tam.mml.2pl.R b/R/tam.mml.2pl.R
@@ -1,5 +1,5 @@
 ## File Name: tam.mml.2pl.R
-## File Version: 9.589
+## File Version: 9.593
 
 tam.mml.2pl <- function( resp, Y=NULL, group=NULL,  irtmodel="2PL",
                  formulaY=NULL, dataY=NULL,

diff --git a/R/tam_jml_version1.R b/R/tam_jml_version1.R
@@ -1,11 +1,11 @@
 ## File Name: tam_jml_version1.R
-## File Version: 9.358
+## File Version: 9.369
 
 tam_jml_version1 <- function( resp, group=NULL, adj=.3, disattenuate=FALSE,
                      bias=TRUE, xsi.fixed=NULL,  xsi.inits=NULL,
                      theta.fixed=NULL,
                      A=NULL, B=NULL, Q=NULL, ndim=1,
-                     pweights=NULL, control=list() )
+                     pweights=NULL, theta_proc=NULL, control=list() )
 {
 
 
@@ -23,10 +23,11 @@ tam_jml_version1 <- function( resp, group=NULL, adj=.3, disattenuate=FALSE,
   Lcon <- length(con)
   con1a <- con1 <- con ;
   names(con1) <- NULL
-  for (cc in 1:Lcon ){
+  for (cc in 1L:Lcon ){
     assign( names(con)[cc], con1[[cc]], envir=e1 )
   }
 
+
   resp <- add.colnames.resp(resp)
 
   # maximum no. of categories per item.
@@ -70,36 +71,36 @@ tam_jml_version1 <- function( resp, group=NULL, adj=.3, disattenuate=FALSE,
   } else { xsi <- rep(0,np)   }
   if ( ! is.null( xsi.fixed ) ){
     xsi[ xsi.fixed[,1] ] <- xsi.fixed[,2]
-    est.xsi.index <- setdiff( 1:np, xsi.fixed[,1] )
-  } else { est.xsi.index <- 1:np }
+    est.xsi.index <- setdiff( 1L:np, xsi.fixed[,1] )
+  } else { est.xsi.index <- 1L:np }
 
 
   # group indicators for variance matrix
   if ( ! is.null(group) ){
     groups <- sort(unique(group))
     G <- length(groups)
     # user must label groups from 1, ..., G
-    if ( length( setdiff( 1:G, groups)  ) > 0 ){
+    if ( length( setdiff( 1L:G, groups)  ) > 0 ){
       stop("Label groups from 1, ...,G\n")
     }
   } else { G <- 1 }
 
   # define response indicator matrix for missings
   resp.ind <- 1 - is.na(resp)
-  resp.ind.list <- list( 1:nitems )
-  for (i in 1:nitems){ resp.ind.list[[i]] <- which( resp.ind[,i]==1)  }
+  resp.ind.list <- list( 1L:nitems )
+  for (i in 1L:nitems){ resp.ind.list[[i]] <- which( resp.ind[,i]==1)  }
   resp[ is.na(resp) ] <- 0     # set all missings to zero
 
   # Create an index linking items and parameters
   indexIP <- colSums(aperm(A, c(2,1,3)) !=0, na.rm=TRUE)
   # define list of elements for item parameters
-  indexIP.list <- list( 1:np )
-  for ( kk in 1:np ){
+  indexIP.list <- list( 1L:np )
+  for ( kk in 1L:np ){
     indexIP.list[[kk]] <- which( indexIP[,kk] > 0 )
   }
 
 
-  col.index <- rep( 1:nitems, each=maxK )
+  col.index <- rep( 1L:nitems, each=maxK )
   cResp <- resp[, col.index  ]*resp.ind[, col.index ]
   # This line does not take missings into account
   cResp <- 1 * t( t(cResp)==rep(0:(maxK-1), nitems) )
@@ -154,7 +155,7 @@ tam_jml_version1 <- function( resp, group=NULL, adj=.3, disattenuate=FALSE,
   deviance <- 0
   deviance.history <- matrix( 0, nrow=maxiter, ncol=2)
   colnames(deviance.history) <- c("iter", "deviance")
-  deviance.history[,1] <- 1:maxiter
+  deviance.history[,1] <- 1L:maxiter
 
   iter <- 0
   meanChangeWLE <- maxChangeWLE <- maxChangeP <- 999    # item parameter change
@@ -178,7 +179,7 @@ tam_jml_version1 <- function( resp, group=NULL, adj=.3, disattenuate=FALSE,
     #-- update theta (ability estimates)
     jmlAbility <- tam_jml_wle( tamobj, resp, resp.ind, A, B, nstud, nitems, maxK, convM,
                     PersonScores, theta, xsi, Msteps, WLE=FALSE,
-                    theta.fixed=theta.fixed)
+                    theta.fixed=theta.fixed, theta_proc=theta_proc)
 
     theta <- jmlAbility$theta
     if (is.null(xsi.fixed)){
@@ -187,6 +188,7 @@ tam_jml_version1 <- function( resp, group=NULL, adj=.3, disattenuate=FALSE,
     meanChangeWLE <- jmlAbility$meanChangeWLE
     errorMLE <- jmlAbility$errorWLE
 
+
     #update xsi, item parameters
     jmlxsi <- tam_jml_version1_calc_xsi( resp, resp.ind, A, B, nstud, nitems, maxK, convM,
                             ItemScore, theta, xsi, Msteps, pweightsM,
@@ -197,12 +199,12 @@ tam_jml_version1 <- function( resp, group=NULL, adj=.3, disattenuate=FALSE,
 
     #Deviance
     #Calculate Axsi. Only need to do this once for ability estimates.
-    for (i in 1:nitems) {
-      for (k in 1:maxK){
+    for (i in 1L:nitems) {
+      for (k in 1L:maxK){
         AXsi[i,k] <- ( A[i,k,] %*% xsi )
       }
     }
-    res <- tam_mml_calc_prob(iIndex=1:nitems, A, AXsi,
+    res <- tam_mml_calc_prob(iIndex=1L:nitems, A, AXsi,
                         B, xsi, theta, nstud, maxK, recalc=FALSE )
     rprobs <- res[["rprobs"]]
     crprobs <- t( matrix( aperm( rprobs, c(2,1,3) ), nrow=dim(rprobs)[3], byrow=TRUE ) )
@@ -223,13 +225,14 @@ tam_jml_version1 <- function( resp, group=NULL, adj=.3, disattenuate=FALSE,
     #@ARb 2012-08-27
     # stop loop (break) if there is no change in deviation
     if ( abs( deviance-olddeviance) < 1E-10 ){ break }
+
   }# end of all convergence
 
   #After convergence, compute final WLE (WLE set to TRUE)
 
   jmlWLE <- tam_jml_wle( tamobj, resp, resp.ind, A, B, nstud, nitems, maxK, convM,
                           PersonScores, theta, xsi, Msteps, WLE=TRUE,
-                          theta.fixed=theta.fixed )
+                          theta.fixed=theta.fixed, theta_proc=theta_proc )
 
   thetaWLE <- jmlWLE$theta[,1]
 
@@ -254,7 +257,7 @@ tam_jml_version1 <- function( resp, group=NULL, adj=.3, disattenuate=FALSE,
 
   # collect item statistics
   item <- data.frame( "xsi.label"=dimnames(A)[[3]],
-        "xsi.index"=1:( length(xsi) ), "xsi"=xsi,
+        "xsi.index"=1L:( length(xsi) ), "xsi"=xsi,
         "se.xsi"=errorP
     )
 
@@ -271,7 +274,7 @@ tam_jml_version1 <- function( resp, group=NULL, adj=.3, disattenuate=FALSE,
   }
 
   # Output list
-  deviance.history <- deviance.history[ 1:iter, ]
+  deviance.history <- deviance.history[ 1L:iter, ]
   res <- list( "item"=item, "xsi"=xsi,  "errorP"=errorP,
                "theta"=theta[,1], "errorWLE"=errorWLE,  "WLE"=thetaWLE,
                "WLEreliability"=WLEreliability,

diff --git a/R/tam_jml_wle.R b/R/tam_jml_wle.R
@@ -1,12 +1,12 @@
 ## File Name: tam_jml_wle.R
-## File Version: 9.324
+## File Version: 9.330
 
 
 #-- WLE in JML estimation
 tam_jml_wle <- function ( tamobj, resp, resp.ind, A, B, nstud, nitems, maxK, convM,
             PersonScores, theta, xsi, Msteps, WLE=FALSE,
             theta.fixed=NULL, progress=FALSE, output.prob=TRUE, damp=0,
-            version=2)
+            version=2, theta_proc=NULL)
 {
 
     AXsi <- matrix(0, nrow=nitems, ncol=maxK)
@@ -21,8 +21,8 @@ tam_jml_wle <- function ( tamobj, resp, resp.ind, A, B, nstud, nitems, maxK, con
     B_Cube <- array(0,dim=nstud)
 
     #Calculate Axsi. Only need to do this once for ability estimates.
-    for (i in 1:nitems) {
-        for (k in 1:maxK){
+    for (i in 1L:nitems) {
+        for (k in 1L:maxK){
             AXsi[i,k] <- ( A[i,k,] %*% xsi )
         }
     }
@@ -52,7 +52,7 @@ a0 <- Sys.time()
 
     while (!convergeWLE & ( iterWLE <=Msteps ) ){
         if (version==2){
-            resWLE <- tam_mml_calc_prob(iIndex=1:nitems, A=A, AXsi=AXsi,
+            resWLE <- tam_mml_calc_prob(iIndex=1L:nitems, A=A, AXsi=AXsi,
                             B=B, xsi=xsi, theta=theta, nnodes=nstud, maxK=maxK, recalc=FALSE )
             rprobsWLE <- resWLE$rprobs
             rprobsWLE[ is.na(rprobsWLE) ] <- 0
@@ -66,7 +66,7 @@ a0 <- Sys.time()
         if (version==2){
             B_bari <- B1[,1] * rprobsWLE[, 1, ]
             BB_bari <- BB[,1] * rprobsWLE[, 1, ]
-            for (kk in 2:maxK){
+            for (kk in 2L:maxK){
                 B_bari <- B_bari + B1[,kk]*rprobsWLE[,kk,]
                 BB_bari <- BB_bari + BB[,kk] * rprobsWLE[, kk, ]
             }
@@ -80,7 +80,7 @@ a0 <- Sys.time()
             BB_bari <- res$BB_bari
         }
 
-        # B_bari.OLD <- sapply(1:nitems, function(i) colSums(B1[i,] * rprobsWLE[i,,], na.rm=TRUE)) * resp.ind
+        # B_bari.OLD <- sapply(1L:nitems, function(i) colSums(B1[i,] * rprobsWLE[i,,], na.rm=TRUE)) * resp.ind
         # B1        [ nitems, maxK ]
         # rprobsWLE [ nitems, maxK, nstud ]
         # resp.ind  [ nstud, nitems ]
@@ -96,7 +96,7 @@ a0 <- Sys.time()
 
         if (WLE) {
             BBB_bari <- BBB[,1] * rprobsWLE[, 1, ]
-            for (kk in 2:maxK){
+            for (kk in 2L:maxK){
                 BBB_bari <- BBB_bari + BBB[,kk] * rprobsWLE[, kk, ]
             }
             BBB_bari <- t(BBB_bari) * resp.ind
@@ -134,13 +134,19 @@ a0 <- Sys.time()
     }
 
     cat("\n")
+
+    if (!is.null(theta_proc)){
+        theta <- theta_proc(theta=theta)
+    }
+
     meanChangeWLE <- mean(theta - thetaOld)
     #standard errors of theta estimates
     errorWLE <- sqrt(err_inv)
     if ( ! is.null(theta.fixed ) ){
         errorWLE[ theta.fixed[,1] ] <- 0
     }
 
+
     res <- list( "theta"=theta, "errorWLE"=errorWLE, "meanChangeWLE"=meanChangeWLE)
     return (res)
 }

diff --git a/R/tam_mml_2pl_mstep_slope.R b/R/tam_mml_2pl_mstep_slope.R
@@ -1,5 +1,5 @@
 ## File Name: tam_mml_2pl_mstep_slope.R
-## File Version: 9.579
+## File Version: 9.584
 
 
 tam_mml_2pl_mstep_slope <- function (B_orig, B, B_obs, B.fixed, max.increment, nitems, A,
@@ -13,8 +13,8 @@ tam_mml_2pl_mstep_slope <- function (B_orig, B, B_obs, B.fixed, max.increment, n
     xtemp <- matrix(0, nrow=1, ncol=1)
     converge <- FALSE
     Biter <- 1
-    mK <- 1:maxK
-    items.temp <- 1:nitems
+    mK <- 1L:maxK
+    items.temp <- 1L:nitems
     items.conv <- NULL
     items.conv1 <- c(-1)
     increments_msteps <- rep(NA,Msteps)
@@ -51,7 +51,7 @@ tam_mml_2pl_mstep_slope <- function (B_orig, B, B_obs, B.fixed, max.increment, n
         LIT <- length(items.temp)
 
         ######     D I M E N S I O N S     ######
-        for (dd in 1:ndim){
+        for (dd in 1L:ndim){
             if ( irtmodel %in% c("GPCM","GPCM.design","GPCM.groups") ){
                 xtemp <- matrix(0, nrow=LIT, ncol=TP )
             }
@@ -131,17 +131,17 @@ tam_mml_2pl_mstep_slope <- function (B_orig, B, B_obs, B.fixed, max.increment, n
                 increment <- tam_outer( increment.temp, mK-1)
                 d1 <- tam_outer(  1 / abs( deriv.temp ), mK-1 )
                 LL <- ncol(d1)
-                for (ll in 1:LL){
+                for (ll in 1L:LL){
                     m1 <- sqrt( diag( E %*% d1[,ll] %*% t( d1[,ll] ) %*% t(E) ) )
                     if (Biter==1){
                         se.B[,ll,dd]  <- m1
                     }
                 }
                 nB <- dim(B)
                 B_ind <- 1 * ( B_orig !=0 )
-                for (dd in 1:nB[3]){
+                for (dd in 1L:nB[3]){
                     EB <- E %*% basispar[,dd]
-                    for (cc in 1:(nB[2]-1)){
+                    for (cc in 1L:(nB[2]-1)){
                         B[,cc+1,dd] <- cc * EB * B_ind[,cc+1,dd]
                     }
                 }
@@ -189,7 +189,7 @@ tam_mml_2pl_mstep_slope <- function (B_orig, B, B_obs, B.fixed, max.increment, n
         if ( irtmodel=="2PL" ){
             items.temp <- which( apply( old_increment, 1,
                             FUN=function(ll){ ! ( max(abs(ll)) < convM ) } ) )
-            items.conv <- setdiff( 1:nitems, items.temp )
+            items.conv <- setdiff( 1L:nitems, items.temp )
             if ( length(items.conv) > 0 ){
                 items.conv1 <- items.conv
             }

diff --git a/README.md b/README.md
@@ -21,9 +21,9 @@ The CRAN version can be installed from within R using:
 utils::install.packages("TAM")
 ```
 
-#### GitHub version `TAM` 4.3-2 (2024-02-20)
+#### GitHub version `TAM` 4.3-4 (2024-09-09)
 
-[![](https://img.shields.io/badge/github%20version-4.3--2-orange.svg)](https://github.com/alexanderrobitzsch/TAM)&#160;&#160;
+[![](https://img.shields.io/badge/github%20version-4.3--4-orange.svg)](https://github.com/alexanderrobitzsch/TAM)&#160;&#160;
 
 The version hosted [here](https://github.com/alexanderrobitzsch/TAM) is the development version of `TAM`. 
 The GitHub version can be installed using `devtools` as