[composites] correctly rescale model-implied covariance matrix

yrosseel · Jan 28, 2025 · 63c4678 · 63c4678
1 parent 3a06697
commit 63c4678
Show file tree

Hide file tree

Showing 3 changed files with 19 additions and 5 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: lavaan
 Title: Latent Variable Analysis
-Version: 0.6-20.2261
+Version: 0.6-20.2262
 Authors@R: c(person(given   = "Yves", family = "Rosseel",
                     role    = c("aut", "cre"),
                     email   = "Yves.Rosseel@UGent.be",

diff --git a/R/lav_representation_lisrel.R b/R/lav_representation_lisrel.R
@@ -1105,10 +1105,19 @@ computeVYx.LISREL <- computeSigmaHat.LISREL <- function(MLIST = NULL,
                            function(x) sum(x == 0) == ncol(LAMBDA)))
     clv.idx <- which(apply(LAMBDA, 2L,
                            function(x) sum(x == 0) == nrow(LAMBDA)))
+    # regular latent variables
+    rlv.idx <- seq_len(ncol(LAMBDA))[-clv.idx]
+
+    # combine LAMBDA and WMAT
+    LW <- LAMBDA + WMAT
+
     Tmat <- diag(nrow(LAMBDA))
     Tmat[cov.idx, cov.idx] <- THETA[cov.idx, cov.idx]
+    wtw <- t(LW[,clv.idx, drop = FALSE]) %*% Tmat %*% LW[,clv.idx, drop = FALSE]
+    wtw.inv <- solve(wtw)
+    WTW.inv <- diag(ncol(LAMBDA))
+    WTW.inv[clv.idx, clv.idx] <- wtw.inv
 
-    LambdaWmat <- LAMBDA + WMAT
     if (is.null(BETA)) {
       IB.inv <- diag(nrow(PSI))
     } else {
@@ -1117,7 +1126,7 @@ computeVYx.LISREL <- computeSigmaHat.LISREL <- function(MLIST = NULL,
     VETA <- IB.inv %*% PSI %*% t(IB.inv)
     C0 <- VETA; diag(C0)[clv.idx] <- 0
 
-    VYx <- Tmat %*% LambdaWmat %*% C0 %*% t(LambdaWmat) %*% Tmat + THETA
+    VYx <- Tmat %*% LW %*% WTW.inv %*% C0 %*% t(WTW.inv) %*% t(LW) %*% Tmat + THETA
   }
 
   # if delta, scale

diff --git a/R/lav_start.R b/R/lav_start.R
@@ -463,8 +463,8 @@ lav_start <- function(start.method = "default",
         lavpartable$op == "~~" &
         lavpartable$rhs %in% ov.ind.c &
         lavpartable$lhs != lavpartable$rhs)
-      lhs.idx <- match(lavpartable$lhs[cov.idx], ov.ind.c)
-      rhs.idx <- match(lavpartable$rhs[cov.idx], ov.ind.c)
+      lhs.idx <- match(lavpartable$lhs[cov.idx], ov.names)
+      rhs.idx <- match(lavpartable$rhs[cov.idx], ov.names)
       if (!is.null(lavsamplestats@missing.h1[[g]])) {
         start[cov.idx] <- lavsamplestats@missing.h1[[g]]$sigma[
           cbind(lhs.idx, rhs.idx)
@@ -984,14 +984,19 @@ lav_start <- function(start.method = "default",
 # StartingValues <- lav_start
 
 # sanity check: (user-specified) variances smaller than covariances
+# but not for composites, as we have not 'set' their variances yet
 lav_start_check_cov <- function(lavpartable = NULL, start = lavpartable$start) {
   nblocks <- lav_partable_nblocks(lavpartable)
   block.values <- lav_partable_block_values(lavpartable)
 
   for (g in 1:nblocks) {
+
+    lv.names.c <- lav_partable_vnames(lavpartable, "lv.composite", block = g)
+
     # collect all non-zero covariances
     cov.idx <- which(lavpartable$op == "~~" &
       lavpartable$block == block.values[g] &
+      !lavpartable$lhs %in% lv.names.c &
       lavpartable$lhs != lavpartable$rhs &
       !lavpartable$exo &
       start != 0)