diff --git a/R/get_add.R b/R/get_add.R index c176e32..ea40c67 100644 --- a/R/get_add.R +++ b/R/get_add.R @@ -197,7 +197,7 @@ get_add <- function(sem_out, if (!inherits(sem_out, "lavaan")) { stop("sem_out is not a lavaan-class object.") } - pt <- lavaan::parameterTable(sem_out) + pt <- parameterTable_simple(sem_out) # ==== Remove all user-defined parameters ==== pt <- pt[pt$op != ":=", ] @@ -426,36 +426,58 @@ gen_pt_add <- function(x, pt, sem_out, from = NA) { x_constr_out <- NULL } # Add free parameters + do_fit <- getOption("modelbpp.do_fit", FALSE) + + use_pt_add_only <- getOption("modelbpp.use_pt_add_only", FALSE) + # Allow pt_add_only only if the model has no constraints + slotModel <- sem_out@Model + if ((!slotModel@cin.simple.only && + (nrow(slotModel@con.jac) > 0L)) || + slotModel@ceq.simple.only) { + use_pt_add_only <- FALSE + } if (length(x_free) > 0) { x_free_str <- par_names(pars_list = x_free) p_to_add <- sapply(x_free, paste0, collapse = "") - sem_out_update <- auto_ram( - FUN = lavaan::update, - object = sem_out, - model = pt, - add = x_free_str, - do.fit = do_fit, - baseline = FALSE, - h1 = FALSE, - implied = FALSE, - check.vcov = FALSE, - check.start = FALSE, - check.sigma.pd = FALSE, - check.gradient = FALSE, - check.post = FALSE, - samplestats = do_fit, - optim.force.converged = TRUE, - control = list(max.iter = 1) - ) - pt_update <- lavaan::parameterTable(sem_out_update) - pt_update$se <- NA - if (do_fit) { - pt_update_df <- unname(lavaan::fitMeasures(sem_out_update, - fit.measures = "df")) + if (use_pt_add_only) { + # Valid only if no constraint + ngroups <- lavaan::lavTech(sem_out, "ngroups") + pt_update <- pt_add_only( + pt = pt, + add = x_free_str, + ngroups = ngroups + ) + pt_update_df <- lavaan::lav_partable_df(pt_update) } else { - pt_update_df <- lavaan_df(sem_out_update) + sem_out_update <- auto_ram( + FUN = lavaan::update, + object = sem_out, + model = pt, + add = x_free_str, + do.fit = do_fit, + baseline = FALSE, + h1 = FALSE, + implied = FALSE, + check.vcov = FALSE, + check.start = FALSE, + check.sigma.pd = FALSE, + check.gradient = FALSE, + check.post = FALSE, + samplestats = do_fit, + optim.force.converged = TRUE, + control = list(max.iter = 1) + ) + pt_update <- parameterTable_simple(sem_out_update) + if (do_fit && + !use_pt_add_only) { + pt_update_df <- unname(lavaan::fitMeasures(sem_out_update, + fit.measures = "df")) + } else { + pt_update_df <- lavaan_df(sem_out_update) + } } + pt_update$se <- NA } else { x_free_str <- NULL p_to_add <- NULL @@ -476,7 +498,7 @@ gen_pt_add <- function(x, pt, sem_out, from = NA) { optim.force.converged = TRUE, control = list(max.iter = 1) ) - pt_update <- lavaan::parameterTable(sem_out_update) + pt_update <- parameterTable_simple(sem_out_update) pt_update$se <- NA if (do_fit) { pt_update_df <- unname(lavaan::fitMeasures(sem_out_update, @@ -505,7 +527,7 @@ lavaan_df <- function( object ) { # Adapted from lavaan:::lav_model_test() - pt <- lavaan::parameterTable(object) + pt <- parameterTable_simple(object) df <- lavaan::lav_partable_df(pt) slotModel <- object@Model if (!slotModel@cin.simple.only && diff --git a/R/get_drop.R b/R/get_drop.R index cd6738e..b555214 100644 --- a/R/get_drop.R +++ b/R/get_drop.R @@ -126,7 +126,7 @@ get_drop <- function(sem_out, stop("sem_out is not a lavaan-class object.") } loadings_to_exclude <- match.arg(loadings_to_exclude) - pt <- lavaan::parameterTable(sem_out) + pt <- parameterTable_simple(sem_out) # ==== Remove all user-defined parameters unless constrained ==== pt <- pt_remove_user_defined(pt, remove_constrained = FALSE) # ==== Exclude all parameters already constrained to be equal ==== @@ -252,7 +252,7 @@ gen_pt_drop <- function(x, pt, to, source_df = NA, sem_out) { samplestats = do_fit, control = list(max.iter = 1)) ) - pt_update <- lavaan::parameterTable(sem_out_update) + pt_update <- parameterTable_simple(sem_out_update) if (do_fit) { pt_update_df <- unname(lavaan::fitMeasures(sem_out_update, fit.measures = "df")) diff --git a/R/helpers1.R b/R/helpers1.R index 59d7a19..f64e3c5 100644 --- a/R/helpers1.R +++ b/R/helpers1.R @@ -405,4 +405,84 @@ pt_remove_all_loadings <- function( } else { return(pt[!i1, ]) } +} + +#' @noRd +pt_add_only <- function( + pt, + add, + ngroups +) { + # Adapted from lavaan::lav_object_extended() + # Use it to avoid using lavaan::update() + # Customized for get_add() + + add_org <- lavaan::lavaanify( + add, + ngroups = ngroups + ) + add_1 <- add_org[, c("lhs", "op", "rhs", "user", + "label")] + # Add block, group, level + k <- nrow(add_1) + if (!is.null(add_org$block)) { + add_1$block <- add_org$block + } else { + add_1$block <- rep(1, k) + } + if (!is.null(add_org$group)) { + add_1$group <- add_org$group + } else { + add_1$group <- rep(1, k) + } + if (!is.null(add_org$level)) { + add_1$level <- add_org$level + } else { + add_1$level <- rep(1, k) + } + + # Only keep user parameters + free_idx <- which(add_1$user > 0) + add_1 <- add_1[free_idx, , drop = FALSE] + + # Complete the table + k <- nrow(add_1) + add_1$free <- rep(1, k) + add_1$start <- rep(0, k) + add_1$user <- rep(1, k) + + pt_added <- lavaan::lav_partable_merge( + pt, + add_1, + remove.duplicated = TRUE, + warn = FALSE + ) + + # Fix free + free_idx <- which(pt_added$free > 0) + pt_added$free[free_idx] <- seq_along(free_idx) + + # Match original pt + pt_cols <- match(colnames(pt), + colnames(pt_added)) + pt_added <- pt_added[, pt_cols[!is.na(pt_cols)]] + class(pt_added) <- c("lavaan.data.frame", + class(pt)) + + pt_added +} + +#' @noRd +parameterTable_simple <- function( + object +) { + # A simplified version of lavaan::parameterTable() + # There is no need to check object because + # all models are supposed to be generated internally + out <- as.data.frame( + object@ParTable, + stringsAsFactors = FALSE + ) + class(out) <- c("lavaan.data.frame", class(out)) + out } \ No newline at end of file diff --git a/R/model_set.R b/R/model_set.R index de8e7be..966d89b 100644 --- a/R/model_set.R +++ b/R/model_set.R @@ -601,7 +601,7 @@ gen_models <- function(sem_out, must_drop = must_drop, must_not_drop = must_not_drop, loadings_to_exclude_from_drop = loadings_to_exclude_from_drop, - remove_constraints = remove_duplicated, + remove_constraints = remove_constraints, exclude_error_cov = exclude_error_cov, exclude_feedback = exclude_feedback, exclude_xy_cov = exclude_xy_cov,