3.10-12

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: sirt
 Type: Package
 Title: Supplementary Item Response Theory Models
-Version: 3.10-10
-Date: 2020-03-02 17:37:57
+Version: 3.10-12
+Date: 2020-03-04 17:18:01
 Author: Alexander Robitzsch [aut,cre] (<https://orcid.org/0000-0002-8226-3132>)
 Maintainer: Alexander Robitzsch <[email protected]>
 Description: 

R/RcppExports.R

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

R/lsem.bootstrap.R

@@ -1,8 +1,8 @@
 ## File Name: lsem.bootstrap.R
-## File Version: 0.300
+## File Version: 0.304
 
 
-lsem.bootstrap <- function(object, R=100, verbose=TRUE)
+lsem.bootstrap <- function(object, R=100, verbose=TRUE, cluster=NULL)
 {
     lsem_args <- object$lsem_args
     lsem_args$se <- "none"
@@ -27,16 +27,21 @@ lsem.bootstrap <- function(object, R=100, verbose=TRUE)
 
     #-- loop over bootstrap samples
     lsem_bootstrap_print_start(verbose=verbose)
-    for (rr in 1:R){
+    rr <- 1
+    while (rr<=R){
         lsem_bootstrap_print_progress(rr=rr, verbose=verbose, R=R)
         #- draw bootstrap sample
         lsem_args1 <- lsem_bootstrap_draw_bootstrap_sample(data=data,
-                            sampling_weights=sampling_weights, lsem_args=lsem_args)
+                            sampling_weights=sampling_weights, lsem_args=lsem_args,
+                            cluster=cluster)
         #- fit model
-        mod1 <- do.call(what=lsem.estimate, args=lsem_args1)
+        mod1 <- try( do.call(what=lsem.estimate, args=lsem_args1), silent=TRUE)
         #- output collection
-        parameters_boot[,rr] <- mod1$parameters$est
-        fitstats_joint_boot[,rr] <- mod1$fitstats_joint$value
+        if ( class(mod1) !="try-error" ){
+            parameters_boot[,rr] <- mod1$parameters$est
+            fitstats_joint_boot[,rr] <- mod1$fitstats_joint$value
+            rr <- rr + 1
+        }
     }
 
     #- modify output objects

R/lsem.permutationTest.R

@@ -1,8 +1,8 @@
 ## File Name: lsem.permutationTest.R
-## File Version: 0.44
+## File Version: 0.451
 
-############################################
-# permutation test for LSEM model
+
+#*** permutation test for LSEM model
 lsem.permutationTest <- function( lsem.object, B=1000, residualize=TRUE,
             verbose=TRUE )
 {

R/lsem_bootstrap_draw_bootstrap_sample.R

@@ -1,12 +1,24 @@
 ## File Name: lsem_bootstrap_draw_bootstrap_sample.R
-## File Version: 0.02
+## File Version: 0.052
 
 lsem_bootstrap_draw_bootstrap_sample <- function(data, sampling_weights,
-    lsem_args)
+    lsem_args, cluster=NULL)
 {
     lsem_args1 <- lsem_args
     N <- nrow(data)
-    ind <- sample(1:N, N, replace=TRUE)
+    if (is.null(cluster)){
+        ind <- sample(1:N, N, replace=TRUE)
+    } else {
+        cluster1 <- data[,cluster]
+        t1 <- unique(cluster1)
+        N <- length(t1)
+        ind0 <- sort(sample(t1, size=N, replace=TRUE))
+        ind <- NULL
+        for (nn in 1L:N){
+            v1 <- which(cluster1==ind0[nn])
+            ind <- c(ind, v1)
+        }
+    }
     lsem_args1$data <- data[ind,]
     lsem_args1$sampling_weights <- sampling_weights[ind]
     return(lsem_args1)

R/penalty_D1_abs.R

@@ -1,5 +1,5 @@
 ## File Name: penalty_D1_abs.R
-## File Version: 0.01
+## File Version: 0.02
 
 
 penalty_D1_abs <- function(x, lambda, eps)

R/penalty_D1_mcp.R

@@ -1,5 +1,5 @@
 ## File Name: penalty_D1_mcp.R
-## File Version: 0.02
+## File Version: 0.03
 
 
 penalty_D1_mcp <- function(x, lambda, eps, a=2.7)

R/penalty_D1_scad.R

@@ -1,13 +1,13 @@
 ## File Name: penalty_D1_scad.R
-## File Version: 0.03
+## File Version: 0.04
 
 
 penalty_D1_scad <- function(x, lambda, eps, a=3.7)
 {
     x <- abs(x)
     res <- ifelse( x < lambda, lambda * sqrt( x^2 + eps ), 0)
     res <- res + ifelse( ( x >=lambda ) & ( x < a*lambda),
-                            - ( x^2 - 2*a*lambda*sqrt(x^2+eps)+lambda^2) / ( 2*(a-1)),0 )
+                        - ( x^2 - 2*a*lambda*sqrt(x^2+eps)+lambda^2) / ( 2*(a-1)),0 )
     res <- res + ifelse (x>=a*lambda, (a+1)*lambda^2 / 2, 0 )
     return(res)
 }

R/regpolca.R

@@ -1,5 +1,5 @@
 ## File Name: regpolca.R
-## File Version: 0.115
+## File Version: 0.116
 
 
 #- Regularized polytomous latent class analysis
@@ -12,7 +12,7 @@ regpolca <- function(dat, nclasses, weights=NULL, group=NULL,
     #*** preliminaries
     CALL <- match.call()
     s1 <- Sys.time()
-    
+
     #** analyze response patterns
     res <- regpolca_proc_data(dat=dat, group=group)
     ncats <- res$ncats
@@ -23,29 +23,29 @@ regpolca <- function(dat, nclasses, weights=NULL, group=NULL,
     groups <- res$groups
     G <- res$G
     Ni <- res$Ni
-    
+
     #- define theta class distribution
     K <- nclasses
     par_Theta <- xxirt_classprobs_lca_init_par(K=K, G=G, random_sd=0)
     customTheta  <- xxirt_createThetaDistribution( par=par_Theta,
                             est=rep(TRUE,G*(K-1)), P=xxirt_classprobs_lca)
     Theta <- diag(K)
-    
-    #- define item response functions    
-    res <- regpolca_define_customItems( ncats=ncats, K=K, dat=dat, 
-                    par_item_max=par_item_max ) 
+
+    #- define item response functions
+    res <- regpolca_define_customItems( ncats=ncats, K=K, dat=dat,
+                    par_item_max=par_item_max )
     customItems <- res$customItems
     partable <- res$partable
-    itemtype <- res$itemtype                    
+    itemtype <- res$itemtype
 
     #-- include penalty function
     penalty_fun_item <- NULL
     if (regular_lam>0){
         combis <- t( utils::combn(K,2) )
         if (regular_type=="scad"){ penalty_used <- penalty_D1_scad }
         if (regular_type=="mcp"){ penalty_used <- penalty_D1_mcp }
-        if (regular_type=="lasso"){ penalty_used <- penalty_D1_lasso }                
-        penalty_fun_item <- function(x, ...){            
+        if (regular_type=="lasso"){ penalty_used <- penalty_D1_lasso }
+        penalty_fun_item <- function(x, ...){
             pen <- 0
             #* fused probabilities among classes
             for (ii in 1:I){
@@ -55,47 +55,47 @@ regpolca <- function(dat, nclasses, weights=NULL, group=NULL,
                 pen <- pen + Ni[ii]*sum(a1)
             }
             return(pen)
-        }    
+        }
     }
 
     #-- create argument list for xxirt
     args <- list( dat=dat, Theta=Theta, partable=partable, customItems=customItems,
                 customTheta=customTheta, maxit=random_iter, mstep_iter=mstep_iter,
-                penalty_fun_item=penalty_fun_item, h=h, use_grad=TRUE, verbose=2 )    
+                penalty_fun_item=penalty_fun_item, h=h, use_grad=TRUE, verbose=2 )
+
+    #-- random starts if required
+    args <- regpolca_run_xxirt_random_starts( args=args, random_starts=random_starts,
+                    sd_noise_init=sd_noise_init )
 
-    #-- random starts if required                
-    args <- regpolca_run_xxirt_random_starts( args=args, random_starts=random_starts, 
-                    sd_noise_init=sd_noise_init )     
-
     #-- arguments for final xxirt model
     args$verbose <- TRUE
     args$maxit <- maxit
 
     #-- run xxirt in a final model
-    res <- do.call(what=xxirt, args=args)    
-    res$iter <- res$iter + random_iter*(random_starts>0)    
-    
+    res <- do.call(what=xxirt, args=args)
+    res$iter <- res$iter + random_iter*(random_starts>0)
+
     #- process output
     res$probs_Theta <- regpolca_postproc_prob_Theta(probs_Theta=res$probs_Theta)
-    item <- regpolca_postproc_irf(probs_items=res$probs_items, dat=dat, 
+    item <- regpolca_postproc_irf(probs_items=res$probs_items, dat=dat,
                     lca_dich=lca_dich)
-    res0 <- regpolca_postproc_count_regularized_parameters(item=item, 
+    res0 <- regpolca_postproc_count_regularized_parameters(item=item,
                     set_equal=set_equal, lca_dich=lca_dich, probs_items=res$probs_items)
-    item1_index <- res0$item1_index    
-    n_reg <- res0$n_reg    
+    item1_index <- res0$item1_index
+    n_reg <- res0$n_reg
     item <- res0$item
     res$probs_items <- res0$probs_items
-    
+
     #- adapt information criteria
-    res$ic <- regpolca_postproc_ic(ic=res$ic, n_reg=n_reg)    
-    
+    res$ic <- regpolca_postproc_ic(ic=res$ic, n_reg=n_reg)
+
     #-- arrange output
     res$CALL <- CALL
     res2 <- list(s1=s1, s2=Sys.time(), lca_dich=lca_dich, nclasses=nclasses,
                     item=item, regular_lam=regular_lam, regular_type=regular_type,
                     item1_index=item1_index, n_reg=n_reg)
     res <- sirt_add_list_elements(res=res, res2=res2)
-        
+
     class(res) <- "regpolca"
-    return(res)    
+    return(res)
 }

R/regpolca_postproc_ic.R

@@ -1,11 +1,11 @@
 ## File Name: regpolca_postproc_ic.R
-## File Version: 0.04
+## File Version: 0.05
 
 
 regpolca_postproc_ic <- function(ic, n_reg)
 {
     ic$n_reg <- n_reg
     ic$np.items <- ic$np.items - ic$n_reg
-    ic <- xxirt_ic_compute_criteria(ic=ic)    
+    ic <- xxirt_ic_compute_criteria(ic=ic)
     return(ic)
 }

README.md

@@ -22,9 +22,9 @@ The CRAN version can be installed from within R using:
 utils::install.packages("sirt")
 ```
 
-#### GitHub version `sirt` 3.10-10 (2020-03-02)
+#### GitHub version `sirt` 3.10-12 (2020-03-04)
 
-[![](https://img.shields.io/badge/github%20version-3.10--10-orange.svg)](https://github.com/alexanderrobitzsch/sirt)  
+[![](https://img.shields.io/badge/github%20version-3.10--12-orange.svg)](https://github.com/alexanderrobitzsch/sirt)  
 
 The version hosted [here](https://github.com/alexanderrobitzsch/sirt) is the development version of `sirt`. 
 The GitHub version can be installed using `devtools` as: