R/ptable_to_syntax.R

In sfcheung/semhelpinghands: Helper Functions for Structural Equation Modeling

#' @title Convert a 'lavaan' Parameter
#' Table to a 'lavaan' Model Syntax
#'
#' @description It tries to generate a
#' 'lavaan' model syntax from a
#' `lavaan` parameter table.
#'
#' @details
#' This function tries to convert
#' a `lavaan` parameter table to a
#' text representation of the `lavaan`
#' model specified in model syntax.
#'
#' When users call [lavaan::sem()],
#' in addition to the model syntax,
#' other arguments not stored in the
#' syntax are also used to produce
#' the final model (e.g.,
#' `meanstructure`, `fixed.x`, and
#' `std.lv`). To produce exactly the
#' same model, these arguments are also
#' needed to be specified, which is
#' difficult to generate using only
#' the parameter table.
#'
#' Therefore, the model syntax produced
#' will state all aspects of a model
#' explicitly, even for those aspects
#' that usually can be omitted due to
#' the default values of these arguments.
#' This approach requires users to call
#' [lavaan::lavaan()] directly, instead
#' of its wrappers (e.g, [lavaan::sem()]),
#' to produce the same parameter table.
#'
#' The model syntax produced this way
#' is more difficult to read. However,
#' it ensures that original model can
#' be reproduced, without the need to
#' know the arguments to set.
#'
#' Due to the nearly unlimited possibilities
#' in the form of a model, it is
#' recommended to compare the model
#' generated by the model syntax with
#' the original parameter table using
#' [compare_ptables()]. It
#' only compares the forms of the
#' two models, including user starting
#' values, if any. It does not compare
#' parameter estimates and standard
#' errors.
#'
#' ## Raw Specification From `lavaan::lavParseModelString()`
#'
#' There may be cases in which the
#' parameter table is the "incomplete"
#' table generated by [lavaan::lavParseModelString()],
#' with `as.data.frame. = TRUE`.
#' This table is "incomplete" because
#' it is formed merely by parsing the
#' model syntax. There is no guarantee
#' that the model is valid.
#'
#' The function [ptable_to_syntax()]
#' has basic support for this kind
#' of tables but it is disabled by
#' default. To process an incomplete
#' parameter table formed by
#' [lavaan::lavParseModelString()],
#' set `allow_incomplete` to `TRUE`.
#'
#' ## Limitations
#'
#' The function [ptable_to_syntax()]
#' does not yet support the following
#' models:
#'
#' - Multiple-group models.
#'
#' - Multilevel models.
#'
#' - Models with categorical variables.
#'
#' - Models with user-specified lower or
#'   upper bounds.
#'
#' - Models with the operator `<~`.
#'
#' - Models with constraints imposed by
#'   `equal()`.
#'
#' - Models with labels having spaces.
#'
#' - Models with labels having syntax
#'   operators (e.g., `~`, `=~`, etc.).
#'
#'
#' @return
#' [ptable_to_syntax()] returns a
#' length-one character vector that stores
#' the generated `lavaan` model syntax.
#'
#' [compare_ptables()] returns a
#' length-one logical vector. `TRUE`
#' if the two models are identical
#' in form. `FALSE` if they are
#' not identical.
#'
#' @param object If set to a `lavaan`
#' object, such
#' as the output of [lavaan::sem()]
#' or [lavaan::cfa()], the parameter
#' table will be extracted
#' from it by [lavaan::parameterTable()].
#' If set to a parameter table, it will
#' be used to generate the model syntax.
#' It can also the output of
#' [lavaan::lavParseModelString()] with
#' `as.data.frame. = TRUE`, if
#' `allow_incomplete` is set to `TRUE`.
#' Note that `allow_incomplete` is set
#' to `FALSE` by default because
#' [lavaan::lavParseModelString()] only
#' parses the model syntax and there is
#' no guarantee that the model defined
#' is valid.
#'
#' @param allow_incomplete Whether
#' incomplete parameter table formed
#' by [lavaan::lavParseModelString()]
#' with `as.data.frame. = TRUE` is
#' allowed. Default if `FALSE`.
#'
#' @param object1 The first `lavaan`
#' parameter table, to be compared with
#' `object2`. If it is set to a
#' `lavaan` object (e.g., the output
#' of [lavaan::sem()] or
#' [lavaan::cfa()]), then the
#' parameter table will be extracted
#' from it.
#'
#' @param object2 The second `lavaan`
#' parameter table, to be compared with
#' `object1`. If it is set to a
#' `lavaan` object (e.g., the output
#' of [lavaan::sem()] or
#' [lavaan::cfa()]), then the
#' parameter table will be extracted
#' from it.
#'
#' @author Shu Fai Cheung <https://orcid.org/0000-0002-9871-9448>.
#' This function is inspired by
#' a discussion at the Google Group
#' <https://groups.google.com/g/lavaan/c/1ueFiue9qLM/m/cJhxDoqeBAAJ>.
#'
#' @seealso [lavaan::lavaan()], [lavaan::parameterTable()]
#'
#' @examples
#'
#' library(lavaan)
#'
#' mod <-
#' "
#' visual  =~ x3 + x1 + x2
#' textual =~ x4 + x6 + x5
#' speed   =~ x7 + x8 + x9 + start(0.1) * x6
#' visual ~ a*textual
#' speed ~ b*visual
#' ab := a * b
#' "
#'
#' fit <- sem(mod, data = HolzingerSwineford1939)
#'
#' mod_chk <- ptable_to_syntax(fit)
#' cat(mod_chk, sep = "\n")
#' # Need to call lavaan() directly
#' fit_chk <- lavaan(mod_chk, data = HolzingerSwineford1939)
#' fit_chk
#' fit
#' # Compare the parameter table:
#' (ptable1 <- parameterTable(fit))
#' (ptable2 <- parameterTable(fit_chk))
#' compare_ptables(ptable1, ptable2)
#'
#'
#' @describeIn ptable_to_syntax Convert
#' a lavaan parameter a lavaan model
#' syntax.
#' @order 1
#'
#' @export
#'
ptable_to_syntax <- function(object,
                             allow_incomplete = FALSE) {
    if (inherits(object, "lavaan")) {
        if (!ptable_to_syntax_check_fit(object)) {
            stop("The model in 'fit' is not supported.")
          }
        ptable <- lavaan::parameterTable(object)
        is_incomplete <- FALSE
        names_lv <- lavaan::lavNames(object, "lv.regular")
        names_eqs_y <- lavaan::lavNames(object, "eqs.y")
      } else if (inherits(object, "data.frame") &&
                 !inherits(object, "lavaan.data.frame")) {
        if (!allow_incomplete) {
            stop("Object may be an incomplete parameter table ",
                 "but 'allow_incomplete' is FALSE.")
          }
        is_incomplete <- TRUE
        ptable <- object
        if (!ptable_to_syntax_check_inc(ptable)) {
            stop("The model in 'object' is not supported.")
          }
        names_lv <- inc_lavNames_lv_regular(ptable)
        names_eqs_y <- inc_lavNames_eqs_y(ptable)
      } else {
        ptable <- object
        if (!ptable_to_syntax_check_ptable(ptable)) {
            stop("The parameter table in 'object' is not supported.")
          }
        is_incomplete <- FALSE
        names_lv <- pt_lavNames_lv_regular(ptable)
        names_eqs_y <- pt_lavNames_eqs_y(ptable)
      }

    if (is_incomplete) {
        names_def <- inc_lavNames_def(ptable)
      } else {
        names_def <- pt_lavNames_def(ptable)
      }

    # lv
    if (length(names_lv) != 0) {
        out_lv <- sapply(names_lv,
                         mod_ind,
                         ptable = ptable,
                         is_incomplete = is_incomplete)
      } else {
        out_lv <- character(0)
      }

    # y
    if (length(names_eqs_y) != 0) {
        out_y <- sapply(names_eqs_y,
                        mod_y,
                        ptable = ptable,
                        is_incomplete = is_incomplete)

      } else {
        out_y <- character(0)
      }

    # user
    if (length(names_def) != 0) {
        out_def <- sapply(names_def,
                          mod_def,
                          ptable = ptable,
                          is_incomplete = is_incomplete)
      } else {
        out_def <- character(0)
      }

    # constraints
    out_eq <- mod_eq(ptable,
                     is_incomplete = is_incomplete)

    # covariances and variances
    out_cov <- mod_cov(ptable,
                       is_incomplete = is_incomplete)

    # intercepts
    out_int <- mod_int(ptable,
                       is_incomplete = is_incomplete)

    out <- c(out_lv,
             out_y,
             out_def,
             out_eq,
             out_cov,
             out_int)
    out <- paste(out,
                 collapse = "\n")
    out
  }

#' @describeIn ptable_to_syntax Compare two lavaan parameter tables.
#' @order 2
#' @export

compare_ptables <- function(object1,
                            object2) {
    if (inherits(object1, "lavaan")) {
        ptable1 <- lavaan::parameterTable(object1)
      } else {
        ptable1 <- object1
      }
    if (inherits(object2, "lavaan")) {
        ptable2 <- lavaan::parameterTable(object2)
      } else {
        ptable2 <- object2
      }
    c0 <- c("lhs", "op", "rhs",
            "group", "free", "ustart",
            "exo", "label", "start",
            "plabel")
    pt1 <- try(ptable1[, c0],
               silent = TRUE)
    if (inherits(pt1, "try-error")) {
        stop("Check whether object1 is a lavaan object or a parameter table?")
      }
    pt2 <- try(ptable2[, c0],
               silent = TRUE)
    if (inherits(pt2, "try-error")) {
        stop("Check whether object2 is a lavaan object or a parameter table?")
      }
    plabel_match <- match_plabels(pt1, pt2)
    pt2 <- update_plabel(pt2, plabel_match)
    # Check lhs, op, rhs
    tmp1 <- pt1[order(pt1$group,
                      pt1$op, pt1$lhs, pt1$rhs), ]
    tmp2 <- pt2[order(pt2$group,
                      pt2$op, pt2$lhs, pt2$rhs), ]
    rownames(tmp1) <- NULL
    rownames(tmp2) <- NULL
    if (!identical(tmp1[, c("group", "lhs", "op", "rhs")],
                   tmp2[, c("group", "lhs", "op", "rhs")])) {
        return(FALSE)
      }
    if (!identical(tmp1$free > 0,
                   tmp2$free > 0)) {
        return(FALSE)
      }
    if (!identical(tmp1$label,
                   tmp2$label)) {
        return(FALSE)
      }
    if (!identical(tmp1$exo,
                   tmp2$exo)) {
        return(FALSE)
      }
    tmp1u <- tmp1[which(tmp1$ustart > 0), ]
    tmp2u <- tmp2[which(tmp2$ustart > 0), ]
    if (!identical(tmp1u$start,
                   tmp2u$start)) {
        return(FALSE)
      }
    return(TRUE)
  }

