add pbapply where it is informative

DESCRIPTION

@@ -43,6 +43,7 @@ Imports:
     vegan,
     Deriv,
     splines,
+    pbapply (>= 1.3-0),
     dcurver
 Suggests:
     boot,

NAMESPACE

@@ -83,6 +83,7 @@ import(dcurver)
 import(lattice)
 import(methods)
 import(mgcv)
+import(pbapply)
 import(splines)
 import(stats)
 import(stats4)

NEWS.md

@@ -1,5 +1,9 @@
 # Changes in mirt 1.36
 
+- Progress bar added automatically (controlled via the `verbose` argument) 
+  when using several of the package's secondary functions (e.g., `fscores()`, 
+  `DIF()`, `'DRF()`, `mdirt()`, etc)
+
 - Added `itemstats()` function to give basic item information statistics
 
 - Item-EFA models now automatically flips negative signs in rotate solutions

R/DIF.R

@@ -268,7 +268,8 @@ DIF <- function(MGmodel, which.par, scheme = 'add', items2test = 1:extract.mirt(
     invariance <- MGmodel@Model$invariance[MGmodel@Model$invariance %in%
                                          c('free_means', 'free_var')]
     if(!length(invariance)) invariance <- ''
-    res <- myLapply(X=items2test, FUN=loop_test, model=MGmodel, which.par=which.par, values=values,
+    res <- myLapply(X=items2test, FUN=loop_test, progress=verbose,
+                    model=MGmodel, which.par=which.par, values=values,
                     Wald=Wald, drop=drop, itemnames=itemnames, invariance=invariance,
                     return_models=return_models, ...)
     names(res) <- itemnames[items2test]
@@ -339,7 +340,7 @@ DIF <- function(MGmodel, which.par, scheme = 'add', items2test = 1:extract.mirt(
                                           verbose = FALSE, ...)
             pick <- !keep
             if(drop) pick <- !pick
-            tmp <- myLapply(X=items2test[pick], FUN=loop_test, model=updatedModel,
+            tmp <- myLapply(X=items2test[pick], FUN=loop_test, progress=verbose, model=updatedModel,
                             which.par=which.par, values=values, Wald=Wald, drop=drop,
                             itemnames=itemnames, invariance=invariance, return_models=FALSE, ...)
             names(tmp) <- itemnames[items2test][pick]
@@ -354,7 +355,7 @@ DIF <- function(MGmodel, which.par, scheme = 'add', items2test = 1:extract.mirt(
         pick <- !lastkeep
         if(return_seq_model) return(updatedModel)
         if(!(scheme %in% c('add', 'drop'))){ # will equal 'add/drop' if all items on first loop have DIF
-            res <- myLapply(X=items2test[pick], FUN=loop_test, model=updatedModel,
+            res <- myLapply(X=items2test[pick], FUN=loop_test, progress=verbose, model=updatedModel,
                             which.par=which.par, values=values, Wald=Wald, drop=FALSE,
                             itemnames=itemnames, invariance=invariance, return_models=return_models,
                             ...)

R/DRF.R

@@ -52,6 +52,7 @@
 #' @param par.strip.text plotting argument passed to \code{\link{lattice}}
 #' @param par.settings plotting argument passed to \code{\link{lattice}}
 #' @param ... additional arguments to be passed to \code{lattice}
+#' @param verbose logical; include additional information in the console?
 #'
 #' @author Phil Chalmers \email{rphilip.chalmers@@gmail.com}
 #' @references
@@ -255,14 +256,15 @@
 # DRF(simmod, draws = 500)
 #
 #' }
-DRF <- function(mod, draws = NULL, focal_items = 1L:extract.mirt(mod, 'nitems'), param_set = NULL,
-                den.type = 'both', CI = .95, npts = 1000,
+DRF <- function(mod, draws = NULL, focal_items = 1L:extract.mirt(mod, 'nitems'),
+                param_set = NULL, den.type = 'both', CI = .95, npts = 1000,
                 quadpts = NULL, theta_lim=c(-6,6), Theta_nodes = NULL,
                 plot = FALSE, DIF = FALSE, p.adjust = 'none',
                 par.strip.text = list(cex = 0.7),
                 par.settings = list(strip.background = list(col = '#9ECAE1'),
                                  strip.border = list(col = "black")),
-                auto.key = list(space = 'right', points=FALSE, lines=TRUE), ...){
+                auto.key = list(space = 'right', points=FALSE, lines=TRUE),
+                verbose = TRUE, ...){
 
     compute_ps <- function(x, xs, X2=FALSE){
         if(X2){
@@ -405,7 +407,8 @@ DRF <- function(mod, draws = NULL, focal_items = 1L:extract.mirt(mod, 'nitems'),
         on.exit({.mirtClusterEnv$rslist <- .mirtClusterEnv$param_set <- NULL
             reloadPars(longpars=longpars, pars=pars, ngroups=2L, J=length(pars[[1L]])-1L)
         })
-        list_scores <- myLapply(1L:nrow(param_set), fn2, pars=pars, MGmod=mod, param_set=param_set,
+        list_scores <- myLapply(1L:nrow(param_set), fn2, progress=verbose,
+                                pars=pars, MGmod=mod, param_set=param_set,
                                 max_score=max_score, Theta=Theta, rslist=rslist,
                                 Theta_nodes=Theta_nodes, plot=plot, details=details,
                                 DIF=DIF, focal_items=focal_items, signs=signs, den.type=den.type)
@@ -600,7 +603,8 @@ draw_parameters <- function(mod, draws, method = c('parametric', 'boostrap'),
         names <- colnames(covB)
         imputenums <- sapply(strsplit(names, '\\.'), function(x) as.integer(x[2L]))
         pre.ev <- eigen(covB)
-        ret <- myLapply(1L:draws, fn_param, shortpars=shortpars, longpars=longpars, lbound=lbound,
+        ret <- myLapply(1L:draws, fn_param, progress=verbose,
+                        shortpars=shortpars, longpars=longpars, lbound=lbound,
                         ubound=ubound, pre.ev=pre.ev, constrain=constrain, est=est,
                         imputenums=imputenums, MGmod=mod, redraws=redraws, pars=pars)
         ret <- do.call(rbind, ret)

R/PLCI.mirt.R

@@ -22,6 +22,7 @@
 #' @param lower logical; search for the lower CI?
 #' @param upper logical; search for the upper CI?
 #' @param NealeMiller logical; use the Neale and Miller 1997 approximation? Default is \code{FALSE}
+#' @param verbose logical; include additional information in the console?
 #' @param ... additional arguments to pass to the estimation functions
 #'
 #' @author Phil Chalmers \email{rphilip.chalmers@@gmail.com}
@@ -73,7 +74,7 @@
 PLCI.mirt <- function(mod, parnum = NULL, alpha = .05,
                       search_bound = TRUE, step = .5,
                       lower = TRUE, upper = TRUE, inf2val = 30,
-                      NealeMiller = FALSE, ...){
+                      NealeMiller = FALSE, verbose = TRUE, ...){
 
     #silently accepts print_debug = TRUE for printing the minimization criteria
 
@@ -285,7 +286,8 @@ PLCI.mirt <- function(mod, parnum = NULL, alpha = .05,
     if(lower && upper)
         parnums <- rep(parnums, each = 2)
     X <- 1L:length(parnums)
-    result <- mySapply(X=X, FUN=LLpar, parnums=parnums, asigns=asigns,
+    result <- mySapply(X=X, FUN=LLpar, progress=verbose,
+                       parnums=parnums, asigns=asigns,
                        dat=dat, constrain=constraints, itemtype=itemtype,
                        model=model, large=large, sv=sv, get.LL=get.LL, parprior=parprior,
                        PrepList=PrepList, inf2val=inf2val, maxLL=LL,

R/boot.LR.R

@@ -10,6 +10,7 @@
 #' @param mod an estimated model object
 #' @param mod2 an estimated model object
 #' @param R number of parametric bootstraps to use.
+#' @param verbose logical; include additional information in the console?
 #'
 #' @author Phil Chalmers \email{rphilip.chalmers@@gmail.com}
 #' @return a p-value evaluating whether the more restrictive model fits significantly worse
@@ -37,7 +38,7 @@
 #' boot.LR(mod1, mod2, R=200)
 #'
 #' }
-boot.LR <- function(mod, mod2, R = 1000){
+boot.LR <- function(mod, mod2, R = 1000, verbose=TRUE){
     stopifnot(is(mod, 'SingleGroupClass'))
     df1 <- extract.mirt(mod, 'df')
     df2 <- extract.mirt(mod2, 'df')
@@ -63,7 +64,7 @@ boot.LR <- function(mod, mod2, R = 1000){
             break
         }
         lr0
-    }, mod=mod, mod2=mod2)
+    }, progress=verbose, mod=mod, mod2=mod2)
     p <- (1 + sum(LR < results, na.rm = TRUE)) / (1 + R)
     p
 }

R/fscores.internal.R

@@ -289,16 +289,16 @@ setMethod(
                 log_itemtrace <- log(itemtrace)
                 if(mixture) ThetaShort <- thetaStack(ThetaShort, length(pis))
                 if(method == 'classify')
-                    tmp <- myApply(X=matrix(seq_len(nrow(scores))), MARGIN=1L,
+                    tmp <- myApply(X=matrix(seq_len(nrow(scores))), MARGIN=1L, progress=verbose,
                                    FUN=EAP_classify, log_itemtrace=log_itemtrace,
                                    tabdata=tabdata, W=W, nclass=length(pis))
                 else if(method == 'EAP' && return.acov){
-                    tmp <- myApply(X=matrix(seq_len(nrow(scores))), MARGIN=1L, FUN=EAP,
+                    tmp <- myApply(X=matrix(seq_len(nrow(scores))), MARGIN=1L, FUN=EAP, progress=verbose,
                                    log_itemtrace=log_itemtrace,
                                    tabdata=tabdata, ThetaShort=ThetaShort, W=W, return.acov=TRUE,
                                    scores=scores, hessian=TRUE)
                 } else {
-            	    tmp <- myApply(X=matrix(seq_len(nrow(scores))), MARGIN=1L, FUN=EAP,
+            	    tmp <- myApply(X=matrix(seq_len(nrow(scores))), MARGIN=1L, FUN=EAP, progress=FALSE,
             	                   log_itemtrace=log_itemtrace,
                                    tabdata=tabdata, ThetaShort=ThetaShort, W=W, scores=scores,
                                    hessian=estHess && method == 'EAP', return_zeros=method != 'EAP')
@@ -316,7 +316,8 @@ setMethod(
     		if(method %in% c("EAP", 'classify')){
                 #do nothing
     		} else if(method == "MAP"){
-                tmp <- myApply(X=matrix(seq_len(nrow(scores))), MARGIN=1L, FUN=MAP, scores=scores, pars=pars,
+                tmp <- myApply(X=matrix(seq_len(nrow(scores))), MARGIN=1L, FUN=MAP, progress=verbose,
+                               scores=scores, pars=pars,
                                tabdata=tabdata, itemloc=itemloc, gp=gp, prodlist=prodlist, den_fun=den_fun,
                                CUSTOM.IND=CUSTOM.IND, return.acov=return.acov, hessian=estHess,
                                ...)
@@ -329,7 +330,8 @@ setMethod(
                 SEscores[allmcat,] <- NA
                 scores[allzero,] <- -Inf
                 SEscores[allzero,] <- NA
-                tmp <- myApply(X=matrix(seq_len(nrow(scores))), MARGIN=1L, FUN=ML, scores=scores, pars=pars,
+                tmp <- myApply(X=matrix(seq_len(nrow(scores))), MARGIN=1L, FUN=ML, progress=verbose,
+                               scores=scores, pars=pars,
                                tabdata=tabdata, itemloc=itemloc, gp=gp, prodlist=prodlist, den_fun=NULL,
                                CUSTOM.IND=CUSTOM.IND, return.acov=return.acov, hessian=estHess,
                                ...)
@@ -338,7 +340,8 @@ setMethod(
     		    cls <- sapply(object@ParObjects$pars, class)
     		    for(i in seq_len(length(cls)-1L))
     		        DERIV[[i]] <- selectMethod(DerivTheta, c(cls[i], 'matrix'))
-                tmp <- myApply(X=matrix(seq_len(nrow(scores))), MARGIN=1L, FUN=WLE, scores=scores, pars=pars,
+                tmp <- myApply(X=matrix(seq_len(nrow(scores))), MARGIN=1L, FUN=WLE, progress=verbose,
+                               scores=scores, pars=pars,
                                tabdata=tabdata, itemloc=itemloc, gp=gp, prodlist=prodlist, DERIV=DERIV,
                                CUSTOM.IND=CUSTOM.IND, hessian=estHess, data=object@Data$tabdata, ...)
             } else {

R/itemfit.R

@@ -326,7 +326,8 @@ itemfit <- function(x, fit_stats = 'S_X2', which.items = 1:extract.mirt(x, 'nite
         stopifnot(nrow(org) == length(which.items))
         model <- extract.mirt(mod, 'model')
         sv <- mod2values(mod)
-        retQ1 <- mySapply(1L:boot, pb_fun, mod=mod, N=N, sv=sv, itemtype=itemtype,
+        retQ1 <- mySapply(1L:boot, pb_fun, progress=verbose,
+                          mod=mod, N=N, sv=sv, itemtype=itemtype,
                           which.items=which.items, draws=draws, model=model,
                           p.adjust=p.adjust, ...)
         if(nrow(retQ1) == 1L) retQ1 <- t(retQ1)
@@ -388,7 +389,8 @@ itemfit <- function(x, fit_stats = 'S_X2', which.items = 1:extract.mirt(x, 'nite
         stopifnot(length(org) == length(which.items))
         sv <- mod2values(mod)
         model <- extract.mirt(mod, 'model')
-        X2bs <- mySapply(1L:boot, pb_fun, mod=mod, N=N, model=model, is_NA=is_NA,
+        X2bs <- mySapply(1L:boot, pb_fun, progress=verbose,
+                         mod=mod, N=N, model=model, is_NA=is_NA,
                          itemtype=itemtype, sv=sv, which.items=which.items,
                          ETrange=ETrange, ETpoints=ETpoints, ...)
         if(nrow(X2bs) == 1L) X2bs <- t(X2bs)

R/mdirt.R

@@ -336,8 +336,8 @@ mdirt <- function(data, model, customTheta = NULL, structure = NULL, item.Q = NU
     if((is(model, 'mirt.model') || is.character(model)) && is.null(technical$customTheta))
         stop('customTheta input required when using a mirt.model type input')
     technical$omp <- FALSE
-    mods <- myLapply(1:nruns, function(x, ...) return(ESTIMATION(...)), method=method,
-                     latent.regression=latent.regression, structure=structure,
+    mods <- myLapply(1:nruns, function(x, ...) return(ESTIMATION(...)), progress=verbose,
+                     method=method, latent.regression=latent.regression, structure=structure,
                      data=data, model=model, group=group, itemtype=itemtype, optimizer=optimizer,
                      technical=technical, calcNull=FALSE, GenRandomPars=GenRandomPars, item.Q=item.Q,
                      dentype = 'discrete', verbose=ifelse(nruns > 1L, FALSE, verbose), pars=pars, ...)

R/mirt-package.R

@@ -26,7 +26,7 @@
 #' @title Full information maximum likelihood estimation of IRT models.
 #' @author Phil Chalmers \email{rphilip.chalmers@@gmail.com}
 #' @useDynLib mirt
-#' @import stats lattice GPArotation Rcpp stats4 methods mgcv splines vegan dcurver
+#' @import stats lattice GPArotation Rcpp stats4 methods mgcv splines vegan dcurver pbapply
 #' @importFrom utils write.table flush.console packageVersion capture.output head
 #' @importFrom gridExtra grid.arrange
 #' @importFrom graphics symbols

R/utils.R

@@ -2617,23 +2617,32 @@ missingMsg <- function(string)
 .mirtClusterEnv$ncores <- 1L
 .mirtClusterEnv$omp_threads <- 1L
 
-myApply <- function(X, MARGIN, FUN, ...){
+myApply <- function(X, MARGIN, FUN, progress = FALSE, ...){
+    if(progress)
+        return(t(pbapply::pbapply(X, MARGIN, FUN, ...,
+                         cl=.mirtClusterEnv$MIRTCLUSTER)))
     if(.mirtClusterEnv$ncores > 1L){
         return(t(parallel::parApply(cl=.mirtClusterEnv$MIRTCLUSTER, X=X, MARGIN=MARGIN, FUN=FUN, ...)))
     } else {
         return(t(apply(X=X, MARGIN=MARGIN, FUN=FUN, ...)))
     }
 }
 
-myLapply <- function(X, FUN, ...){
+myLapply <- function(X, FUN, progress = FALSE, ...){
+    if(progress)
+        return(t(pbapply::pblapply(X, FUN, ...,
+                                  cl=.mirtClusterEnv$MIRTCLUSTER)))
     if(.mirtClusterEnv$ncores > 1L){
         return(parallel::parLapply(cl=.mirtClusterEnv$MIRTCLUSTER, X=X, fun=FUN, ...))
     } else {
         return(lapply(X=X, FUN=FUN, ...))
     }
 }
 
-mySapply <- function(X, FUN, ...){
+mySapply <- function(X, FUN, progress = FALSE, ...){
+    if(progress)
+        return(t(pbapply::pbsapply(X, FUN, ...,
+                                   cl=.mirtClusterEnv$MIRTCLUSTER)))
     if(.mirtClusterEnv$ncores > 1L){
         return(t(parallel::parSapply(cl=.mirtClusterEnv$MIRTCLUSTER, X=X, FUN=FUN, ...)))
     } else {