[SAM] allow (again) for sample.cov= + sample.mean= (instead of data=)

yrosseel · Nov 16, 2024 · 81ec552 · 81ec552
1 parent 010b6da
commit 81ec552
Show file tree

Hide file tree

Showing 4 changed files with 44 additions and 10 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: lavaan
 Title: Latent Variable Analysis
-Version: 0.6-20.2232
+Version: 0.6-20.2233
 Authors@R: c(person(given   = "Yves", family = "Rosseel",
                     role    = c("aut", "cre"),
                     email   = "[email protected]",

diff --git a/R/lav_predict.R b/R/lav_predict.R
@@ -333,7 +333,7 @@ lav_predict_internal <- function(lavmodel = NULL,
         veta.sqrt <- lav_matrix_symmetric_sqrt(VETA[[g]])
         if (fsm) {
           # change FSM
-          FSM[[g]] <<- veta.sqrt %*% fs.inv.sqrt %*% FSM[[g]]
+          FSM[[g]] <- veta.sqrt %*% fs.inv.sqrt %*% FSM[[g]]
         }
         tmp <- FS.centered %*% fs.inv.sqrt %*% veta.sqrt
         ret <- t(t(tmp) + drop(EETA[[g]]))

diff --git a/R/lav_sam_step1.R b/R/lav_sam_step1.R
@@ -185,6 +185,32 @@ lav_sam_step1 <- function(cmd = "sem", mm.list = NULL, mm.args = list(),
     slotData.block <- lav_data_update_subset(FIT@Data,
       ov.names = ov.names.block
     )
+    # if data.type == "moment", (re)create sample.cov and sample.nobs
+    if (FIT@Data@data.type == "moment") {
+      if (ngroups == 1L) {
+        mm.sample.cov <- lavInspect(FIT, "h1")$cov
+        mm.sample.mean <- NULL
+        if (FIT@Model@meanstructure) {
+          mm.sample.mean <- lavInspect(FIT, "h1")$mean
+        }
+        mm.sample.nobs <- FIT@SampleStats@nobs[[1L]]
+      } else {
+        cov.list <- lapply(lavTech(FIT, "h1", add.labels = TRUE),
+                           "[[", "cov")
+        mm.sample.cov <- lapply(seq_len(ngroups),
+          function(x) cov.list[[x]][ov.names.block[[x]], ov.names.block[[x]]])
+        mm.sample.mean <- NULL
+        if (FIT@Model@meanstructure) {
+          mean.list <- lapply(lavTech(FIT, "h1", add.labels = TRUE),
+                           "[[", "mean")
+          mm.sample.mean <- lapply(seq_len(ngroups),
+            function(x) mean.list[[x]][ov.names.block[[x]]])
+        }
+        mm.sample.nobs <- FIT@SampleStats@nobs
+      }
+    }
+
+
     # handle single block 1-factor CFA with (only) two indicators
     if (length(unlist(ov.names.block)) == 2L && ngroups == 1L) {
       lambda.idx <- which(PTM$op == "=~")
@@ -209,10 +235,20 @@ lav_sam_step1 <- function(cmd = "sem", mm.list = NULL, mm.args = list(),
 
     # fit this measurement model only
     # (question: can we re-use even more slots?)
-    fit.mm.block <- lavaan(
-      model = PTM, slotData = slotData.block,
-      slotOptions = slotOptions.mm, debug = FALSE, verbose = FALSE
-    )
+    if (FIT@Data@data.type == "full") {
+      fit.mm.block <- lavaan(
+        model = PTM, slotData = slotData.block,
+        slotOptions = slotOptions.mm, debug = FALSE, verbose = FALSE
+      )
+    } else if (FIT@Data@data.type == "moment") {
+      slotOptions.mm$sample.cov.rescale <- FALSE
+      fit.mm.block <- lavaan(
+        model = PTM, slotData = slotData.block,
+        sample.cov = mm.sample.cov, sample.mean = mm.sample.mean,
+        sample.nobs = mm.sample.nobs,
+        slotOptions = slotOptions.mm, debug = FALSE, verbose = FALSE
+      )
+    }
 
     # check convergence
     if (!lavInspect(fit.mm.block, "converged")) {

diff --git a/R/xxx_sam.R b/R/xxx_sam.R
@@ -41,10 +41,8 @@
 #                - rename veta.force.pd -> lambda.correction
 #                - move alpha.correction= argument to local.options
 
-# YR 09 Nov 2024 - add cache (list) argument, to re-use information
-#                  from previous runs (assuming the same model, same data
-#                  features)
-
+# YR 09 Nov 2024 - add se = "bootstrap"
+# YR 14 Nov 2024 - add se = "local"
 
 # twostep = wrapper for global sam
 twostep <- function(model = NULL, data = NULL, cmd = "sem",