#' @noRd

ptable_to_syntax_check_inc <- function(ptable) {
    tmp1 <- strsplit(ptable$fixed, ";")
    tmp2 <- strsplit(ptable$start, ";")
    tmp3 <- strsplit(ptable$label, ";")
    ng <- max(sapply(c(tmp1, tmp2, tmp3), length))
    if (ng > 1) {
        stop("Multigroup models not supported.")
      }
    if (("level" %in% ptable$lhs) ||
        (max(ptable$block) > 1)) {
        stop("Multilevel models not supported.")
      }
    # if (!all(lavaan::lavTech(fit, "nclusters") == 1)) {
    #     stop("Models with clusters not supported.")
    #   }
    if (("|" %in% ptable$op) ||
        ("~*~" %in% ptable$op)) {
        stop("Models with ordinal variables not supported.")
      }
    if ("<~" %in% ptable$op) {
        stop("Models with operator '<~' not supported.")
      }
    ptmp <- ptable
    ptmp$label <- ""
    coef_names <- lavaan::lav_partable_labels(ptmp)
    user_labels <- setdiff(ptable$label, "")
    if (any(user_labels %in% coef_names)) {
        stop("Does not support constraints imposed by 'equal()'.")
      }
    if (any(sapply(ptable$label, any_space))) {
        stop("Does not support labels with spaces.")
      }
    if (any(sapply(ptable$label, any_op))) {
        stop("Does not support labels with syntax operators.")
      }
    TRUE
  }


