3.5-16

alexanderrobitzsch · May 5, 2020 · 5c66690 · 5c66690
1 parent a050ec7
commit 5c66690
Show file tree

Hide file tree

Showing 40 changed files with 97 additions and 74 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,8 +1,8 @@
 Package: TAM
 Type: Package
 Title: Test Analysis Modules
-Version: 3.5-6
-Date: 2020-04-17 17:48:11
+Version: 3.5-16
+Date: 2020-05-05 14:48:35
 Author:
     Alexander Robitzsch [aut, cre], Thomas Kiefer [aut], Margaret Wu [aut]
 Maintainer: Alexander Robitzsch <[email protected]>

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

diff --git a/R/plot.tam.R b/R/plot.tam.R
@@ -1,5 +1,5 @@
 ## File Name: plot.tam.R
-## File Version: 9.2875
+## File Version: 9.289
 
 #--- plotting tam expected scores curves
 plot.tam <- function(x, items=1:x$nitems, type="expected",

diff --git a/R/summary.tam.jml.R b/R/summary.tam.jml.R
@@ -1,5 +1,5 @@
 ## File Name: summary.tam.jml.R
-## File Version: 9.2573
+## File Version: 9.258
 
 
 #***** summary for tam object

diff --git a/R/summary.tam.linking.R b/R/summary.tam.linking.R
@@ -1,5 +1,5 @@
 ## File Name: summary.tam.linking.R
-## File Version: 0.1581
+## File Version: 0.159
 
 summary.tam.linking <- function( object, file=NULL, ...)
 {

diff --git a/R/tam.fa.R b/R/tam.fa.R
@@ -1,5 +1,5 @@
 ## File Name: tam.fa.R
-## File Version: 9.2551
+## File Version: 9.256
 
 
 #---- Exploratory Factor Analysis and Bifactor Models

diff --git a/R/tam.jml.R b/R/tam.jml.R
@@ -1,5 +1,5 @@
 ## File Name: tam.jml.R
-## File Version: 9.3576
+## File Version: 9.361
 
 
 tam.jml <- function( resp, group=NULL, adj=.3, disattenuate=FALSE,

diff --git a/R/tam.jml.fit.R b/R/tam.jml.fit.R
@@ -1,5 +1,5 @@
 ## File Name: tam.jml.fit.R
-## File Version: 9.1991
+## File Version: 9.201
 
 
 tam.jml.fit <- function( tamobj )
@@ -32,7 +32,7 @@ tam.jml.fit <- function( tamobj )
     NU <- length(theta.unique)
     B_bari <- array(0,dim=c(NU, nitems))
     BB_bari <- array(0, dim=c(NU, nitems))
-    use_rcpp <- FALSE
+    use_rcpp <- TRUE
     res <- tam_mml_calc_prob(iIndex=1:nitems, A=A, AXsi=AXsi,
                         B=B, xsi=xsi, theta=matrix( theta.unique, nrow=NU, ncol=1),
                         nnodes=NU, maxK=maxK, recalc=FALSE, use_rcpp=use_rcpp )

diff --git a/R/tam.latreg.R b/R/tam.latreg.R
@@ -1,5 +1,5 @@
 ## File Name: tam.latreg.R
-## File Version: 9.339
+## File Version: 9.341
 
 ###################################################################
 # latent regression
@@ -294,7 +294,7 @@ tam.latreg <- function( like, theta=NULL, Y=NULL, group=NULL,
                  "groups"=if ( is.null(group)){1} else { groups },
                  "formulaY"=formulaY, "dataY"=dataY,
                  "pweights"=pweights,
-                 "time"=c(s1,s2,s2-s1),
+                 "time"=c(s1,s2),
                  "nstud"=nstud,
                  "hwt"=hwt,  "like"=like,
                  "ndim"=ndim,

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.5772
+## File Version: 9.582
 
 tam.mml.2pl <- function( resp, Y=NULL, group=NULL,  irtmodel="2PL",
                  formulaY=NULL, dataY=NULL,
@@ -557,7 +557,7 @@ tam.mml.2pl <- function( resp, Y=NULL, group=NULL,  irtmodel="2PL",
                "groups"=if ( is.null(group)){1} else { groups },
                "formulaY"=formulaY, "dataY"=dataY,
                "pweights"=pweights0,
-               "time"=c(s1,s2,s2-s1), "A"=A, "B"=B,
+               "time"=c(s1,s2), "A"=A, "B"=B,
                "se.B"=se.B,
                "nitems"=nitems, "maxK"=maxK, "AXsi"=AXsi,
                "AXsi_"=- AXsi,

diff --git a/R/tam.mml.3pl.R b/R/tam.mml.3pl.R
@@ -1,5 +1,6 @@
 ## File Name: tam.mml.3pl.R
-## File Version: 9.8541
+## File Version: 9.857
+
 tam.mml.3pl <- function( resp, Y=NULL, group=NULL,
             formulaY=NULL, dataY=NULL,
             ndim=1, pid=NULL,
@@ -835,7 +836,7 @@ tam.mml.3pl <- function( resp, Y=NULL, group=NULL,
                  "groups"=if ( is.null(group)){1} else { groups },
                  "formulaY"=formulaY, "dataY"=dataY,
                  "pweights"=pweights0,
-                 "time"=c(s1,s2,s2-s1), "A"=A, "B"=B,
+                 "time"=c(s1,s2), "A"=A, "B"=B,
                  "se.B"=se.B,
                  "nitems"=nitems, "maxK"=maxK, "AXsi"=AXsi,
                  "AXsi_"=- AXsi,

diff --git a/R/tam.mml.R b/R/tam.mml.R
@@ -1,5 +1,5 @@
 ## File Name: tam.mml.R
-## File Version: 9.8008
+## File Version: 9.802
 
 tam.mml <- function( resp, Y=NULL, group=NULL,  irtmodel="1PL",
             formulaY=NULL, dataY=NULL,
@@ -511,7 +511,7 @@ tam.mml <- function( resp, Y=NULL, group=NULL,  irtmodel="1PL",
                  "groups"=if ( is.null(group)){1} else { groups },
                  "formulaY"=formulaY, "dataY"=dataY,
                  "pweights"=pweights0,
-                 "time"=c(s1,s2,s2-s1), "A"=A, "B"=B,
+                 "time"=c(s1,s2), "A"=A, "B"=B,
                  "se.B"=se.B,
                  "nitems"=nitems, "maxK"=maxK, "AXsi"=AXsi,
                  "AXsi_"=- AXsi,

diff --git a/R/tam.mml.mfr.R b/R/tam.mml.mfr.R
@@ -1,5 +1,5 @@
 ## File Name: tam.mml.mfr.R
-## File Version: 9.9134
+## File Version: 9.924
 
 tam.mml.mfr <- function( resp, Y=NULL, group=NULL,  irtmodel="1PL",
             formulaY=NULL, dataY=NULL,
@@ -118,13 +118,15 @@ tam.mml.mfr <- function( resp, Y=NULL, group=NULL,  irtmodel="1PL",
 # cat(" --- design matrix ready" ) ; a1 <- Sys.time() ; print(a1-a0) ; a0 <- a1
 
     #--- processing in case of multiple person IDs in a dataset
-    tp <- max( table( pid ))
+    tp <- max(table(pid))
     if ( tp > 1){
-        res <- tam_mml_mfr_proc_multiple_person_ids( pid=pid, tp=tp, gresp=gresp, gresp.noStep=gresp.noStep,
-                    progress=progress )
+        res <- tam_mml_mfr_proc_multiple_person_ids( pid=pid, tp=tp, gresp=gresp,
+                    gresp.noStep=gresp.noStep, progress=progress, group=group, Y=Y)
         pid <- res$pid
         gresp <- res$gresp
         gresp.noStep <- res$gresp.noStep
+        group <- res$group
+        Y <- res$Y
     }
 # cat("process data in case of multiple persons" ) ; a1 <- Sys.time() ; print(a1-a0) ; a0 <- a1
 
@@ -133,9 +135,9 @@ tam.mml.mfr <- function( resp, Y=NULL, group=NULL,  irtmodel="1PL",
     xsi.fixed <- res$xsi.fixed
     xsi0 <- res$xsi0
 
-    nitems <- nrow( X.red )
+    nitems <- nrow(X.red)
     nstud <- nrow(gresp)        # number of students
-    if ( is.null( pweights) ){
+    if ( is.null(pweights) ){
         pweights <- rep(1,nstud) # weights of response pattern
     }
 
@@ -565,7 +567,7 @@ tam.mml.mfr <- function( resp, Y=NULL, group=NULL,  irtmodel="1PL",
                  "groups"=if ( is.null(group)){1} else { groups },
                  "formulaY"=formulaY, "dataY"=dataY,
                  "pweights"=pweights,
-                 "time"=c(s1,s2,s2-s1), "A"=A, "B"=B,
+                 "time"=c(s1,s2), "A"=A, "B"=B,
                  "se.B"=se.B,
                  "nitems"=nitems, "maxK"=maxK, "AXsi"=AXsi,
                  "AXsi_"=- AXsi,

diff --git a/R/tam.modelfit.R b/R/tam.modelfit.R
@@ -1,5 +1,5 @@
 ## File Name: tam.modelfit.R
-## File Version: 9.37
+## File Version: 9.38
 
 
 # Q3 statistic and model fit statistics for objects of class tam
@@ -47,7 +47,7 @@ tam.modelfit <- function( tamobj, progress=TRUE )
 
     #-- compute p value
     N <- nrow(resp)
-    se1 <- - abs( dfr2$aQ3 * sqrt( N -3 ) )
+    se1 <- - abs( tam_fisherz(dfr2$aQ3) * sqrt( N -3 ) )
     dfr2$p <- 2 * stats::pnorm( se1  )
     dfr <- dfr2
     dfr <- dfr[ order( dfr$aQ3, decreasing=TRUE), ]

diff --git a/R/tam.np.R b/R/tam.np.R
@@ -1,5 +1,5 @@
 ## File Name: tam.np.R
-## File Version: 0.412
+## File Version: 0.413
 
 
 tam.np <- function( dat, probs_init=NULL, pweights=NULL, lambda=NULL, control=list(),
@@ -167,7 +167,7 @@ tam.np <- function( dat, probs_init=NULL, pweights=NULL, lambda=NULL, control=li
 
     #--- output
     s2 <- Sys.time()
-    time <- c(s1, s2, s2-s1)
+    time <- c(s1, s2)
     res <- list( CALL=CALL, dat=dat, dat2=dat2, dat_resp=dat_resp, n.ik=n.ik, N.ik=N.ik,
                 item=item, rprobs=probs, pi.k=pi.k, nodes=nodes, pweights=pweights, like=f.yi.qk,
                 hwt=f.qk.yi, iter=iter, loglike=loglike, AIC=AIC, converged=converged,

diff --git a/R/tam.pv.mcmc.R b/R/tam.pv.mcmc.R
@@ -1,5 +1,5 @@
 ## File Name: tam.pv.mcmc.R
-## File Version: 0.847
+## File Version: 0.848
 
 tam.pv.mcmc <- function( tamobj, Y=NULL, group=NULL, beta_groups=TRUE,
                 nplausible=10, level=.95, n.iter=1000,
@@ -211,7 +211,7 @@ tam.pv.mcmc <- function( tamobj, Y=NULL, group=NULL, beta_groups=TRUE,
                     nplausible=nplausible, ndim=D, pweights=pweights, pid=pid,
                     n.iter=n.iter, n.burnin=n.burnin, ndim=D,
                     nplausible=nplausible, calc_ic=calc_ic,
-                    time=c(s1,s2,s2-s1), CALL=CALL )
+                    time=c(s1,s2), CALL=CALL )
     class(res) <- "tam.pv.mcmc"
     return(res)
 }

diff --git a/R/tam_find_root.R b/R/tam_find_root.R
@@ -1,9 +1,8 @@
 ## File Name: tam_find_root.R
-## File Version: 0.02
+## File Version: 0.03
 
 
-################################################################
-# root finding utility function
+#*** root finding utility function
 tam_find_root <- function( x1, y1, prob.lvl, theta )
 {
     N <- length(y1)
@@ -27,4 +26,3 @@ tam_find_root <- function( x1, y1, prob.lvl, theta )
     }
     return(thetasol)
 }
-################################################################
diff --git a/R/tam_fisherz.R b/R/tam_fisherz.R
@@ -0,0 +1,7 @@
+## File Name: tam_fisherz.R
+## File Version: 0.01
+
+tam_fisherz <- function(x)
+{
+    0.5*log( (1+x)/ (1-x) )
+}
diff --git a/R/tam_jml_version1.R b/R/tam_jml_version1.R
@@ -1,5 +1,5 @@
 ## File Name: tam_jml_version1.R
-## File Version: 9.357
+## File Version: 9.358
 
 tam_jml_version1 <- function( resp, group=NULL, adj=.3, disattenuate=FALSE,
                      bias=TRUE, xsi.fixed=NULL,  xsi.inits=NULL,
@@ -285,7 +285,7 @@ tam_jml_version1 <- function( resp, group=NULL, adj=.3, disattenuate=FALSE,
                "xsi.fixed"=xsi.fixed, "deviance"=deviance,
                "deviance.history"=deviance.history,
                "control"=con1a, "iter"=iter)
-  res$time <-  c(s1,s2,s2-s1)
+  res$time <-  c(s1,s2)
   class(res) <- "tam.jml"
   return(res)
 }
diff --git a/R/tam_jml_version2.R b/R/tam_jml_version2.R
@@ -1,5 +1,5 @@
 ## File Name: tam_jml_version2.R
-## File Version: 9.514
+## File Version: 9.515
 
 tam_jml_version2 <- function( resp, group=NULL, adj=.3, disattenuate=FALSE,
             bias=TRUE, xsi.fixed=NULL,  xsi.inits=NULL, A=NULL, B=NULL, Q=NULL,
@@ -283,7 +283,7 @@ tam_jml_version2 <- function( resp, group=NULL, adj=.3, disattenuate=FALSE,
                     A=A, B=B, nitems=nitems, maxK=maxK, rprobs=rprobs, nstud=nstud,
                     resp.ind.list=resp.ind.list, xsi.fixed=xsi.fixed, deviance=deviance,
                     deviance.history=deviance.history, control=con1a, iter=iter)
-    res$time <-  c(s11,s2,s2-s11)
+    res$time <-  c(s11,s2)
     class(res) <- "tam.jml"
     return(res)
 }

diff --git a/R/tam_jml_wle.R b/R/tam_jml_wle.R
@@ -1,5 +1,5 @@
 ## File Name: tam_jml_wle.R
-## File Version: 9.2864
+## File Version: 9.287
 
 
 #-- WLE in JML estimation

diff --git a/R/tam_linking_irf_discrepancy.R b/R/tam_linking_irf_discrepancy.R
@@ -1,7 +1,7 @@
 ## File Name: tam_linking_irf_discrepancy.R
-## File Version: 0.053
+## File Version: 0.054
 
-tam_linking_irf_discrepancy <- function(probs1, probs2, wgt, type, 
+tam_linking_irf_discrepancy <- function(probs1, probs2, wgt, type,
     pow_rob_hae=1, eps_rob_hae=1e-4)
 {
     K <- dim(probs1)[3]

diff --git a/R/tam_linking_joint.R b/R/tam_linking_joint.R
@@ -1,5 +1,5 @@
 ## File Name: tam_linking_joint.R
-## File Version: 0.077
+## File Version: 0.078
 
 tam_linking_joint <- function(NM, parameters_list, linking_args, verbose=TRUE)
 {
@@ -10,7 +10,7 @@ tam_linking_joint <- function(NM, parameters_list, linking_args, verbose=TRUE)
     eps_rob_hae <- linking_args$eps_rob_hae
     fix.slope <- linking_args$fix.slope
     par_init <- linking_args$par_init
-    
+
     #- control arguments
     control <- list()
     if (verbose){

diff --git a/R/tam_mml_3pl_ic.R b/R/tam_mml_3pl_ic.R
@@ -1,5 +1,5 @@
 ## File Name: tam_mml_3pl_ic.R
-## File Version: 9.2522
+## File Version: 9.253
 
 
 #--- Information criteria tam.mml.3pl

diff --git a/R/tam_mml_calc_prob_R.R b/R/tam_mml_calc_prob_R.R
@@ -1,5 +1,5 @@
 ## File Name: tam_mml_calc_prob_R.R
-## File Version: 0.1684
+## File Version: 0.170
 
 
 tam_mml_calc_prob_R <- function(iIndex, A, AXsi, B, xsi, theta,
@@ -41,7 +41,7 @@ tam_mml_calc_prob_R <- function(iIndex, A, AXsi, B, xsi, theta,
     # rr <- exp(rr1)
     rr <- tam_rcpp_calc_prob_subtract_max_exp( rr0=rr0, dim_rr=dim_rr )
 
-    
+
     #    rprobs <- rr / aperm( array( rep( colSums( aperm( rr, c(2,1,3) ),
     #                dims=1, na.rm=TRUE), maxK ), dim=dim(rr)[c(1,3,2)] ), c(1,3,2) )
     rprobs <- tam_rcpp_tam_mml_calc_prob_R_normalize_rprobs( rr=rr, dim_rr=dim_rr)

diff --git a/R/tam_mml_ic.R b/R/tam_mml_ic.R
@@ -1,5 +1,5 @@
 ## File Name: tam_mml_ic.R
-## File Version: 9.1992
+## File Version: 9.201
 
 
 #--- information criteria

diff --git a/R/tam_mml_mfr_proc_multiple_person_ids.R b/R/tam_mml_mfr_proc_multiple_person_ids.R
@@ -1,19 +1,24 @@
 ## File Name: tam_mml_mfr_proc_multiple_person_ids.R
-## File Version: 0.12
+## File Version: 0.23
 
 
 tam_mml_mfr_proc_multiple_person_ids <- function(pid,tp, gresp, gresp.noStep,
-        progress )
+        progress=TRUE, group=NULL, Y=NULL )
 {
     persons <- sort( unique( pid ) )
     NP <- length( persons )
-    person.ids <- sapply( persons, FUN=function( pp){ which( pid==pp ) },
+    person.ids <- sapply( persons, FUN=function(pp){ which( pid==pp ) },
                             simplify=FALSE)
     PP <- matrix( NA, nrow=NP, ncol=tp)
     for (pos in 1:tp){
         PP[,pos] <- unlist( lapply( person.ids, FUN=function(vv){ vv[pos] } ) )
     }
-
+    if (! is.null(group)){
+        group <- group[ PP[,1] ]
+    }
+    if (! is.null(Y)){
+        Y <- Y[ PP[,1],, drop=FALSE ]
+    }
     gresp0 <- matrix( NA, nrow=NP, ncol=ncol(gresp) )
     colnames(gresp0) <- colnames(gresp)
     gresp0.noStep <- matrix( NA, nrow=NP, ncol=ncol(gresp.noStep) )
@@ -56,7 +61,8 @@ tam_mml_mfr_proc_multiple_person_ids <- function(pid,tp, gresp, gresp.noStep,
         utils::flush.console()
     }
     #--- OUTPUT
-    res <- list(pid=pid, gresp=gresp, gresp.noStep=gresp.noStep)
+    res <- list(pid=pid, gresp=gresp, gresp.noStep=gresp.noStep,
+                    group=group, Y=Y)
     return(res)
 }
 

diff --git a/R/tam_summary_print_ic.R b/R/tam_summary_print_ic.R
@@ -1,5 +1,5 @@
 ## File Name: tam_summary_print_ic.R
-## File Version: 0.2722
+## File Version: 0.274
 
 tam_summary_print_ic <- function( object, digits_ic=0, digits_values=2, bayes_crit=FALSE )
 {