From 33dd3f33df95b161618aa4406b181a389c8a1ec0 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Wed, 3 Jun 2026 20:09:34 +0800 Subject: [PATCH] Add the option to computer df internally tests and checks passed. --- R/fit_many.R | 8 ++++++ R/get_add.R | 56 +++++++++++++++++++++++++----------- R/get_drop.R | 24 +++++++--------- R/helpers3_for_model_graph.R | 2 ++ R/helpers4_for_model_graph.R | 1 + R/print.model_set.R | 1 + 6 files changed, 61 insertions(+), 31 deletions(-) diff --git a/R/fit_many.R b/R/fit_many.R index 125f873..82cb093 100644 --- a/R/fit_many.R +++ b/R/fit_many.R @@ -350,6 +350,7 @@ fit_many <- function(model_list, MoreArgs = list(fit_i = fit_i), SIMPLIFY = TRUE) if (is.null(original)) { + # Can use "fitMeasures" because sem_out is always a fitted object sem_out_df <- as.numeric(lavaan::fitMeasures(sem_out, "df")) # change_list <- sapply(fit_list, # function(x) sem_out_df - as.numeric(lavaan::fitMeasures(x, fit.measures = "df"))) @@ -389,6 +390,7 @@ lavaan_to_sem_outs <- function(x, } else { if (original %in% names(x)) { i_original <- match(original, names(x)) + # Can use "fitMeasures" because sem_out is always a fitted object change_list <- sapply(x, function(x) as.numeric(lavaan::fitMeasures(x, fit.measures = "df"))) df_original <- change_list[i_original] @@ -415,6 +417,7 @@ lavaan_to_sem_outs <- function(x, fit_many_get_df <- function(fit, model, fit_i) { + # Can try "fitMeasures" because sem_out is always a fitted object out <- tryCatch(lavaan::fitMeasures(fit, fit.measures = "df"), error = function(e) e) if (!inherits(out, "error")) { @@ -426,6 +429,11 @@ fit_many_get_df <- function(fit, warn = FALSE))) out <- tryCatch(lavaan::fitMeasures(fit1, fit.measures = "df"), error = function(e) e) + if (!inherits(out, "error")) { + return(as.numeric(out)) + } + # Last resort + out <- lavaan_df(lavaan::parameterTable(fit)) if (!inherits(out, "error")) { return(as.numeric(out)) } diff --git a/R/get_add.R b/R/get_add.R index 126307b..5390e9b 100644 --- a/R/get_add.R +++ b/R/get_add.R @@ -426,6 +426,7 @@ gen_pt_add <- function(x, pt, sem_out, from = NA) { x_constr_out <- NULL } # Add free parameters + do_fit <- getOption("modelbpp.do_fit", TRUE) if (length(x_free) > 0) { x_free_str <- par_names(pars_list = x_free) p_to_add <- sapply(x_free, paste0, collapse = "") @@ -434,20 +435,18 @@ gen_pt_add <- function(x, pt, sem_out, from = NA) { object = sem_out, model = pt, add = x_free_str, - do.fit = TRUE, + do.fit = do_fit, optim.force.converged = TRUE, control = list(max.iter = 1) ) - # sem_out_update <- lavaan::update(sem_out, - # pt, - # add = x_free_str, - # do.fit = TRUE, - # optim.force.converged = TRUE, - # control = list(max.iter = 1)) pt_update <- lavaan::parameterTable(sem_out_update) pt_update$se <- NA - pt_update_df <- unname(lavaan::fitMeasures(sem_out_update, - fit.measures = "df")) + if (do_fit) { + pt_update_df <- unname(lavaan::fitMeasures(sem_out_update, + fit.measures = "df")) + } else { + pt_update_df <- lavaan_df(sem_out_update) + } } else { x_free_str <- NULL p_to_add <- NULL @@ -455,19 +454,18 @@ gen_pt_add <- function(x, pt, sem_out, from = NA) { FUN = lavaan::update, object = sem_out, model = pt, - do.fit = TRUE, + do.fit = do_fit, optim.force.converged = TRUE, control = list(max.iter = 1) ) - # sem_out_update <- lavaan::update(sem_out, - # pt, - # do.fit = TRUE, - # optim.force.converged = TRUE, - # control = list(max.iter = 1)) pt_update <- lavaan::parameterTable(sem_out_update) pt_update$se <- NA - pt_update_df <- unname(lavaan::fitMeasures(sem_out_update, - fit.measures = "df")) + if (do_fit) { + pt_update_df <- unname(lavaan::fitMeasures(sem_out_update, + fit.measures = "df")) + } else { + pt_update_df <- lavaan_df(sem_out_update) + } } attr(pt_update, "parameters_added") <- p_to_add attr(pt_update, "parameters_added_str") <- x_free_str @@ -477,8 +475,32 @@ gen_pt_add <- function(x, pt, sem_out, from = NA) { attr(pt_update, "constraints_released") <- x_constr_pars attr(pt_update, "constraints_released_list") <- x_constr_out attr(pt_update, "from") <- from + # Can use "fitMeasures" because sem_out is always a fitted object attr(pt_update, "df_expected") <- unname(lavaan::fitMeasures(sem_out, "df")) - length(x) attr(pt_update, "df_actual") <- pt_update_df pt_update } + +#' @noRd +lavaan_df <- function( + object +) { + # Adapted from lavaan:::lav_model_test() + pt <- lavaan::parameterTable(object) + df <- lavaan::lav_partable_df(pt) + slotModel <- object@Model + if (!slotModel@cin.simple.only && + (nrow(slotModel@con.jac) > 0L)) { + ceq_idx <- attr(slotModel@con.jac, "ceq.idx") + if (length(ceq_idx) > 0L) { + neq <- qr(slotModel@con.jac[ceq_idx, , drop = FALSE])$rank + df <- df + neq + } + } else if (slotModel@ceq.simple.only) { + ndat <- lavaan::lav_partable_ndat(pt) + npar <- sum(pt$free > 0) + df <- ndat - npar + } + df +} diff --git a/R/get_drop.R b/R/get_drop.R index b5de869..85386f2 100644 --- a/R/get_drop.R +++ b/R/get_drop.R @@ -176,6 +176,7 @@ get_drop <- function(sem_out, } ) sets_to_gen <- unlist(sets_to_gen, recursive = FALSE) + # Can use "fitMeasures" because sem_out is always a fitted object df0 <- lavaan::fitMeasures(sem_out, "df") if (progress) { cat("\nGenerate", length(sets_to_gen), "more restrictive model(s):\n") @@ -231,11 +232,12 @@ gen_pt_drop <- function(x, pt, to, source_df = NA, sem_out) { p_to_drop_out <- lapply(x, function(x) { c(lhs = pt[x, "lhs"], op = pt[x, "op"], rhs = pt[x, "rhs"]) }) + do_fit <- getOption("modelbpp.do_fit", TRUE) suppressWarnings(sem_out_update <- auto_ram( FUN = lavaan::update, object = sem_out, model = pt, - do.fit = TRUE, + do.fit = do_fit, optim.force.converged = TRUE, warn = FALSE, se = "none", @@ -245,25 +247,19 @@ gen_pt_drop <- function(x, pt, to, source_df = NA, sem_out) { check.vcov = FALSE, control = list(max.iter = 1)) ) - # suppressWarnings(sem_out_update <- lavaan::update(sem_out, - # pt, - # do.fit = TRUE, - # optim.force.converged = TRUE, - # warn = FALSE, - # se = "none", - # baseline = FALSE, - # check.start = FALSE, - # check.post = FALSE, - # check.vcov = FALSE, - # control = list(max.iter = 1))) pt_update <- lavaan::parameterTable(sem_out_update) + if (do_fit) { + pt_update_df <- unname(lavaan::fitMeasures(sem_out_update, + fit.measures = "df")) + } else { + pt_update_df <- lavaan_df(sem_out_update) + } attr(pt_update, "parameters_dropped") <- p_to_drop attr(pt_update, "parameters_dropped_list") <- p_to_drop_out attr(pt_update, "ids_dropped") <- x attr(pt_update, "to") <- to attr(pt_update, "df_expected") <- unname(source_df) + length(x) - attr(pt_update, "df_actual") <- unname(lavaan::fitMeasures(sem_out_update, - fit.measures = "df")) + attr(pt_update, "df_actual") <- pt_update_df pt_update } \ No newline at end of file diff --git a/R/helpers3_for_model_graph.R b/R/helpers3_for_model_graph.R index c783724..90eaaf2 100644 --- a/R/helpers3_for_model_graph.R +++ b/R/helpers3_for_model_graph.R @@ -102,6 +102,7 @@ models_network2 <- function(object, if (!all(converged)) { stop("One or more models did not converge.") } + # Can use "fitMeasures" because sem_out is always a fitted object if (inherits(object, "model_set")) { if (!is.null(object$model_df)) { model_dfs <- object$model_df @@ -189,6 +190,7 @@ x_net_y <- function(x, chk <- check_x_net_y(x, y, ignore_fixed_x = FALSE) } + # Can use "fitMeasures" because sem_out is always a fitted object if (is.null(x_df)) { x_df <- lavaan::fitMeasures(x, fit.measures = "df") } diff --git a/R/helpers4_for_model_graph.R b/R/helpers4_for_model_graph.R index 1880cf8..18a505d 100644 --- a/R/helpers4_for_model_graph.R +++ b/R/helpers4_for_model_graph.R @@ -10,6 +10,7 @@ layer_by_df <- function(g, if (!all(model_set_out$converged)) { stop("Not all models converged.") } else { + # Can use "fitMeasures" because sem_out is always a fitted object model_dfs <- sapply(model_set_out$fit, lavaan::fitMeasures, fit.measures = "df") diff --git a/R/print.model_set.R b/R/print.model_set.R index a0baa1a..cdcdea3 100644 --- a/R/print.model_set.R +++ b/R/print.model_set.R @@ -140,6 +140,7 @@ print.model_set <- function(x, if (!is.null(x$model_df)) { model_df_tmp <- x$model_df } else { + # Can use "fitMeasures" because sem_out is always a fitted object model_df_tmp <- sapply(x$fit, lavaan::fitMeasures, fit.measures = "df") }