#' @noRd

ptable_to_syntax_check_fit <- function(fit) {
    if (lavaan::lavTech(fit, "ngroups") != 1) {
        stop("Multigroup models not supported.")
      }
    if (lavaan::lavTech(fit, "nlevels") != 1) {
        stop("Multilevel models not supported.")
      }
    if (!all(lavaan::lavTech(fit, "nclusters") == 1)) {
        stop("Models with clusters not supported.")
      }
    if (length(lavaan::lavNames(fit, "ov.ord")) > 0) {
        stop("Models with ordinal variables not supported.")
      }
    if (any(lavaan::parameterTable(fit)$op == "<~")) {
        stop("Models with operator '<~' not supported.")
      }
    ptable <- lavaan::parameterTable(fit)
    ptmp <- ptable
    ptmp$label <- ""
    coef_names <- lavaan::lav_partable_labels(ptmp)
    user_labels <- setdiff(ptable$label, "")
    if (any(user_labels %in% coef_names)) {
        stop("Does not support constraints imposed by 'equal()'.")
      }
    if (any(sapply(ptable$label, any_space))) {
        stop("Does not support labels with spaces.")
      }
    if (any(sapply(ptable$label, any_op))) {
        stop("Does not support labels with syntax operators.")
      }
    TRUE
  }

#' @noRd

ptable_to_syntax_check_ptable <- function(ptable) {
    if (!is.null(ptable$group)) {
        if (max(ptable$group) != 1) {
            stop("Multigroup models not supported.")
          }
      }
    if (!is.null(ptable$level)) {
        if (max(ptable$level) != 1)
        stop("Multilevel models not supported.")
      }
    # if (!all(lavaan::lavTech(fit, "nclusters") == 1)) {
    #     stop("Models with clusters not supported.")
    #   }
    if ("|" %in% ptable$op) {
        stop("Models with ordinal variables not supported.")
      }
    if ("<~" %in% ptable$op) {
        stop("Models with operator '<~' not supported.")
      }
    ptmp <- ptable
    ptmp$label <- ""
    coef_names <- lavaan::lav_partable_labels(ptmp)
    user_labels <- setdiff(ptable$label, "")
    if (any(user_labels %in% coef_names)) {
        stop("Does not support constraints imposed by 'equal()'.")
      }
    if (any(sapply(ptable$label, any_space))) {
        stop("Does not support labels with spaces.")
      }
    if (any(sapply(ptable$label, any_op))) {
        stop("Does not support labels with syntax operators.")
      }
    TRUE
  }


#' @noRd

match_plabels <- function(pt1, pt2) {
    pt01 <- pt1[pt1$plabel != "",
                c("lhs", "op", "rhs", "group", "plabel")]
    pt02 <- pt2[pt2$plabel != "",
                c("lhs", "op", "rhs", "group", "plabel")]
    tmp <- merge(pt01, pt02,
                 by = c("lhs", "op", "rhs", "group"),
                 suffixes = c(".1", ".2"))
    two2one <- tmp$plabel.1
    names(two2one) <- tmp$plabel.2
    two2one
  }

#' @noRd

update_plabel <- function(pt,
                          target) {
    # TODOs:
    # - Simplify the code
    tmp <- match(pt$lhs, names(target))
    if (any(!is.na(tmp))) {
        pt$lhs[which(!is.na(tmp))] <-
          target[tmp[!is.na(tmp)]]
      }
    tmp <- match(pt$rhs, names(target))
    if (any(!is.na(tmp))) {
        pt$rhs[which(!is.na(tmp))] <-
          target[tmp[!is.na(tmp)]]
      }
    tmp <- match(pt$plabel, names(target))
    if (any(!is.na(tmp))) {
        pt$plabel[which(!is.na(tmp))] <-
          target[tmp[!is.na(tmp)]]
      }
    pt
  }


