sfcheung · sfcheung · Jun 3, 2026 · Jun 3, 2026 · Jun 3, 2026 · Jun 3, 2026
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: modelbpp
 Title: Model BIC Posterior Probability
-Version: 0.3.0.1
+Version: 0.3.0.2
 Authors@R:
     c(person(given = "Shu Fai",
              family = "Cheung",
@@ -36,7 +36,7 @@ Suggests:
     rmarkdown,
     tinytest
 Depends:
-    R (>= 4.0.0)
+    R (>= 4.1.0)
 Imports:
     lavaan,
     parallel,

diff --git a/NEWS.md b/NEWS.md
@@ -1,4 +1,4 @@
-# modelbpp 0.3.0.1
+# modelbpp 0.3.0.2
 
 ## Miscellaneous
 
@@ -7,6 +7,18 @@
   if `LISREL` fails.
   (0.3.0.1)
 
+- If the option `modelbpp.do_fit` is set
+  to `FALSE`, a parameter table will not
+  be fitted to get the model *df*, leading
+  to faster search. If this options is
+  set to `TRUE` or is not set, then the
+  parameter table will be fitted as
+  in 0.3.0.2 or older version.
+  (0.3.0.2)
+
+- Depends on R 4.1.0 or later now.
+  (0.3.0.2)
+
 # modelbpp 0.3.0
 
 ## Miscellaneous

diff --git 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
@@ -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,40 +435,37 @@ 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
         sem_out_update <- auto_ram(
           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
@@ -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
   }
diff --git 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
@@ -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
@@ -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")
           }

diff --git a/README.md b/README.md
@@ -11,7 +11,7 @@
 
 # modelbpp: Model BIC Posterior Probability <img src="man/figures/logo.png" align="right" />
 
-(Version 0.3.0.1 updated on 2026-05-30, [release history](https://sfcheung.github.io/modelbpp/news/index.html))
+(Version 0.3.0.2 updated on 2026-05-30, [release history](https://sfcheung.github.io/modelbpp/news/index.html))
 
 This package is for assessing model uncertainty in structural
 equation modeling (SEM) by the BIC posterior