3.2-13

alexanderrobitzsch · Mar 29, 2019 · 27b38ec · 27b38ec
1 parent 31c6ab0
commit 27b38ec
Show file tree

Hide file tree

Showing 36 changed files with 549 additions and 448 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,8 +1,8 @@
 Package: TAM
 Type: Package
 Title: Test Analysis Modules
-Version: 3.2-1
-Date: 2019-03-19 10:53:50
+Version: 3.2-13
+Date: 2019-03-29 19:44:43
 Author:
     Alexander Robitzsch [aut, cre], Thomas Kiefer [aut], Margaret Wu [aut]
 Maintainer: Alexander Robitzsch <[email protected]>

diff --git a/NAMESPACE b/NAMESPACE
@@ -111,6 +111,7 @@ export(designMatrices.mfr)
 export(designMatrices.mfr2)
 export(doparse)
 export(EAPrel)
+export(IRT.cv)
 export(IRT.drawPV)
 export(IRT.informationCurves)
 export(IRT.linearCFA)
@@ -217,6 +218,7 @@ S3method(anova, tam.mml)
 S3method(anova, tam.mml.3pl)
 S3method(anova, tam.np)
 S3method(anova, tamaan)
+S3method(IRT.cv, tam.np)
 S3method(IRT.data, tam.mml)
 S3method(IRT.data, tam.mml.3pl)
 S3method(IRT.data, tamaan)

diff --git a/R/IRT.cv.R b/R/IRT.cv.R
@@ -0,0 +1,11 @@
+## File Name: IRT.cv.R
+## File Version: 0.02
+
+
+
+# S3 method
+IRT.cv <- function(object, ...)
+{
+  UseMethod("IRT.cv")
+}
+
diff --git a/R/IRT.cv.tam.np.R b/R/IRT.cv.tam.np.R
@@ -0,0 +1,37 @@
+## File Name: IRT.cv.tam.np.R
+## File Version: 0.18
+
+
+IRT.cv.tam.np <- function(object, kfold=10, ...)
+{
+    #* arrange list of arguments
+    args <- as.list(object$CALL)
+    args$control <- object$control
+    args$control$progress <- FALSE
+    args$pars_init <- object$pars
+    pweights <- object$pweights
+    N <- length(pweights)
+    args1 <- list(...)
+    args <- tam_include_arguments_in_list(args=args, args1=args1 )
+
+    #- do cross-validation
+    v <- N/kfold
+    ind_vec <- floor( ( 1:N )*N/(N+1) / v ) + 1
+    dev_cv <- 0
+    eps <- 1E-10
+    cat(paste0("|", paste0(rep("*",kfold), collapse=""), "|\n|"))
+    utils::flush.console()
+    for (kk in 1:kfold){
+        ind_kk <- which(ind_vec==kk)
+        pweights_kk <- pweights
+        pweights_kk[ind_kk] <- eps
+        args$pweights <- pweights_kk
+        res <- do.call(what=tam.np, args=args)
+        ll_individual_kk <- res$ll_individual[ind_kk]
+        dev_cv <- dev_cv - 2*sum(ll_individual_kk)
+        tam_cat_flush_console(label="-")
+    }
+    tam_cat_flush_console(label="|\n")
+    #--- output
+    return(dev_cv)
+}
diff --git a/R/IRT.expectedCounts.tam.R b/R/IRT.expectedCounts.tam.R
@@ -1,5 +1,5 @@
 ## File Name: IRT.expectedCounts.tam.R
-## File Version: 9.17
+## File Version: 9.18
 
 ###########################################################
 ###########################################################
@@ -35,7 +35,8 @@ IRT.expectedCounts.tam.np <- function( object, ... )
 
 ###########################################################
 # object of class tam.mml.3pl