#' @noRd

mod_int <- function(ptable, is_incomplete) {
    if (missing(is_incomplete)) {
        stop("'is_incomplete' must be set.")
      }
    if (is_incomplete) {
        return(inc_int(ptable = ptable))
      } else {
        return(pt_int(ptable = ptable))
      }
  }


#' @noRd

pt_int <- function(ptable) {
    pt0 <- ptable[(ptable$op == "~1"), , drop = FALSE]
    # Drop intercepts of exogenous variables
    pt0 <- pt0[pt0$exo == 0, ]
    k <- nrow(pt0)
    out0 <- character(0)
    if (k == 0) {
        return(character(0))
      }
    for (i in seq_len(k)) {
        pt_i <- pt0[i, ]
        if (pt_i$free == 0) {
            outi1 <- paste0(pt_i$ustart,
                            "*1")
          } else {
            outi1 <- "1"
          }
        if (pt_i$label != "") {
            outi2 <- paste0(pt_i$label,
                            "*1")
          } else {
            outi2 <- character(0)
          }
        if (!is.na(pt_i$ustart)) {
            outi3 <- paste0("start(",
                            pt_i$ustart,
                            ")*1")
          } else {
            outi3 <- character(0)
          }
        outi <- paste(c(outi1, outi2, outi3),
                      collapse = " + ")
        out0 <- c(out0,
                  paste0(pt_i$lhs,
                         " ~ ",
                         outi))
      }
    out0
  }

#' @noRd

inc_int <- function(ptable) {
    pt0 <- ptable[(ptable$op == "~1"), , drop = FALSE]
    k <- nrow(pt0 > 0)
    out0 <- character(0)
    if (k > 0) {
        for (i in seq_len(k)) {
            pt_i <- pt0[i, ]
            if (pt_i$label != "") {
                outi1 <- paste0(pt_i$label,
                                "*1")
              } else {
                outi1 <- 1
              }
            if (pt_i$start != "") {
                outi2 <- paste0("start(",
                                pt_i$start,
                                ")*1")
              } else {
                outi2 <- character(0)
              }
            if (pt_i$fixed != "") {
                outi3 <- paste0(pt_i$fixed,
                                "*1")
              } else {
                outi3 <- character(0)
              }
            outi <- paste(c(outi1, outi2, outi3),
                          collapse = " + ")
            out0 <- c(out0,
                      paste0(pt_i$lhs,
                            " ~ ",
                            outi))
          }
      } else {
        return(out0)
      }
    out0
  }



#' @noRd

mod_cov <- function(ptable, is_incomplete) {
    if (missing(is_incomplete)) {
        stop("'is_incomplete' must be set.")
      }
    if (is_incomplete) {
        return(inc_cov(ptable = ptable))
      } else {
        return(pt_cov(ptable = ptable))
      }
  }

#' @noRd

pt_cov <- function(ptable) {
    pt0 <- ptable[(ptable$op == "~~"), , drop = FALSE]
    # Drop variances and covariances of exogenous variables
    pt0 <- pt0[pt0$exo == 0, ]
    k <- nrow(pt0)
    out0 <- character(0)
    if (k == 0) {
        return(character(0))
      }
    for (i in seq_len(k)) {
        pt_i <- pt0[i, ]
        if (pt_i$free == 0) {
            outi1 <- paste0(pt_i$ustart,
                            "*",
                            pt_i$rhs)
          } else {
            outi1 <- pt_i$rhs
          }
        if (pt_i$label != "") {
            outi2 <- paste0(pt_i$label,
                            "*",
                            pt_i$rhs)
          } else {
            outi2 <- character(0)
          }
        if (!is.na(pt_i$ustart)) {
            outi3 <- paste0("start(",
                            pt_i$ustart,
                            ")*",
                            pt_i$rhs)
          } else {
            outi3 <- character(0)
          }
        outi <- paste(c(outi1, outi2, outi3),
                      collapse = " + ")
        out0 <- c(out0,
                  paste0(pt_i$lhs,
                         " ~~ ",
                         outi))
      }
    out0
  }


