further work on Composites (not finished)

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: lavaan
 Title: Latent Variable Analysis
-Version: 0.6-20.2259
+Version: 0.6-20.2260
 Authors@R: c(person(given   = "Yves", family = "Rosseel",
                     role    = c("aut", "cre"),
                     email   = "[email protected]",
@@ -61,7 +61,6 @@ Description: Fit a variety of latent variable models, including confirmatory
 Depends: R(>= 3.4)
 Imports: methods, stats4, stats, utils, graphics, MASS,
          mnormt, pbivnorm, numDeriv, quadprog
-Suggests: lavaanC
 BugReports: https://github.com/yrosseel/lavaan/issues
 License: GPL (>= 2)
 LazyData: yes

R/lav_lavaan_step09_model.R

@@ -74,6 +74,16 @@ lav_lavaan_step09_model <- function(slotModel = NULL, # nolint
           }
         }
       }
+
+    # same for composites: call lav_model_set_parameters once to set
+    # total/residual variances of composites in PSI
+    } else if (lavmodel@composites) {
+      lavmodel <- lav_model_set_parameters(
+        lavmodel = lavmodel,
+        x = lav_model_get_parameters(lavmodel)
+      )
+      # re-adjust parameter table
+      lavpartable$start <- lav_model_get_parameters(lavmodel, type = "user")
     }
     if (lav_verbose()) {
       cat(" done.\n")

R/lav_lavaan_step11_optim.R

@@ -280,7 +280,7 @@ lav_lavaan_step11_estoptim <- function(lavdata = NULL, # nolint
 
     # if a warning was produced, say it here
     warn.txt <- attr(x, "warn.txt")
-    if (nchar(warn.txt) > 0L) {
+    if (!is.null(warn.txt) && nchar(warn.txt) > 0L) {
       lav_msg_warn(
         gettext("Model estimation FAILED! Returning starting values."))
     }

R/lav_model.R

@@ -356,6 +356,13 @@ lav_model <- function(lavpartable = NULL,                          # nolint
       names(ov.efa.idx[[g]]) <- efa.values
       names(lv.efa.idx[[g]]) <- efa.values
     } # efa
+
+    # set variances composites (new in 0.6-20)
+    if (composites) {
+      mm.in.group <- 1:nmat[g] + cumsum(c(0L, nmat))[g]
+      tmp.glist[mm.in.group] <-
+        setVarianceComposites.LISREL(tmp.glist[mm.in.group])
+    }
   } # g
 
   # fixed.x parameters?

R/lav_model_estimate.R

@@ -503,7 +503,7 @@ lav_model_estimate <- function(lavmodel = NULL,
         attr(fx, "fx.group") <- rep(as.numeric(NA), ngroups)
         attr(x, "converged") <- FALSE
         attr(x, "iterations") <- 0L
-        attr(x, "control") <- lavoptions@control
+        attr(x, "control") <- lavoptions$control
         attr(x, "fx") <- fx
         return(x)
       }

R/lav_partable_flat.R

@@ -38,7 +38,7 @@ lav_partable_flat <- function(FLAT = NULL, # nolint
   lv.names <- lav_partable_vnames(FLAT, type = "lv") # latent variables
   # lv.names.r   <- lav_partable_vnames(FLAT, type="lv.regular")
   # regular latent variables
-  if (composites ) {
+  if (composites) {
     lv.names.f <- character(0L)
     lv.names.c <- lav_partable_vnames(FLAT, type = "lv.composite")
     ov.ind.c <- lav_partable_vnames(FLAT, type = "ov.cind")
@@ -222,8 +222,8 @@ lav_partable_flat <- function(FLAT = NULL, # nolint
   # auto-remove ordinal variables
   # idx <- match(ov.names.ord, ov.var)
   # if(length(idx)) ov.var <- ov.var[-idx]
-  lhs <- c(lhs, ov.var, lv.names.noc)
-  rhs <- c(rhs, ov.var, lv.names.noc)
+  lhs <- c(lhs, ov.var, lv.names)
+  rhs <- c(rhs, ov.var, lv.names)
   # }
 
   # b) `independent` latent variable COVARIANCES (lv.names.x)
@@ -480,6 +480,15 @@ lav_partable_flat <- function(FLAT = NULL, # nolint
     free[var.idx] <- 0L
   }
 
+  # 0d. variances for composites: ALWAYS fixed (should be set later
+  #     by setVarianceComposites.LISREL
+  if (length(lv.names.c) > 0) {
+    var.idx <- which(op == "~~" & lhs %in% lv.names.c & lhs == rhs)
+    ustart[var.idx] <- as.numeric(NA)
+    free[var.idx] <- 0L
+  }
+
+
   # 1. fix metric of regular latent variables
   if (std.lv) {
     # fix metric by fixing the variance of the latent variable

R/lav_partable_utils.R

@@ -107,6 +107,7 @@ lav_partable_ndat <- function(partable) {
   fixed.x <- any(partable$exo > 0L & partable$free == 0L)
   conditional.x <- any(partable$exo > 0L & partable$op == "~")
   categorical <- any(partable$op == "|")
+  composites <- any(partable$op == "<~")
   correlation <- any(partable$op == "~*~")
   if (categorical) {
     meanstructure <- TRUE
@@ -176,6 +177,16 @@ lav_partable_ndat <- function(partable) {
       ndat[b] <- ndat[b] - pstar.x
     }
 
+    # composites?
+    if (composites) {
+      ov.cind <- lav_partable_vnames(partable, "ov.cind", block = b)
+      covar.idx <- which(partable$op == "~~" &
+                         partable$lhs %in% ov.cind &
+                         partable$rhs %in% ov.cind &
+                         partable$free == 0L)
+      ndat[b] <- ndat[b] - length(covar.idx)
+    }
+
     # correction for ordinal data?
     if (categorical) {
       ov.names.x <- lav_partable_vnames(partable, "ov.x", block = b)

R/lav_simulate_old.R

@@ -14,6 +14,7 @@ simulateData <- function( # user-specified model
                          int.lv.free = FALSE,
                          marker.int.zero = FALSE,
                          conditional.x = FALSE,
+                         composites = TRUE,
                          fixed.x = FALSE,
                          orthogonal = FALSE,
                          std.lv = TRUE,
@@ -72,6 +73,7 @@ simulateData <- function( # user-specified model
       int.ov.free = int.ov.free,
       int.lv.free = int.lv.free,
       marker.int.zero = marker.int.zero,
+      composites = composites,
       conditional.x = conditional.x,
       fixed.x = fixed.x,
       orthogonal = orthogonal,
@@ -154,11 +156,13 @@ simulateData <- function( # user-specified model
         "if residual variances are specified, please use standardized=FALSE"))
     }
 
-    # new in 0.6-20: use setResidualElements.LISREL
+    # new in 0.6-20: - use setResidualElements.LISREL
+    #                - use setVarianceComposites.LISREL
     dotdotdot <- list(...)
     dotdotdot$sample.nobs <- sample.nobs
     dotdotdot$fixed.x <- FALSE # for now
     dotdotdot$representation <- "LISREL"
+    dotdotdot$composites <- composites
     dotdotdot$correlation <- TRUE # this is the trick
     tmp.fit <- do.call("lavaan", args = c(list(model = lav), dotdotdot))
     # set/get parameters to invoke setResidualElements.LISREL

R/lav_start.R

@@ -68,6 +68,7 @@ lav_start <- function(start.method = "default",
       start <- numeric(length(lavpartable$ustart))
       # if(categorical || correlation) {
       start[which(lavpartable$op == "=~")] <- 0.7
+      start[which(lavpartable$op == "<~")] <- 1
       # } else {
       #    start[ which(lavpartable$op == "=~") ] <- 1.0
       # }
@@ -182,6 +183,7 @@ lav_start <- function(start.method = "default",
     lv.names.efa <- vnames(lavpartable, "lv.efa", group = group.values[g])
     ov.names.x <- vnames(lavpartable, "ov.x", group = group.values[g])
     ov.ind.c <- vnames(lavpartable, "ov.cind", group = group.values[g])
+    lv.names.c <- vnames(lavpartable, "lv.composite", group = group.values[g])
 
     # just for the nlevels >1 case
     ov.names <- unique(unlist(ov.names))
@@ -190,7 +192,8 @@ lav_start <- function(start.method = "default",
     lv.names.efa <- unique(unlist(lv.names.efa))
     ov.names.x <- unique(unlist(ov.names.x))
     ov.ind.c <- unique(unlist(ov.ind.c))
-
+    lv.names.c <- unique(unlist(lv.names.c))
+    lv.names.noc <- lv.names[!lv.names %in% lv.names.c]
 
     # residual ov variances (including exo/ind, to be overriden)
     ov.var.idx <- which(lavpartable$group == group.values[g] &
@@ -235,7 +238,7 @@ lav_start <- function(start.method = "default",
     if (start.initial %in% c("lavaan", "mplus") &&
       model.type %in% c("sem", "cfa")) {
       # fabin3 estimator (2sls) of Hagglund (1982) per factor
-      for (f in lv.names) {
+      for (f in lv.names.noc) {
         # not for efa factors
         if (f %in% lv.names.efa) {
           next