4.2-13

alexanderrobitzsch · Mar 1, 2024 · 097cd32 · 097cd32
1 parent e36a297
commit 097cd32
Show file tree

Hide file tree

Showing 31 changed files with 409 additions and 209 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,8 +1,8 @@
 Package: sirt
 Type: Package
 Title: Supplementary Item Response Theory Models
-Version: 4.2-2
-Date: 2024-02-15 17:09:03
+Version: 4.2-13
+Date: 2024-03-01 15:48:53
 Author: Alexander Robitzsch [aut,cre] (<https://orcid.org/0000-0002-8226-3132>)
 Maintainer: Alexander Robitzsch <[email protected]>
 Description: 

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

diff --git a/R/lsem.MGM.stepfunctions.R b/R/lsem.MGM.stepfunctions.R
@@ -1,5 +1,5 @@
 ## File Name: lsem.MGM.stepfunctions.R
-## File Version: 0.131
+## File Version: 0.132
 
 #**** define object with LSEM step functions
 lsem.MGM.stepfunctions <- function( object, moderator.grid )
@@ -12,7 +12,7 @@ lsem.MGM.stepfunctions <- function( object, moderator.grid )
     dfr <- NULL
     G <- length(moderator.grid)
 
-    for (gg in 1:G){
+    for (gg in 1L:G){
         mod.gg <- moderator.grid[gg]
         ind.gg <- which( ( moderator.grouped$min <=mod.gg ) &
                             ( moderator.grouped$max > mod.gg ) )

diff --git a/R/lsem.bootstrap.R b/R/lsem.bootstrap.R
@@ -1,5 +1,5 @@
 ## File Name: lsem.bootstrap.R
-## File Version: 0.431
+## File Version: 0.432
 
 
 lsem.bootstrap <- function(object, R=100, verbose=TRUE, cluster=NULL,
@@ -135,7 +135,7 @@ lsem.bootstrap <- function(object, R=100, verbose=TRUE, cluster=NULL,
                         verbose=verbose, arglist=arglist)
         parallel::stopCluster(cl)
 
-        for (rr in 1:R){
+        for (rr in 1L:R){
             res_out_rr <- res_all[[rr]]
             parameters_boot[,rr] <- res_out_rr$parameters_boot
             fitstats_joint_boot[,rr] <- res_out_rr$fitstats_joint_boot

diff --git a/R/lsem.estimate.R b/R/lsem.estimate.R
@@ -1,5 +1,5 @@
 ## File Name: lsem.estimate.R
-## File Version: 1.074
+## File Version: 1.108
 
 # estimate LSEM model
 lsem.estimate <- function( data, moderator, moderator.grid,
@@ -23,10 +23,19 @@ lsem.estimate <- function( data, moderator, moderator.grid,
     }
     use_lavaan_survey <- FALSE
 
+    #- check if list of imputed datasets is available
+    is_imputed <- ! ( is.list(data) & is.data.frame(data) )
+
     #- data cleaning
-    data <- as.data.frame(data)
-    data <- data[ ! is.na(data[,moderator]), ]
-    moderator_variable <- data[,moderator]
+    if (!is_imputed){
+        data <- as.data.frame(data)
+        data <- data[ ! is.na(data[,moderator]), ]
+        moderator_variable <- data[,moderator]
+        Nimp <- 0
+    } else {
+        moderator_variable <- NULL
+        Nimp <- length(data)
+    }
 
     #- process arguments
     res <- lsem_estimate_proc_args( lavaan.args=lavaan.args,
@@ -35,7 +44,8 @@ lsem.estimate <- function( data, moderator, moderator.grid,
                 use_lavaan_survey=use_lavaan_survey, est_joint=est_joint,
                 par_invariant=par_invariant, par_linear=par_linear,
                 par_quadratic=par_quadratic, partable_joint=partable_joint,
-                moderator.grid=moderator.grid, se=se, verbose=verbose )
+                moderator.grid=moderator.grid, se=se, verbose=verbose,
+                is_imputed=is_imputed)
     sufficient_statistics <- res$sufficient_statistics
     use_lavaan_survey <- res$use_lavaan_survey
     variables_model <- res$variables_model
@@ -51,7 +61,8 @@ lsem.estimate <- function( data, moderator, moderator.grid,
 
     # group moderator if type='MGM'
     out <- lsem_group_moderator( data=data, type=type, moderator.grid=moderator.grid,
-                moderator=moderator, residualize=residualize, h=h )
+                moderator=moderator, residualize=residualize, h=h,
+                is_imputed=is_imputed, Nimp=Nimp )
     data <- out$data
     moderator.grouped <- out$moderator.grouped
     h <- out$h
@@ -63,7 +74,8 @@ lsem.estimate <- function( data, moderator, moderator.grid,
                     moderator.grid=moderator.grid, lavmodel=lavmodel, h=h, bw=bw,
                     residualize=residualize, eps=eps, verbose=verbose,
                     sampling_weights=sampling_weights, kernel=kernel,
-                    variables_model=variables_model)
+                    variables_model=variables_model, is_imputed=is_imputed,
+                    Nimp=Nimp)
     G <- out$G
     data <- out$data
     weights <- out$weights
@@ -91,7 +103,8 @@ lsem.estimate <- function( data, moderator, moderator.grid,
                     variables_model=variables_model, sampling_weights=sampling_weights,
                     has_meanstructure=has_meanstructure,
                     sufficient_statistics=sufficient_statistics, est_joint=est_joint,
-                    se=se, use_lavaan_survey=use_lavaan_survey, ... )
+                    se=se, use_lavaan_survey=use_lavaan_survey,
+                    is_imputed=is_imputed, Nimp=Nimp, ... )
     nobs <- unlist(lavfit@Data@nobs)
 
     # extract variables which are in model and data frame
@@ -127,7 +140,8 @@ lsem.estimate <- function( data, moderator, moderator.grid,
                     loc_linear_smooth=loc_linear_smooth, pd=pd,
                     residualized_intercepts=residualized_intercepts,
                     has_meanstructure=has_meanstructure, est_DIF=est_DIF,
-                    residualize=residualize, ... )
+                    residualize=residualize, is_imputed=is_imputed,
+                    Nimp=Nimp, moderator=moderator, ... )
     dif_effects <- out2$dif_effects
     parameters <- out2$parameters
     is_meanstructure <- out2$is_meanstructure
@@ -139,19 +153,26 @@ lsem.estimate <- function( data, moderator, moderator.grid,
     parameters_summary <- lsem_parameter_summary( parameters=parameters,
                                 moderator.density=out$moderator.density,
                                 verbose=verbose )
-    out$moderator.density$Neff <- colSums(weights)
-
+    weights0 <- weights
+    if (is_imputed){
+        weights0 <- lsem_aggregate_statistics(x=weights)
+    }
+    out$moderator.density$Neff <- colSums(weights0)
     obji0 <- obji <- out$moderator.density
     obji$moderator <- obji$moderator
     obji$wgt <- obji$wgt
     obji$Neff <- obji$Neff
     Y <- obji0[,-1]
     dfr <- data.frame( M=colMeans(Y), SD=apply( Y, 2, stats::sd ),
                             min=apply( Y, 2, min ), max=apply( Y, 2, max ) )
-    x <- data[,moderator]
-    dfr0 <- data.frame(M=mean( x, na.rm=TRUE ), SD=out$sd.moderator,
-                        min=min( x, na.rm=TRUE ), max=max( x, na.rm=TRUE ) )
-    obji <- rbind( dfr0, dfr )
+    if (is_imputed){
+        x <- (data[[1]])[, moderator]
+    } else {
+        x <- data[,moderator]
+    }
+    dfr0 <- data.frame(M=mean(x, na.rm=TRUE ), SD=out$sd.moderator,
+                        min=min(x, na.rm=TRUE ), max=max(x, na.rm=TRUE ) )
+    obji <- rbind( dfr0, dfr)
     rownames(obji) <- NULL
     moderator.stat <- data.frame(variable=c('moderator','wgt', 'Neff'), obji )
 
@@ -188,7 +209,7 @@ lsem.estimate <- function( data, moderator, moderator.grid,
                     partable_joint=partable_joint,
                     dif_effects=dif_effects, sample_stats=sample_stats,
                     loc_linear_smooth=loc_linear_smooth,
-                    se=se, compute_se=compute_se,
+                    se=se, compute_se=compute_se, is_imputed=is_imputed, Nimp=Nimp,
                     class_boot=FALSE, type=type, CALL=CALL )
     class(res) <- 'lsem'
     return(res)

diff --git a/R/lsem.permutationTest.R b/R/lsem.permutationTest.R
@@ -1,5 +1,5 @@
 ## File Name: lsem.permutationTest.R
-## File Version: 0.592
+## File Version: 0.593
 
 
 #*** permutation test for LSEM model
@@ -18,13 +18,13 @@ lsem.permutationTest <- function( lsem.object, B=1000, residualize=TRUE,
     object <- lsem.object
     arglist <- list()
     EE <- length(entr)
-    for (ee in 1:EE){
+    for (ee in 1L:EE){
         arglist[[ entr[ee] ]] <- object[[ entr[ee] ]]
     }
     arglist2 <- lsem.object$lavaan.args
     NL <- length(arglist2)
     if (NL > 0){
-        for (ll in 1:NL){
+        for (ll in 1L:NL){
             arglist[[ names(arglist2)[ll] ]] <- arglist2[[ names(arglist2)[ll] ]]
         }
     }
@@ -140,7 +140,7 @@ lsem.permutationTest <- function( lsem.object, B=1000, residualize=TRUE,
 
         parallel::stopCluster(cl)
 
-        for (bb in 1:B){
+        for (bb in 1L:B){
             parameters_permutation[, bb] <- res_all[[bb]]$est
             parameters_summary_M[,bb] <- res_all[[bb]]$M
             parameters_summary_SD[,bb] <- res_all[[bb]]$SD

diff --git a/R/lsem.test.R b/R/lsem.test.R
@@ -1,5 +1,5 @@
 ## File Name: lsem.test.R
-## File Version: 0.133
+## File Version: 0.134
 
 #**** test LSEM model based on bootstrap
 lsem.test <- function( mod, bmod, models=NULL )
@@ -23,7 +23,7 @@ lsem.test <- function( mod, bmod, models=NULL )
 
     #* define design matrix
     A <- matrix(0, nrow=NG-1, ncol=NG)
-    for (gg in 1:(NG-1)){
+    for (gg in 1L:(NG-1)){
         A[gg,gg] <- -1
         A[gg,gg+1] <- 1
     }
@@ -73,7 +73,7 @@ lsem.test <- function( mod, bmod, models=NULL )
             if (! bmod_missing){
                 est_boot <- matrix(NA, nrow=NC, ncol=R)
                 rr <- 1
-                for (rr in 1:R){
+                for (rr in 1L:R){
                     dat$y <- parameters_boot[ind_pp,rr]
                     dat$w <- bmod$moderator_density_boot[,rr]
                     mod12 <- stats::lm(formula=model_mm, data=dat)
@@ -89,7 +89,7 @@ lsem.test <- function( mod, bmod, models=NULL )
                 # global Wald test for all parameters without intercept
                 V <- stats::cov(t(est_boot))
                 A <- matrix(0, nrow=NC-1, ncol=NC)
-                for (cc in 1:(NC-1)){
+                for (cc in 1L:(NC-1)){
                     A[cc,cc+1] <- 1
                 }
                 res <- lsem_wald_test(theta=coef11, V=V, A=A)

diff --git a/R/lsem_aggregate_statistics.R b/R/lsem_aggregate_statistics.R
@@ -0,0 +1,14 @@
+## File Name: lsem_aggregate_statistics.R
+## File Version: 0.02
+
+
+lsem_aggregate_statistics <- function(x)
+{
+    Nimp <- length(x)
+    w <- 0
+    for (ii in 1L:Nimp){
+        w <- w + x[[ii]]
+    }
+    w <- w / Nimp
+    return(w)
+}
diff --git a/R/lsem_estimate_proc_args.R b/R/lsem_estimate_proc_args.R
@@ -1,11 +1,15 @@
 ## File Name: lsem_estimate_proc_args.R
-## File Version: 0.406
+## File Version: 0.416
 
 lsem_estimate_proc_args <- function(lavaan.args, sufficient_statistics,
     pseudo_weights, lavmodel, data, use_lavaan_survey, est_joint=FALSE,
     par_invariant=NULL, par_linear=NULL, par_quadratic=NULL,
-    partable_joint=NULL, se=NULL, G=NULL, moderator.grid=NULL, verbose=TRUE)
+    partable_joint=NULL, se=NULL, G=NULL, moderator.grid=NULL, verbose=TRUE,
+    is_imputed=FALSE)
 {
+    if (is_imputed){
+        data <- data[[1]]
+    }
 
     use_pseudo_weights <- pseudo_weights > 0
     if ( sufficient_statistics | use_pseudo_weights ){
@@ -54,7 +58,7 @@ lsem_estimate_proc_args <- function(lavaan.args, sufficient_statistics,
     data_ordered <- rep(FALSE, ncol(data1))
     names(data_ordered) <- colnames(data1)
     NV <- ncol(data1)
-    for (vv in 1:NV){
+    for (vv in 1L:NV){
         data_ordered[vv] <- is.factor(data1[,vv])
     }
     some_ordinal <- FALSE
@@ -90,6 +94,6 @@ lsem_estimate_proc_args <- function(lavaan.args, sufficient_statistics,
                 variables_ordered=variables_ordered, est_joint=est_joint,
                 partable=partable, has_meanstructure=has_meanstructure, se=se,
                 compute_se=compute_se, pseudo_weights=pseudo_weights,
-                some_ordinal=some_ordinal)
+                some_ordinal=some_ordinal, is_imputed=is_imputed)
     return(res)
 }
diff --git a/R/lsem_fit_initial_model.R b/R/lsem_fit_initial_model.R
@@ -1,9 +1,9 @@
 ## File Name: lsem_fit_initial_model.R
-## File Version: 0.205
+## File Version: 0.212
 
 lsem_fit_initial_model <- function(lavmodel__, lavaan_est_fun, dat, variables_model,
     sampling_weights, has_meanstructure, sufficient_statistics, est_joint=FALSE,
-    se="standard", use_lavaan_survey=FALSE, ...)
+    se="standard", use_lavaan_survey=FALSE, is_imputed=FALSE, Nimp=0, ...)
 {
     if (est_joint){
         has_meanstructure <- TRUE
@@ -12,7 +12,8 @@ lsem_fit_initial_model <- function(lavmodel__, lavaan_est_fun, dat, variables_mo
         #- compute sufficient statistics
         res <- lsem_fit_initial_model_sufficient_statistics(dat=dat,
                     variables_model=variables_model, sampling_weights=sampling_weights,
-                    has_meanstructure=has_meanstructure)
+                    has_meanstructure=has_meanstructure,
+                    is_imputed=is_imputed, Nimp=Nimp)
         wmean <- res$wmean
         wcov <- res$wcov
         Nobs <- res$Nobs

diff --git a/R/lsem_fit_initial_model_sufficient_statistics.R b/R/lsem_fit_initial_model_sufficient_statistics.R
@@ -1,19 +1,37 @@
 ## File Name: lsem_fit_initial_model_sufficient_statistics.R
-## File Version: 0.064
+## File Version: 0.075
 
 lsem_fit_initial_model_sufficient_statistics <- function(dat, variables_model,
-    sampling_weights, has_meanstructure)
+    sampling_weights, has_meanstructure, is_imputed=FALSE, Nimp=0)
 {
-    data_suff <- dat[, variables_model]
-    dat_resp <- 1 - is.na(data_suff)
-    wmean <- lsem_weighted_mean( x=data_suff, weights=sampling_weights,
-                                    x_resp=dat_resp)$mean
-    res <- lsem_weighted_cov( x=data_suff, weights=sampling_weights, x_resp=dat_resp)
-    wcov <- res$cov
-    Nobs <- round(res$Nobs)
+
+    dat0 <- dat
+    if (!is_imputed){
+        dat0 <- list(dat0)
+    }
+    Nimp <- max(1, Nimp)
+    wmean <- list()
+    wcov <- list()
+    Nobs <- list()
+    for (ii in 1L:Nimp){
+        dat <- dat0[[ii]]
+        data_suff <- dat[, variables_model]
+        dat_resp <- 1 - is.na(data_suff)
+        wmean[[ii]] <- lsem_weighted_mean( x=data_suff, weights=sampling_weights,
+                                        x_resp=dat_resp)$mean
+        res <- lsem_weighted_cov( x=data_suff, weights=sampling_weights, x_resp=dat_resp)
+        wcov[[ii]] <- res$cov
+        Nobs[[ii]] <- round(res$Nobs)
+    }
+
+    Nobs <- lsem_aggregate_statistics(x=Nobs)
+    wcov <- lsem_aggregate_statistics(x=wcov)
+    wmean <- lsem_aggregate_statistics(x=wmean)
+
     if (! has_meanstructure){
         wmean <- NULL
     }
+
     #--- output
     res <- list(wmean=wmean, wcov=wcov, Nobs=Nobs )
     return(res)