#' @noRd

inc_cov <- function(ptable) {
    pt0 <- ptable[(ptable$op == "~~"), , drop = FALSE]
    k <- nrow(pt0 > 0)
    out0 <- character(0)
    if (k > 0) {
        for (i in seq_len(k)) {
            pt_i <- pt0[i, ]
            if (pt_i$label != "") {
                outi1 <- paste0(pt_i$label,
                                "*",
                                pt_i$rhs)
              } else {
                outi1 <- pt_i$rhs
              }
            if (pt_i$start != "") {
                outi2 <- paste0("start(",
                                pt_i$start,
                                ")*",
                                pt_i$rhs)
              } else {
                outi2 <- character(0)
              }
            if (pt_i$fixed != "") {
                outi3 <- paste0(pt_i$fixed,
                                "*",
                                pt_i$rhs)
              } else {
                outi3 <- character(0)
              }
            outi <- paste(c(outi1, outi2, outi3),
                            collapse = " + ")
            out0 <- c(out0,
                      paste0(pt_i$lhs,
                             " ~~ ",
                             outi))
          }
      } else {
        return(out0)
      }
    out0
  }


#' @noRd

mod_eq <- function(ptable, is_incomplete) {
    if (missing(is_incomplete)) {
        stop("'is_incomplete' must be set.")
      }
    if (is_incomplete) {
        return(inc_eq(ptable = ptable))
      } else {
        return(pt_eq(ptable = ptable))
      }
  }


#' @noRd

pt_eq <- function(ptable) {
    pt0 <- ptable[(ptable$op == "=="), , drop = FALSE]
    plabels <- setdiff(ptable$plabel, "")
    labels <- setdiff(ptable$label, "")
    k <- nrow(pt0)
    out0 <- character(0)
    if (k == 0) {
        return(character(0))
      }
    i1 <- (pt0$lhs %in% plabels) |
          (pt0$rhs %in% plabels)
    i2 <- (pt0$lhs %in% labels) |
          (pt0$rhs %in% labels)
    pt0 <- pt0[!i1 & i2, ]
    k <- nrow(pt0)
    if (k == 0) {
        return(character(0))
      }
    out0 <- c(out0,
              paste(pt0$lhs, pt0$op, pt0$rhs))
    out0
  }


#' @noRd

inc_eq <- function(ptable) {
    con <- attr(ptable, "constraints")
    ops <- sapply(con, function(x) x$op)
    tmp <- ops == "=="
    if (all(!tmp)) {
        return(character(0))
      }
    con <- con[tmp]
    out0 <- sapply(con, function(x) {
        paste(x$lhs, x$op, x$rhs)
      })
    return(out0)
  }


#' @noRd

mod_def <- function(ptable, def, is_incomplete) {
    if (missing(is_incomplete)) {
        stop("'is_incomplete' must be set.")
      }
    if (is_incomplete) {
        return(inc_def(ptable = ptable,
                       def = def))
      } else {
        return(pt_def(ptable = ptable,
                      def = def))
      }
  }

#' @noRd

pt_def <- function(ptable, def) {
    pt0 <- ptable[(ptable$op == ":="), , drop = FALSE]
    k <- nrow(pt0 > 0)
    out0 <- character(0)
    if (k > 0) {
        for (i in seq_len(k)) {
            out0 <- c(out0,
                      paste(pt0[i, "lhs"],
                            ":=",
                            pt0[i, "rhs"]))
          }
      } else {
        return(out0)
      }
    return(out0)
  }

#' @noRd

inc_def <- function(ptable, def) {
    con <- attr(ptable, "constraints")
    ops <- sapply(con, function(x) x$op)
    tmp <- ops == ":="
    if (all(!tmp)) {
        return(character(0))
      }
    con <- con[tmp]
    out0 <- sapply(con, function(x) {
        paste(x$lhs, x$op, x$rhs)
      })
    return(out0)
  }



#' @noRd

