Avoid update for some models

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 &&

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"))

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
 }

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,