R/lav_syntax_mlist.R

In lavaan: Latent Variable Analysis

# generate lavaan model syntax from a list of model matrices
#
# YR -- 4 Dec 2021
#
# - currently for a single group/level only
# - continuous setting only; the model matrices are LAMBDA, PSI, THETA and
#   optionally BETA
#
# we return a single string

lav_syntax_mlist <- function(MLIST, ov.prefix = "y", lv.prefix = "f",
                             include.values = TRUE) {
  # model matrices
  LAMBDA <- MLIST$lambda
  THETA <- MLIST$theta
  PSI <- MLIST$psi
  BETA <- MLIST$beta

  # check prefix
  if (ov.prefix == lv.prefix) {
    lav_msg_stop(gettext("ov.prefix can not be the same as lv.prefix"))
  }

  header <- "# syntax generated by lav_syntax_mlist()"

  # LAMBDA
  if (!is.null(LAMBDA)) {
    IDXV <- row(LAMBDA)[(LAMBDA != 0)]
    IDXF <- col(LAMBDA)[(LAMBDA != 0)]
    # lambda.txt <- character(nfactors)
    # for(f in seq_len(nfactors)) {
    #      var.idx <- which(LAMBDA[,f] != 0.0)
    #      lambda.vals <- LAMBDA[var.idx, f]
    #      lambda.txt[f] <- paste( paste0(lv.prefix, f), "=~",
    #                              paste(lambda.vals, "*",
    #                              paste0(ov.prefix, var.idx),
    #                              sep = "", collapse = " + ") )
    # }
    nel <- length(IDXF)
    lambda.txt <- character(nel)
    for (i in seq_len(nel)) {
      if (include.values) {
        lambda.txt[i] <- paste0(
          paste0(lv.prefix, IDXF[i]), " =~ ",
          LAMBDA[IDXV[i], IDXF[i]], "*",
          paste0(ov.prefix, IDXV[i])
        )
      } else {
        lambda.txt[i] <- paste0(
          paste0(lv.prefix, IDXF[i]), " =~ ",
          paste0(ov.prefix, IDXV[i])
        )
      }
    }
  } else {
    lambda.txt <- character(0L)
  }

  # THETA
  if (!is.null(THETA)) {
    IDX1 <- row(THETA)[(THETA != 0) & upper.tri(THETA, diag = TRUE)]
    IDX2 <- col(THETA)[(THETA != 0) & upper.tri(THETA, diag = TRUE)]
    nel <- length(IDX1)
    theta.txt <- character(nel)
    for (i in seq_len(nel)) {
      if (include.values) {
        theta.txt[i] <- paste0(
          paste0(ov.prefix, IDX1[i]), " ~~ ",
          THETA[IDX1[i], IDX2[i]], "*",
          paste0(ov.prefix, IDX2[i])
        )
      } else {
        theta.txt[i] <- paste0(
          paste0(ov.prefix, IDX1[i]), " ~~ ",
          paste0(ov.prefix, IDX2[i])
        )
      }
    }
  } else {
    theta.txt <- character(0L)
  }

  # PSI
  if (!is.null(PSI)) {
    IDX1 <- row(PSI)[(PSI != 0) & upper.tri(PSI, diag = TRUE)]
    IDX2 <- col(PSI)[(PSI != 0) & upper.tri(PSI, diag = TRUE)]
    nel <- length(IDX1)
    psi.txt <- character(nel)
    for (i in seq_len(nel)) {
      if (include.values) {
        psi.txt[i] <- paste0(
          paste0(lv.prefix, IDX1[i]), " ~~ ",
          PSI[IDX1[i], IDX2[i]], "*",
          paste0(lv.prefix, IDX2[i])
        )
      } else {
        psi.txt[i] <- paste0(
          paste0(lv.prefix, IDX1[i]), " ~~ ",
          paste0(lv.prefix, IDX2[i])
        )
      }
    }
  } else {
    psi.txt <- character(0L)
  }

  # BETA
  if (!is.null(BETA)) {
    IDX1 <- row(BETA)[(BETA != 0)]
    IDX2 <- col(BETA)[(BETA != 0)]
    nel <- length(IDX1)
    beta.txt <- character(nel)
    for (i in seq_len(nel)) {
      if (include.values) {
        beta.txt[i] <- paste0(
          paste0(lv.prefix, IDX1[i]), " ~ ",
          BETA[IDX1[i], IDX2[i]], "*",
          paste0(lv.prefix, IDX2[i])
        )
      } else {
        beta.txt[i] <- paste0(
          paste0(lv.prefix, IDX1[i]), " ~ ",
          paste0(lv.prefix, IDX2[i])
        )
      }
    }
  } else {
    beta.txt <- character(0L)
  }

  # assemble
  syntax <- paste(c(header, lambda.txt, theta.txt, psi.txt, beta.txt, ""),
    collapse = "\n"
  )

  syntax
}