mod_y <- function(ptable, eqs_y, is_incomplete) {
    if (missing(is_incomplete)) {
        stop("'is_incomplete' must be set.")
      }
    if (is_incomplete) {
        return(inc_y(ptable = ptable,
                     eqs_y = eqs_y))
      } else {
        return(pt_y(ptable = ptable,
                    eqs_y = eqs_y))
      }
  }


#' @noRd

pt_y <- function(ptable, eqs_y) {
    pt0 <- ptable[(ptable$lhs == eqs_y) &
                  (ptable$op == "~"), , drop = FALSE]
    k <- nrow(pt0 > 0)
    out0 <- character(0)
    if (k > 0) {
        for (i in seq_len(k)) {
            pt_i <- pt0[i, ]
            if (pt_i$free == 0) {
                outi1 <- paste0(pt_i$ustart,
                                "*",
                                pt_i$rhs)
              } else {
                outi1 <- pt_i$rhs
              }
            if (pt_i$label != "") {
                outi2 <- paste0(pt_i$label,
                                "*",
                                pt_i$rhs)
              } else {
                outi2 <- character(0)
              }
            if (!is.na(pt_i$ustart)) {
                outi3 <- paste0("start(",
                                pt_i$ustart,
                                ")*",
                                pt_i$rhs)
              } else {
                outi3 <- character(0)
              }
            outi <- paste(c(outi1, outi2, outi3),
                          collapse = " + ")
            out0 <- c(out0,
                      outi)
          }
      } else {
        return(out0)
      }
    if (length(out0) > 1) {
        out1 <- paste0(out0,
                       collapse = " + ")
      } else {
        out1 <- out0
      }
    out2 <- paste(eqs_y, "~", out1)
    out2
  }


#' @noRd

inc_y <- function(ptable, eqs_y) {
    pt0 <- ptable[(ptable$lhs == eqs_y) &
                  (ptable$op == "~"), , drop = FALSE]
    k <- nrow(pt0 > 0)
    out0 <- character(0)
    if (k > 0) {
        for (i in seq_len(k)) {
            pt_i <- pt0[i, ]
            if (pt_i$label != "") {
                outi1 <- paste0(pt_i$label,
                                "*",
                                pt_i$rhs)
              } else {
                outi1 <- pt_i$rhs
              }
            if (pt_i$start != "") {
                outi2 <- paste0("start(",
                                pt_i$start,
                                ")*",
                                pt_i$rhs)
              } else {
                outi2 <- character(0)
              }
            if (pt_i$fixed != "") {
                outi3 <- paste0(pt_i$fixed,
                                "*",
                                pt_i$rhs)
              } else {
                outi3 <- character(0)
              }
            outi <- paste(c(outi1, outi2, outi3),
                          collapse = " + ")
            out0 <- c(out0,
                      outi)
          }
      } else {
        return(out0)
      }
    if (length(out0) > 1) {
        out1 <- paste0(out0,
                       collapse = " + ")
      } else {
        out1 <- out0
      }
    out2 <- paste(eqs_y, "~", out1)
    out2
  }


#' @noRd

mod_ind <- function(ptable, lv, is_incomplete) {
    if (missing(is_incomplete)) {
        stop("'is_incomplete' must be set.")
      }
    if (is_incomplete) {
        return(inc_ind(ptable = ptable,
                       lv = lv))
      } else {
        return(pt_ind(ptable = ptable,
                      lv = lv))
      }
  }


#' @noRd

pt_ind <- function(ptable, lv) {
    pt0 <- ptable[(ptable$lhs == lv) &
                  (ptable$op == "=~"), , drop = FALSE]
    k <- nrow(pt0 > 0)
    out0 <- character(0)
    if (k > 0) {
        for (i in seq_len(k)) {
            pt_i <- pt0[i, ]
            if (pt_i$free == 0) {
                # Must set to 1 because
                # whether it is 1 depends on
                # the call, if omitted.
                outi1 <- paste0(pt_i$ustart,
                                "*",
                                pt_i$rhs)
              } else {
                outi1 <- pt_i$rhs
              }
            if (pt_i$label != "") {
                outi2 <- paste0(pt_i$label,
                                "*",
                                pt_i$rhs)
              } else {
                outi2 <- character(0)
              }
            if (!is.na(pt_i$ustart) &&
                pt_i$free != 0) {
                outi3 <- paste0("start(",
                                pt_i$ustart,
                                ")*",
                                pt_i$rhs)
              } else {
                outi3 <- character(0)
              }
            outi <- paste(c(outi1, outi2, outi3),
                          collapse = " + ")
            out0 <- c(out0,
                      outi)
          }
      } else {
        return(out0)
      }
    if (length(out0) > 1) {
        out1 <- paste0(out0,
                       collapse = " + ")
      } else {
        out1 <- out0
      }
    out2 <- paste(lv, "=~", out1)
    out2
  }


