use lavaanC in derivative.sigma.LISREL and lav_model_gradient

+ small addition for traces in lavaan
yrosseel · Jan 30, 2025 · 4a45fee · 4a45fee
1 parent 63c4678
commit 4a45fee
Show file tree

Hide file tree

Showing 3 changed files with 30 additions and 9 deletions.
diff --git a/R/lav_model_gradient.R b/R/lav_model_gradient.R
@@ -254,10 +254,13 @@ lav_model_gradient <- function(lavmodel = NULL,
         # full weight matrix
         if (estimator == "GLS" || estimator == "WLS") {
           WLS.V <- lavsamplestats@WLS.V[[g]]
-          group.dx <- -1 * crossprod(
-            Delta[[g]],
-            crossprod(WLS.V, diff)
-          )
+          if (lav_use_lavaanC()) {
+            group.dx <- lavaanC::m_crossprod(Delta[[g]],
+              lavaanC::m_crossprod(WLS.V, -1 * diff, "L"))
+          } else {
+            group.dx <- -1 * crossprod(Delta[[g]],
+                              crossprod(WLS.V, diff))
+          }
         } else if (estimator == "DLS") {
           if (estimator.args$dls.GammaNT == "sample") {
             WLS.V <- lavsamplestats@WLS.V[[g]] # for now

diff --git a/R/lav_representation_lisrel.R b/R/lav_representation_lisrel.R
@@ -2409,7 +2409,7 @@ derivative.sigma.LISREL <- function(m = "lambda",
   # if(m == "lambda" || m == "beta")
   #    IK <- diag(nvar*nvar) + lav_matrix_commutation(nvar, nvar)
   if (m == "lambda" || m == "beta") {
-    L1 <- LAMBDA %*% IB.inv %*% PSI %*% t(IB.inv)
+    L1 <- LAMBDA %*% IB.inv %*% PSI %*% t(IB.inv) # parentheses for performance
   }
   if (m == "beta" || m == "psi") {
     LAMBDA..IB.inv <- LAMBDA %*% IB.inv
@@ -2418,8 +2418,13 @@ derivative.sigma.LISREL <- function(m = "lambda",
   # here we go:
   if (m == "lambda") {
     KOL.idx <- matrix(1:(nvar * nfac), nvar, nfac, byrow = TRUE)[idx]
-    DX <- (L1 %x% diag(nvar))[, idx, drop = FALSE] +
-      (diag(nvar) %x% L1)[, KOL.idx, drop = FALSE]
+    if (lav_use_lavaanC()) {
+      DX <- lavaanC::m_kronecker_diagright_cols(L1, nvar, idx) +
+        lavaanC::m_kronecker_diagleft_cols(L1, nvar, KOL.idx)
+    } else {
+      DX <- (L1 %x% diag(nvar))[, idx, drop = FALSE] +
+        (diag(nvar) %x% L1)[, KOL.idx, drop = FALSE]
+    } 
   } else if (m == "beta") {
     if (composites) {
       DX <- lav_func_jacobian_complex(func = compute.sigma,
@@ -2428,8 +2433,13 @@ derivative.sigma.LISREL <- function(m = "lambda",
       DX <- DX[, idx, drop = FALSE]
     } else {
       KOL.idx <- matrix(1:(nfac * nfac), nfac, nfac, byrow = TRUE)[idx]
-      DX <- (L1 %x% LAMBDA..IB.inv)[, idx, drop = FALSE] +
-        (LAMBDA..IB.inv %x% L1)[, KOL.idx, drop = FALSE]
+      if (lav_use_lavaanC()) {
+        DX <- lavaanC::m_kronecker_cols(L1, LAMBDA..IB.inv, idx) +
+          lavaanC::m_kronecker_cols(LAMBDA..IB.inv, L1, KOL.idx) 
+      } else  {
+        DX <- (L1 %x% LAMBDA..IB.inv)[, idx, drop = FALSE] +
+          (LAMBDA..IB.inv %x% L1)[, KOL.idx, drop = FALSE]
+      }
       # this is not really needed (because we select idx=m.el.idx)
       # but just in case we need all elements of beta...
       DX[, which(idx %in% lav_matrix_diag_idx(nfac))] <- 0.0

diff --git a/R/ldw_trace.R b/R/ldw_trace.R
@@ -34,6 +34,14 @@ if (!exists("lavaan_cache_env")) lavaan_cache_env <- new.env(parent = emptyenv()
 # lavaan:::print_trace("PolDem_trace.txt")
 #
 
+ldw_matrix_info <- function(matrixje) {
+  ll <- length(matrixje)
+  nul <- sum(matrixje == 0)
+  som <- sum(matrixje)
+  paste(paste(dim(matrixje), collapse = " x "), ", splvl:", 100 * nul / ll,
+        ", som:", som)
+}
+
 ldw_trace <- function(content = "") {
   ignore.in.stack <- c(
     "eval", "try", "tryCatch", "tryCatchList", "tryCatchOne", "doTryCatch",