-IRT.expectedCounts.tam.mml.3pl <- function( object, ... ){
+IRT.expectedCounts.tam.mml.3pl <- function( object, ... )
+{
     ll <- aperm( object$n.ik, c(2,3,1,4) )
     dimnames(ll)[[1]] <- colnames(object$resp)
     attr(ll,"theta") <- object$theta

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

diff --git a/R/designMatrices.mfr.R b/R/designMatrices.mfr.R
@@ -1,8 +1,8 @@
 ## File Name: designMatrices.mfr.R
-## File Version: 9.39
+## File Version: 9.418
+
 
 
-#########################################################################
 designMatrices.mfr <- function( resp, formulaA=~ item + item:step, facets=NULL,
             constraint=c("cases", "items"), ndim=1,
             Q=NULL, A=NULL, B=NULL, progress=FALSE )
@@ -15,16 +15,16 @@ z0 <- Sys.time()
     ### Basic Information and Initializations
     constraint <- match.arg(constraint)
     ## restructure formulaA
-    t1 <- attr( stats::terms( formulaA ), "term.labels" )
+    t1 <- attr( stats::terms(formulaA), "term.labels" )
     t2 <- intersect( c("item", "step", "item:step"), t1 )
-
-z0 <- tamcat( " ---  z20", z0, tamcat_active )
+    t0 <- attr( stats::terms(formulaA), "intercept" )
+    inc <- ""
+    if ( t0 %in% c(0,-1) ){ inc <- "0 + "}
 
     formulaA <- paste(  paste( c(t2, setdiff(t1, t2 ) ), collapse=" + " ) )
-    formulaA <- stats::as.formula( paste( " ~ ", formulaA ) )
+    formulaA <- stats::as.formula( paste( " ~ ", inc, formulaA ) )
 
-    #********************************
-    # change formate in facets
+    #--- change formate in facets
     FF <- ncol(facets)
     NFF <- nrow(facets)
     if (progress){
@@ -274,7 +274,6 @@ z0 <- tamcat( " --- .rename.items (gresp.noStep)", z0, tamcat_active )
                                         xsi.table )    )
 z0 <- tamcat( " --- .rename.items (gresp.noStep) facet list", z0, tamcat_active )
 
-
     Q <- .rename.items( matr=Q, itemren, cols=FALSE)
     dimnames(Q)[[1]] <- dimnames(A)[[1]]
 z0 <- tamcat( " --- .rename.items (Q)", z0, tamcat_active )

diff --git a/R/designMatrices.mfr_aux.R b/R/designMatrices.mfr_aux.R
@@ -1,7 +1,8 @@
 ## File Name: designMatrices.mfr_aux.R
-## File Version: 9.20
+## File Version: 9.255
 
-.generate.interactions <- function(X, facets, formulaA, mm ){
+.generate.interactions <- function(X, facets, formulaA, mm )
+{
     d1 <- d0 <- X
     h1 <- sapply( colnames(d1), FUN=function(vv){
                 length(grep( vv, paste(formulaA) )) } )
@@ -227,12 +228,14 @@ if (!vers){
     return(matr)
         }
 #############################################################
-.rename.items2 <- function( vec, itemren ){
+.rename.items2 <- function( vec, itemren )
+{
     cM <- vec
     I <- nrow(itemren)
-
-vers <- TRUE
-#vers <- FALSE
+    vers <- TRUE
+    if (is.null(cM)){
+        vers <- FALSE
+    }
 if (vers){
 v0 <- Sys.time()
     cM0 <- cM

diff --git a/R/designMatrices_aux.R b/R/designMatrices_aux.R
@@ -1,5 +1,5 @@
 ## File Name: designMatrices_aux.R
-## File Version: 9.09
+## File Version: 9.103
 
 #############################################################
 print.designMatrices <-
@@ -41,10 +41,10 @@ rownames.design2 <- function(X){
 
 ###########################################################
 ## function .A.matrix
-.A.matrix <-
-  function( resp, formulaA=~ item + item*step, facets=NULL,
+.A.matrix <- function( resp, formulaA=~ item + item*step, facets=NULL,
             constraint=c("cases", "items"), progress=FALSE,
-            maxKi=NULL ){
+            maxKi=NULL )
+{
     z0 <- Sys.time()
     ### redefine facets matrix
     facets0 <- facets
@@ -90,28 +90,6 @@ rownames.design2 <- function(X){
     # no contrasts for items
     nitems <- ncol(resp)
     #    contr.list[["item"]] <- diag(1,nitems)
-    #******
-    ### prepare data-Object for model.matrix()
-    # expand.list <-
-    #   as.vector( c( list( if( "item" %in% fvars ) factor(1:nI),
-    #                       if( "step" %in% fvars ) factor(1:maxK) ),
-    #                 if( length( otherFacets )==1){
-    #                   list( factor( 1:max(facets[, otherFacets]) ) )
-    #                   #                    list( factor( unique( facets[, otherFacets] ) ) )
-    #                 } else if( length( otherFacets ) > 1 ){
-    #                   #                      apply( as.matrix( facets[, otherFacets] ), 2,
-    #                   #                            function(ff){ as.factor(1:max(ff)) }
-    #                   #                                    )
-    #                   # Bug for equal numbers of levels within facets
-    #                   # Correction 2013-09-03
-    #                   sapply( otherFacets, FUN=function(ff){
-    #                     fff <- facets[, ff]
-    #                     as.factor(1:max(fff))
-    #                   }, simplify=FALSE )
-    #                 }
-    #   ) )
-    # TK: 2014-03-12
-    # Consider long vector response matrix and "item" in facets input
     expand.list <- vector(mode="list", length=0)
     if( "item" %in% fvars )         expand.list <- c(expand.list, if("item" %in% names(facet.list)) list(as.factor(sort(unique(facets[,"item"])))) else list(factor(1:nI)) )
     if( "step" %in% fvars )         expand.list <- c(expand.list, if("step" %in% names(facet.list)) list(as.factor(sort(unique(facets[,"step"])))) else list(factor(1:maxK)) )
@@ -142,9 +120,9 @@ rownames.design2 <- function(X){
     if( constraint=="items" ) mm <- mm[,-1]
 
     ############################################################
-    ###*** ARb 2013-03-28
     ### generate all interactions
     xsi.constr <- .generate.interactions(X, facets, formulaA, mm )
+
     ###############################################################
 # cat(" +++  v130" ) ; z1 <- Sys.time() ; print(z1-z0) ; z0 <- z1
     ### Postprocessing

diff --git a/R/summary.tam.jml.R b/R/summary.tam.jml.R
@@ -1,13 +1,12 @@
 ## File Name: summary.tam.jml.R
-## File Version: 9.22
+## File Version: 9.253
 
 
 #***** summary for tam object
 summary.tam.jml <- function( object, file=NULL, ...)
 {
-    if ( ! is.null( file ) ){
-        sink( paste0( file, "__SUMMARY.Rout"), split=TRUE )
-    }
+    #* open sink
+    tam_osink(file=file)
 
     cat("------------------------------------------------------------\n")
     cat( tam_packageinfo("TAM"), "\n" )
@@ -24,94 +23,22 @@ summary.tam.jml <- function( object, file=NULL, ...)
     tam_print_call(object$CALL)
 
     cat("------------------------------------------------------------\n")
-    cat( "Number of iterations=", object$iter, "\n\n" )
-
-    cat( "Deviance=", round( object$deviance, 2 ), " | " )
-    cat( "Log Likelihood=", round( -object$deviance/2, 2 ), "\n" )
-    cat( "Number of persons=", object$nstud, "\n" )
+    cat( "Number of iterations", "=", object$iter, "\n\n" )
+    cat( "Deviance", "=", round( object$deviance, 2 ), " | " )
+    cat( "Log Likelihood", "=", round( -object$deviance/2, 2 ), "\n" )
+    cat( "Number of persons", "=", object$nstud, "\n" )
 
     if( ! is.null( object$formulaA)  ){
-        cat( "Number of generalized items=", object$nitems, "\n" )
-        cat( "Number of items=", ncol(object$resp_orig), "\n" )
+        cat( "Number of generalized items", "=", object$nitems, "\n" )
+        cat( "Number of items", "=", ncol(object$resp_orig), "\n" )
     } else {
-        cat( "Number of items=", object$nitems, "\n" )
+        cat( "Number of items", "=", object$nitems, "\n" )
     }
 
-    #    cat( "Number of estimated parameters=", object$ic$Npars, "\n" )
-    #    cat( "    Item threshold parameters=", object$ic$Nparsxsi, "\n" )
-    #    cat( "    Item slope parameters=", object$ic$NparsB, "\n" )
-    #    cat( "    Regression parameters=", object$ic$Nparsbeta, "\n" )
-    #    cat( "    (Co)Variance parameters=", object$ic$Nparscov, "\n\n" )
-
-    #    cat( "AIC=", round( object$ic$AIC, 2 ), " | penalty=", round( object$ic$AIC - object$ic$deviance,2 ),
-    #            "   | AIC=-2*LL + 2*p  \n" )
-    #    cat( "AICc=", round( object$ic$AICc, 2 )," | penalty=", round( object$ic$AICc - object$ic$deviance,2 ) )
-    #        cat("    | AICc=-2*LL + 2*p + 2*p*(p+1)/(n-p-1)  (bias corrected AIC)\n" )
-    #    cat( "BIC=", round( object$ic$BIC, 2 ), " | penalty=", round( object$ic$BIC - object$ic$deviance,2 ),
-    #            "   | BIC=-2*LL + log(n)*p  \n" )
-    #    cat( "aBIC=", round( object$ic$aBIC, 2 ), " | penalty=", round( object$ic$aBIC - object$ic$deviance,2 ),
-    #            "   | aBIC=-2*LL + log((n-2)/24)*p  (adjusted BIC) \n" )
-    #    cat( "CAIC=", round( object$ic$CAIC, 2 )," | penalty=", round( object$ic$CAIC - object$ic$deviance,2 ) )
-    #        cat("   | CAIC=-2*LL + [log(n)+1]*p  (consistent AIC)\n\n" )
-
-    #    cat("------------------------------------------------------------\n")
-    #        cat("EAP Reliability\n")
-    #        obji <- round( object$EAP.rel, 3 )
-    #        print( obji )
-    #    cat("------------------------------------------------------------\n")
-    #        cat("Covariances and Variances\n")
-    #        if ( object$G >1){
-    #            a1 <- aggregate( object$variance, list( object$group ), mean )
-    #            object$variance <- a1[,2]
-    #                    }
-    #        obji <- round( object$variance, 3 )
-    #        if ( object$G >1){
-    #            names(obji) <- paste0("Group", seq(1,object$G) )
-    #            names(obji) <- paste0("Group", object$groups )
-    #                    }
-    #        print( obji )
-    #    cat("------------------------------------------------------------\n")
-    #        cat("Correlations and Standard Deviations (in the diagonal)\n")
-    #        if ( object$G >1){
-    #            obji <- sqrt( object$variance )
-    #                    } else {
-    #        obji <- cov2cor(object$variance)
-    #        diag(obji) <- sqrt( diag( object$variance) )
-    #                    }
-    #        if ( object$G >1){
-    #         names(obji) <- paste0("Group", seq(1,object$G) )
-    #            names(obji) <- paste0("Group", object$groups )
-    #                    }
-    #        obji <- round( obji, 3 )
-    #        print( obji )
-    #    cat("------------------------------------------------------------\n")
-    #     cat("Regression Coefficients\n")
-    #        obji <- round( object$beta, 5 )
-    #        print( obji )
-    #    cat("------------------------------------------------------------\n")
-    #        cat("Item Parameters -A*Xsi\n")
-    #        cat("   Item difficulties -A*Xsi are displayed in 'AXsi_'! \n\n")
-    #        obji <- object$item
-    #        for (vv in seq(2,ncol(obji) ) ){ obji[,vv] <- round( obji[,vv], 3) }
-    #        print(obji)
-    #    # print xsi parameters if
-    #    if( ! is.null( object$formulaA)  ){
-    #        cat("\nItem Facet Parameters Xsi\n")
-    #        cat("   Item difficulties -A*Xsi are displayed in 'AXsi_'! \n\n")
-    #        obji <- object$xsi.facets
-    #        for (vv in seq(3,ncol(obji) ) ){ obji[,vv] <- round( obji[,vv], 3) }
-    #        print(obji)
-    #                    }
-    #    if (( object$maxK > 2 ) | ( object$printxsi) ){
-    cat("\nItem Parameters Xsi\n")
+    cat("\nItem Parameters xsi\n")
     obji <- object$item
-    for (vv in seq(2,ncol(obji) ) ){
-        obji[,vv] <- round( obji[,vv], 3)
-    }
-    print(obji)
+    tam_round_data_frame_print(obji=obji, digits=3, from=2)
 
-    #******
-    if ( ! is.null( file ) ){
-        sink()
-    }
+    #** close sink
+    tam_csink(file=file)
 }
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.12
+## File Version: 0.156
 
 summary.tam.linking <- function( object, file=NULL, ...)
 {
@@ -11,14 +11,23 @@ summary.tam.linking <- function( object, file=NULL, ...)
     #- package and R session
     tam_print_package_rsession(pack="TAM")
 
-    cat( paste0("Linking of ", object$NS, " Studies") )
+    cat( paste0("Linking of ", object$NS, " Studies\n") )
     tam_print_call(object$CALL)
 
+    #- computation time
+    tam_print_computation_time(object=object)
+
     type <- object$type
+    cat("method","=", object$method, "\n")
+    cat("type","=", type, " | ")
     if (type=="Hae"){ cat("Haebara Linking Method\n")}
+    if (type=="RobHae"){
+        cat("Robust Haebara Linking Method:")
+        cat(" pow_rob_hae","=", object$pow_rob_hae, "\n")
+    }
     if (type=="SL"){ cat("Stocking Lord Linking Method\n")}
 
-    cat("------------------------------------------------------------\n")
+    cat("\n------------------------------------------------------------\n")
     cat( "Number of Linking Items\n" )
     obji <- object$N_common
     print(obji)