#' @noRd

inc_ind <- function(ptable, lv) {
    pt0 <- ptable[(ptable$lhs == lv) &
                  (ptable$op == "=~"), , drop = FALSE]
    k <- nrow(pt0 > 0)
    out0 <- character(0)
    if (k > 0) {
        for (i in seq_len(k)) {
            pt_i <- pt0[i, ]
            if (pt_i$label != "") {
                outi1 <- paste0(pt_i$label,
                                "*",
                                pt_i$rhs)
              } else {
                outi1 <- pt_i$rhs
              }
            if (pt_i$start != "") {
                outi2 <- paste0("start(",
                                pt_i$start,
                                ")*",
                                pt_i$rhs)
              } else {
                outi2 <- character(0)
              }
            if (pt_i$fixed != "") {
                outi3 <- paste0(pt_i$fixed,
                                "*",
                                pt_i$rhs)
              } else {
                outi3 <- character(0)
              }
            outi <- paste(c(outi1, outi2, outi3),
                          collapse = " + ")
            out0 <- c(out0,
                      outi)
          }
      } else {
        return(out0)
      }
    if (length(out0) > 1) {
        out1 <- paste0(out0,
                       collapse = " + ")
      } else {
        out1 <- out0
      }
    out2 <- paste(lv, "=~", out1)
    out2
  }


#' @noRd

any_space <- function(x) {
    x1 <- gsub(" ", "", x, fixed = TRUE)
    if (nchar(x1) < nchar(x)) {
        return(TRUE)
      }
    return(FALSE)
  }

#' @noRd

any_op <- function(x) {
    ops <- c("~",
             "=~",
             "|",
             "~*~",
             "<~",
             ":=",
             "==")
    # "~~" will be treated as "~"
    # OK for now.
    chk <- sapply(ops,
                  grepl,
                  x = x,
                  fixed = TRUE)
    if (any(chk)) {
        return(TRUE)
      }
    return(FALSE)
  }

#' @noRd

pt_lavNames_lv_regular <- function(ptable) {
    out0 <- unique(ptable[ptable$op == "=~", "lhs",
                          drop = TRUE])
    out0
  }

#' @noRd

inc_lavNames_lv_regular <- function(ptable) {
    out0 <- unique(ptable[ptable$op == "=~", "lhs",
                          drop = TRUE])
    out0
  }

#' @noRd

pt_lavNames_eqs_y <- function(ptable) {
    out0 <- unique(ptable[ptable$op == "~", "lhs",
                          drop = TRUE])
    out0
  }


#' @noRd

inc_lavNames_eqs_y <- function(ptable) {
    out0 <- unique(ptable[ptable$op == "~", "lhs",
                          drop = TRUE])
    out0
  }

#' @noRd

pt_lavNames_def <- function(ptable) {
    out0 <- unname(ptable[ptable$op == ":=",
                   "lhs", drop = TRUE])
    out0
  }

#' @noRd

inc_lavNames_def <- function(ptable) {
    tmp1 <- attr(ptable, "constraints")
    if (length(tmp1) == 0) {
        return(character(0))
      }
    ops <- sapply(tmp1, function(x) x$op)
    tmp2 <- ops == ":="
    if (all(!tmp2)) {
        return(character(0))
      }
    tmp3 <- tmp1[tmp2]
    out0 <- sapply(tmp3, function(x) x$lhs)
    out0
  }