3.12-41

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: sirt
 Type: Package
 Title: Supplementary Item Response Theory Models
-Version: 3.12-1
-Date: 2021-12-10 11:57:34
+Version: 3.12-41
+Date: 2022-02-25 23:07:24
 Author: Alexander Robitzsch [aut,cre] (<https://orcid.org/0000-0002-8226-3132>)
 Maintainer: Alexander Robitzsch <[email protected]>
 Description: 
@@ -28,8 +28,8 @@ Imports:
     CDM, graphics, methods, Rcpp, stats, TAM, utils
 Suggests:
     coda, igraph, lavaan, lavaan.survey, MASS, Matrix,
-    miceadds, mirt, mvtnorm, pbivnorm, pbv, psych, 
-    sfsmisc, sm, survey
+    miceadds, minqa, mirt, mvtnorm, nloptr, optimx, pbivnorm, 
+    pbv, psych, sfsmisc, sm, survey
 Enhances:
     immer
 LinkingTo: 

NAMESPACE

@@ -35,6 +35,7 @@ importFrom(stats, confint)
 importFrom(stats, cor)
 importFrom(stats, cov)
 importFrom(stats, cov2cor)
+importFrom(stats, cov.wt)
 importFrom(stats, cutree)
 importFrom(stats, dbeta)
 importFrom(stats, dnorm)

R/RcppExports.R

@@ -1,5 +1,5 @@
 ## File Name: RcppExports.R
-## File Version: 3.012001
+## File Version: 3.012041
 # Generated by using Rcpp::compileAttributes() -> do not edit by hand
 # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
 
@@ -219,6 +219,66 @@ sirt_rcpp_lq_fit_fct_optim <- function(Z, y, beta, pow, w, eps) {
     .Call('_sirt_sirt_rcpp_lq_fit_fct_optim', PACKAGE='sirt', Z, y, beta, pow, w, eps)
 }
 
+sirt_rcpp_mgsem_quadform <- function(y, A) {
+    .Call('_sirt_sirt_rcpp_mgsem_quadform', PACKAGE='sirt', y, A)
+}
+
+sirt_rcpp_mgsem_quadform_logical <- function(y, A, A_logical) {
+    .Call('_sirt_sirt_rcpp_mgsem_quadform_logical', PACKAGE='sirt', y, A, A_logical)
+}
+
+sirt_rcpp_mgsem_trace_product <- function(A, B) {
+    .Call('_sirt_sirt_rcpp_mgsem_trace_product', PACKAGE='sirt', A, B)
+}
+
+sirt_rcpp_mgsem_trace_product_logical <- function(A, B, B_logical) {
+    .Call('_sirt_sirt_rcpp_mgsem_trace_product_logical', PACKAGE='sirt', A, B, B_logical)
+}
+
+sirt_rcpp_mgsem_loglike_derivative_parameters <- function(S1, S3, y, Sigma_der, Sigma_der_logical) {
+    .Call('_sirt_sirt_rcpp_mgsem_loglike_derivative_parameters', PACKAGE='sirt', S1, S3, y, Sigma_der, Sigma_der_logical)
+}
+
+sirt_rcpp_mgsem_compute_cov <- function(LAM, PHI, PSI) {
+    .Call('_sirt_sirt_rcpp_mgsem_compute_cov', PACKAGE='sirt', LAM, PHI, PSI)
+}
+
+sirt_rcpp_mgsem_sumproduct_logical <- function(x, y, y_logical) {
+    .Call('_sirt_sirt_rcpp_mgsem_sumproduct_logical', PACKAGE='sirt', x, y, y_logical)
+}
+
+sirt_rcpp_mgsem_vech_numeric <- function(A) {
+    .Call('_sirt_sirt_rcpp_mgsem_vech_numeric', PACKAGE='sirt', A)
+}
+
+sirt_rcpp_mgsem_vech_logical <- function(A) {
+    .Call('_sirt_sirt_rcpp_mgsem_vech_logical', PACKAGE='sirt', A)
+}
+
+sirt_rcpp_mgsem_eval_pen_lp_lasso <- function(y, eps_approx, p, regul_fac) {
+    .Call('_sirt_sirt_rcpp_mgsem_eval_pen_lp_lasso', PACKAGE='sirt', y, eps_approx, p, regul_fac)
+}
+
+sirt_rcpp_mgsem_eval_pen_lp_scad <- function(y, eps_approx, p, regul_fac, a_scad) {
+    .Call('_sirt_sirt_rcpp_mgsem_eval_pen_lp_scad', PACKAGE='sirt', y, eps_approx, p, regul_fac, a_scad)
+}
+
+sirt_rcpp_mgsem_eval_pen_lp_lasso_deriv <- function(y, eps_approx, p, regul_fac) {
+    .Call('_sirt_sirt_rcpp_mgsem_eval_pen_lp_lasso_deriv', PACKAGE='sirt', y, eps_approx, p, regul_fac)
+}
+
+sirt_rcpp_mgsem_eval_lp_penalty <- function(x, fac, n, p, eps_approx, deriv, pen_type, a_scad, h) {
+    .Call('_sirt_sirt_rcpp_mgsem_eval_lp_penalty', PACKAGE='sirt', x, fac, n, p, eps_approx, deriv, pen_type, a_scad, h)
+}
+
+sirt_rcpp_mgsem_eval_lpdiff_penalty <- function(x, fac, fac_logical, p, eps_approx, a_scad, pen_type, n) {
+    .Call('_sirt_sirt_rcpp_mgsem_eval_lpdiff_penalty', PACKAGE='sirt', x, fac, fac_logical, p, eps_approx, a_scad, pen_type, n)
+}
+
+sirt_rcpp_mgsem_eval_lpdiff_penalty_deriv <- function(x, fac, n, fac_logical, p, eps_approx, h, a_scad, pen_type) {
+    .Call('_sirt_sirt_rcpp_mgsem_eval_lpdiff_penalty_deriv', PACKAGE='sirt', x, fac, n, fac_logical, p, eps_approx, h, a_scad, pen_type)
+}
+
 sirt_rcpp_monoreg_rowwise <- function(YM, WM) {
     .Call('_sirt_sirt_rcpp_monoreg_rowwise', PACKAGE='sirt', YM, WM)
 }

R/invariance_alignment_cfa_config.R

@@ -1,21 +1,31 @@
 ## File Name: invariance_alignment_cfa_config.R
-## File Version: 0.227
+## File Version: 0.247
 
 
 invariance_alignment_cfa_config <- function(dat, group, weights=NULL,
-    verbose=FALSE, ...)
+    model="2PM", verbose=FALSE, ...)
 {
     CALL <- match.call()
-    #- reordering
-    ind <- order(group)
-    dat <- dat[ ind, ]
-    group <- group[ind]
-    if (!is.null(weights)){
-        weights <- weights[ind]
+    is_data <- sirt_is_data(dat=dat)
+    if (! is_data){
+        mu_list <- dat[[1]]
+        Sigma_list <- dat[[2]]
+        N_list <- dat[[3]]
+        I <- length(mu_list[[1]])
+        group <- seq(1,length(mu_list))
+        is_data <- FALSE
+    }
+    if (is_data){
+        ind <- order(group)
+        dat <- dat[ ind, ]
+        group <- group[ind]
+        I <- ncol(dat)
+        if (!is.null(weights)){
+            weights <- weights[ind]
+        }
     }
     groups <- unique(group)
     G <- length(groups)
-    I <- ncol(dat)
     items <- colnames(dat)
     N <- rep(NA, G)
     names(N) <- groups
@@ -26,17 +36,24 @@ invariance_alignment_cfa_config <- function(dat, group, weights=NULL,
     err_var <- nu
     weights_gg <- NULL
     for (gg in 1:G){
-        dat_gg <- dat[ group==groups[gg], ]
-        dat_gg <- dat_gg[, colMeans(is.na(dat_gg)) < 1 ]
-        items_gg <- colnames(dat_gg)
-        ind_gg <- match(items_gg, items)
-        if (!is.null(weights)){
-            weights_gg <- weights[group==groups[gg]]
+        if (is_data){
+            dat_gg <- dat[ group==groups[gg], ]
+            dat_gg <- dat_gg[, colMeans(is.na(dat_gg)) < 1 ]
+            items_gg <- colnames(dat_gg)
+            ind_gg <- match(items_gg, items)
+            if (!is.null(weights)){
+                weights_gg <- weights[group==groups[gg]]
+            }
+            args <- list(dat_gg=dat_gg, weights_gg=weights_gg, model=model, ...)
+        }
+        if (!is_data){
+            dat_gg <- list(mu=mu_list[[gg]], Sigma=Sigma_list[[gg]], N=N_list[[gg]])
+            args <- list(dat_gg=dat_gg, weights_gg=NULL, model=model)
+            ind_gg <- 1:I
         }
-        cat( paste0("Compute CFA for group ", gg, "\n") )
+        cat( paste0("Compute CFA for group ", gg, " | model ", model, "\n") )
         utils::flush.console()
-        res <- invariance_alignment_cfa_config_estimate(dat_gg=dat_gg,
-                        weights_gg=weights_gg, ...)
+        res <- do.call(what="invariance_alignment_cfa_config_estimate", args=args)
         nu[gg, ind_gg] <- res$nu
         lambda[gg, ind_gg] <- res$lambda
         err_var[gg, ind_gg] <- res$err_var

R/invariance_alignment_cfa_config_estimate.R

@@ -1,23 +1,46 @@
 ## File Name: invariance_alignment_cfa_config_estimate.R
-## File Version: 0.15
+## File Version: 0.189
 
-invariance_alignment_cfa_config_estimate <- function(dat_gg, weights_gg=NULL, ...)
+invariance_alignment_cfa_config_estimate <- function(dat_gg, weights_gg=NULL,
+    model="2PM", ...)
 {
-    I_gg <- ncol(dat_gg)
-    items_gg <- colnames(dat_gg)
-    label_F <- "F"
-    while (label_F %in% items_gg){
-        label_F <- paste0( label_F, "F")
+    is_data <- sirt_is_data(dat=dat_gg)
+    #-- create lavaan model
+    if (is_data){
+        I_gg <- ncol(dat_gg)
+        items_gg <- colnames(dat_gg)
+    } else {
+        mu <- dat_gg[[1]]
+        Sigma <- dat_gg[[2]]
+        I_gg <- length(mu)
+        items_gg <- names(mu)
+        if (is.null(items_gg)){
+            items_gg <- paste0("I",1:I)
+        }
+        names(mu) <- items_gg
+        rownames(Sigma) <- items_gg
+        colnames(Sigma) <- items_gg
     }
-    lavmodel <- paste0(label_F, "=~", paste0(items_gg, collapse="+") )
+    lavmodel <- invariance_alignment_cfa_config_estimate_define_lavaan_model(
+                    items_gg=items_gg, label_F="F", model=model)
     if (is.null(weights_gg)){
         weights_name <- NULL
     } else {
         dat_gg$weights <- weights_gg
         weights_name <- "weights"
     }
-    mod <- sirt_import_lavaan_cfa(data=dat_gg, model=lavmodel, std.lv=TRUE,
-                meanstructure=TRUE, sampling.weights=weights_name, ...)
+
+    #-- estimate lavaan model
+    args <- list( model=lavmodel, std.lv=TRUE, meanstructure=TRUE, ...)
+    if (is_data){
+        args$data <- dat_gg
+        args$sampling.weights <- weights_name
+    } else {
+        args$sample.cov <- Sigma
+        args$sample.mean <- mu
+        args$sample.nobs <- min(1e20,N)
+    }
+    mod <- do.call(what="sirt_import_lavaan_cfa", args=args)
     partable <- sirt_import_lavaan_parameterTable(object=mod)
     lambda <- partable[ partable$op=="=~", "est"]
     nu <- partable[ partable$op=="~1", "est"][1:I_gg]

R/invariance_alignment_cfa_config_estimate_define_lavaan_model.R

@@ -0,0 +1,20 @@
+## File Name: invariance_alignment_cfa_config_estimate_define_lavaan_model.R
+## File Version: 0.08
+
+
+invariance_alignment_cfa_config_estimate_define_lavaan_model <-
+        function(items_gg, label_F="F", model="2PM")
+{
+    while (label_F %in% items_gg){
+        label_F <- paste0( label_F, "F")
+    }
+    if (substring(model,1,1)=="2"){
+        lavmodel <- paste0(label_F, "=~", paste0(items_gg, collapse="+") )
+    } else {
+        lavmodel <- paste0(label_F, "=~", paste0( paste0("a*",items_gg), collapse="+") )
+        # lavmodel <- paste0( lavmodel, "\n", "F~~1*F")
+        lavmodel1 <- paste0(paste0(items_gg, "~~b*", items_gg), collapse="\n" )
+        lavmodel <- paste0( lavmodel, "\n", lavmodel1)
+    }
+    return(lavmodel)
+}

R/invariance_alignment_simulate.R

@@ -1,8 +1,12 @@
 ## File Name: invariance_alignment_simulate.R
-## File Version: 0.05
+## File Version: 0.108
 
-invariance_alignment_simulate <- function(nu, lambda, err_var, mu, sigma, N)
+invariance_alignment_simulate <- function(nu, lambda, err_var, mu, sigma, N,
+    output="data", groupwise=FALSE)
 {
+    if (length(N)==1 & nrow(nu)>1){
+        N <- rep(N, nrow(nu))
+    }
     N_tot <- sum(N)
     G <- nrow(nu)
     I <- ncol(nu)
@@ -13,20 +17,55 @@ invariance_alignment_simulate <- function(nu, lambda, err_var, mu, sigma, N)
     n_end <- cumsum(N)
     n_start <- c(1,n_end+1)[-c(G+1)]
     #* simulate data
-    group <- rep(1:G, N)
-    dat <- matrix(NA, nrow=N_tot, ncol=I+1)
-    colnames(dat) <- c("group",items)
-    dat <- as.data.frame(dat)
-    dat$group <- group
-    for (gg in 1:G){
-        N_gg <- N[gg]
-        ind_gg <- seq(n_start[gg], n_end[gg])
-        fac <- stats::rnorm(N_gg, mean=mu[gg], sd=sigma[gg])
-        for (ii in 1:I){
-            err_ii <- stats::rnorm(N_gg, mean=0, sd=sqrt(err_var[gg,ii]) )
-            dat[ind_gg, ii+1] <- nu[gg,ii] + lambda[gg,ii]*fac + err_ii
+    if (N[1]<Inf){
+        group <- rep(1:G, N)
+        dat <- matrix(NA, nrow=N_tot, ncol=I+1)
+        colnames(dat) <- c("group",items)
+        dat <- as.data.frame(dat)
+        dat$group <- group
+        for (gg in 1:G){
+            N_gg <- N[gg]
+            ind_gg <- seq(n_start[gg], n_end[gg])
+            fac <- stats::rnorm(N_gg, mean=mu[gg], sd=sigma[gg])
+            for (ii in 1:I){
+                err_ii <- stats::rnorm(N_gg, mean=0, sd=sqrt(err_var[gg,ii]) )
+                dat[ind_gg, ii+1] <- nu[gg,ii] + lambda[gg,ii]*fac + err_ii
+            }
+        }
+        #-- output
+        res <- dat
+        if (output=="suffstat"){
+            res <- list(mu=list(), Sigma=list(), N=list() )
+            for (gg in 1:G){
+                ind_gg <- which(dat$group==gg)
+                res$mu[[gg]] <- colMeans(dat[ ind_gg, -1])
+                res$Sigma[[gg]] <- stats::cov.wt(dat[ ind_gg, -1], method="ML")$cov
+                res$N[[gg]] <- N[gg]
+            }
+        }
+    }
+    #*** only compute covariance matrices
+    if (N[1]==Inf){
+        res <- list(mu=list(), Sigma=list(), N=list() )
+        for (gg in 1:G){
+            lam_gg <- lambda[gg,]
+            sig2_gg <- sigma[gg]^2
+            res$mu[[gg]] <- nu[gg,] + lam_gg*mu[gg]
+            lam_gg <- matrix(lam_gg, ncol=1)
+            res$Sigma[[gg]] <- lam_gg %*% sig2_gg %*% t(lam_gg) + diag(err_var[gg,])
+            res$N[[gg]] <- N[gg]
         }
+        output <- "suffstat"
     }
+    #*** group-wise output
+    if ( (output=="suffstat") & groupwise ){
+        res1 <- res
+        res <- as.list(1:G)
+        for (gg in 1:G){
+            res[[gg]] <- list(mu=res1$mu[[gg]], Sigma=res1$Sigma[[gg]], N=res1$N[[gg]])
+        }
+    }
+
     #--- output
-    return(dat)
+    return(res)
 }

R/lsem.estimate.R

@@ -1,5 +1,5 @@
 ## File Name: lsem.estimate.R
-## File Version: 1.008
+## File Version: 1.015
 
 # estimate LSEM model
 lsem.estimate <- function( data, moderator, moderator.grid,
@@ -44,6 +44,7 @@ lsem.estimate <- function( data, moderator, moderator.grid,
     se <- res$se
     compute_se <- res$compute_se
     pseudo_weights <- res$pseudo_weights
+    some_ordinal <- res$some_ordinal
 
     # group moderator if type="MGM"
     out <- lsem_group_moderator( data=data, type=type, moderator.grid=moderator.grid,