sam() now accepts se = "bootstrap"; boostrapLavaan() now works with s…

…am() objects

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: lavaan
 Title: Latent Variable Analysis
-Version: 0.6-20.2229
+Version: 0.6-20.2230
 Authors@R: c(person(given   = "Yves", family = "Rosseel",
                     role    = c("aut", "cre"),
                     email   = "[email protected]",

R/lav_bootstrap.R

@@ -17,13 +17,14 @@
 # Question: if fixed.x=TRUE, should we not keep X fixed, and bootstrap Y
 #           only, conditional on X?? How to implement the conditional part?
 
-# YR 27 Aug: - add keep.idx argument
-#            - always return 'full' set of bootstrap results, including
-#              failed runs (as NAs)
-#            - idx nonadmissible/error solutions as an attribute
-#            - thanks to keep.idx, it is easy to replicate/investigate these
-#              cases if needed
+# YR 27 Aug 2022: - add keep.idx argument
+#                 - always return 'full' set of bootstrap results, including
+#                   failed runs (as NAs)
+#                 - idx nonadmissible/error solutions as an attribute
+#                 - thanks to keep.idx, it is easy to replicate/investigate
+#                   these cases if needed
 
+# YR 10 Nov 2024: - detect sam object
 
 bootstrapLavaan <- function(object,
                             R = 1000L,
@@ -39,6 +40,7 @@ bootstrapLavaan <- function(object,
                             iseed = NULL,
                             h0.rmsea = NULL,
                             ...) {
+
   # checks
   type. <- tolower(type) # overwritten if nonparametric
   stopifnot(
@@ -138,7 +140,13 @@ lav_bootstrap_internal <- function(object = NULL,
 
   # object slots
   FUN.orig <- FUN
+  has.sam.object.flag <- FALSE
   if (!is.null(object)) {
+    stopifnot(inherits(object, "lavaan"))
+    # check for sam object
+    if (!is.null(object@internal$sam.method)) {
+      has.sam.object.flag <- TRUE
+    }
     lavdata <- object@Data
     lavmodel <- object@Model
     lavsamplestats <- object@SampleStats
@@ -368,6 +376,12 @@ lav_bootstrap_internal <- function(object = NULL,
       }
       return(out)
     }
+    if (has.sam.object.flag) {
+      # also need h1
+      booth1 <- lav_h1_implied_logl(lavdata = newData,
+        lavsamplestats = bootSampleStats, lavpartable = lavpartable,
+        lavoptions = lavoptions)
+    }
 
     # do we need to update Model slot? only if we have fixed exogenous
     # covariates, as their variances/covariances are stored in GLIST
@@ -377,16 +391,23 @@ lav_bootstrap_internal <- function(object = NULL,
       model.boot <- lavmodel
     }
 
-    # override option
-
     # fit model on bootstrap sample
-    fit.boot <- suppressWarnings(lavaan(
-      slotOptions = lavoptions,
-      slotParTable = lavpartable,
-      slotModel = model.boot,
-      slotSampleStats = bootSampleStats,
-      slotData = lavdata
-    ))
+    if (has.sam.object.flag) {
+      new_object <- object
+      new_object@Data <- newData
+      new_object@SampleStats <- bootSampleStats
+      new_object@h1 <- booth1
+      # what about lavoptions?
+      fit.boot <- suppressWarnings(sam(new_object, se = "none"))
+    } else {
+      fit.boot <- suppressWarnings(lavaan(
+        slotOptions = lavoptions,
+        slotParTable = lavpartable,
+        slotModel = model.boot,
+        slotSampleStats = bootSampleStats,
+        slotData = newData
+      ))
+    }
     if (!fit.boot@optim$converged) {
       if (lav_verbose()) cat("     FAILED: no convergence\n")
       out <- as.numeric(NA)

R/lav_sam_step0.R

@@ -12,7 +12,6 @@ lav_sam_step0 <- function(cmd = "sem", model = NULL, data = NULL,
   # remove do.fit option if present
   dotdotdot0$do.fit <- NULL
 
-  #
   if (sam.method %in% c("local", "fsr")) {
     dotdotdot0$sample.icov <- FALSE # if N < nvar
   }
@@ -24,7 +23,7 @@ lav_sam_step0 <- function(cmd = "sem", model = NULL, data = NULL,
   dotdotdot0$ceq.simple           <- TRUE # if not the default yet
   dotdotdot0$check.lv.interaction <- FALSE # we allow for it
   # dotdotdot0$cat.wls.w            <- FALSE # no weight matrix if categorical
-  # note: this break the computation of twostep standard errors...
+  # note: this breaks the computation of twostep standard errors...
 
   # any lv interaction terms?
   if (length(lavNames(flat.model, "lv.interaction")) > 0L) {

R/lav_sam_step1.R

@@ -1,7 +1,7 @@
 # step 1 in SAM: fitting the measurement blocks
 
 lav_sam_step1 <- function(cmd = "sem", mm.list = NULL, mm.args = list(),
-                          FIT = FIT, data = NULL, sam.method = "local") {
+                          FIT = FIT, sam.method = "local") {
   lavoptions <- FIT@Options
   lavpta <- FIT@pta
   PT <- FIT@ParTable
@@ -13,20 +13,20 @@ lav_sam_step1 <- function(cmd = "sem", mm.list = NULL, mm.args = list(),
   }
 
   # local only -> handle missing data
-  if (sam.method %in% c("local", "fsr")) {
-    # if missing = "listwise", make data complete, to avoid different
-    # datasets per measurement block
-    if (lavoptions$missing == "listwise") {
-      # FIXME: make this work for multiple groups!!
-      OV <- unique(unlist(FIT@pta$vnames$ov))
-      # add group/cluster/sample.weights variables (if any)
-      OV <- c(
-        OV, FIT@Data@group, FIT@Data@cluster,
-        FIT@Data@sampling.weights
-      )
-      data <- na.omit(data[, OV])
-    }
-  }
+  # if (sam.method %in% c("local", "fsr")) {
+  #   # if missing = "listwise", make data complete, to avoid different
+  #   # datasets per measurement block
+  #   if (lavoptions$missing == "listwise") {
+  #     # FIXME: make this work for multiple groups!!
+  #     OV <- unique(unlist(FIT@pta$vnames$ov))
+  #     # add group/cluster/sample.weights variables (if any)
+  #     OV <- c(
+  #       OV, FIT@Data@group, FIT@Data@cluster,
+  #       FIT@[email protected]
+  #     )
+  #     data <- na.omit(data[, OV])
+  #   }
+  # }
 
   # total number of free parameters
   if (FIT@Model@ceq.simple.only) {

R/lav_sam_utils.R

@@ -540,7 +540,7 @@ lav_sam_step3_joint <- function(FIT = NULL, PT = NULL, sam.method = "local") {
   if (sam.method %in% c("local", "fsr")) {
     lavoptions.joint$baseline <- FALSE
     lavoptions.joint$sample.icov <- FALSE
-    lavoptions.joint$h1 <- FALSE
+    #lavoptions.joint$h1 <- TRUE # we need this if we re-use the sam object
     lavoptions.joint$test <- "none"
     lavoptions.joint$estimator <- "none"
   } else {
@@ -560,7 +560,8 @@ lav_sam_step3_joint <- function(FIT = NULL, PT = NULL, sam.method = "local") {
   JOINT
 }
 
-lav_sam_table <- function(JOINT = NULL, STEP1 = NULL, FIT.PA = FIT.PA,
+lav_sam_table <- function(JOINT = NULL, STEP1 = NULL, FIT.PA = NULL,
+                          cmd = NULL, lavoptions = NULL,
                           mm.args = list(), struc.args = list(),
                           sam.method = "local",
                           local.options = list(), global.options = list()) {
@@ -611,6 +612,7 @@ lav_sam_table <- function(JOINT = NULL, STEP1 = NULL, FIT.PA = FIT.PA,
 
 
   SAM <- list(
+    sam.cmd = cmd,
     sam.method = sam.method,
     sam.local.options = local.options,
     sam.global.options = global.options,
@@ -624,7 +626,9 @@ lav_sam_table <- function(JOINT = NULL, STEP1 = NULL, FIT.PA = FIT.PA,
     sam.mm.rel = sam.mm.rel,
     sam.struc.estimator = FIT.PA@Model@estimator,
     sam.struc.args = struc.args,
-    sam.struc.fit = sam.struc.fit
+    sam.struc.fit = sam.struc.fit,
+    sam.lavoptions = lavoptions
   )
   SAM
 }
+

R/xxx_lavaanList.R

@@ -262,7 +262,8 @@ lavaanList <- function(model = NULL, # model
             args = c(
               list(
                 model = model,
-                data = DATA
+                data = DATA,
+                se = FIT@Options$se
               ),
               dotdotdot
             )