R/model_partable_utils.R

In plssem: Complex Partial Least Squares Structural Equation Modeling

getIntTerms <- function(parTable, col = "rhs") {
  cond1 <- grepl(":", parTable[[col]])
  cond2 <- !grepl("~|\\(|\\)\\|", parTable[[col]])
  cond3 <- parTable$op == "~"

  unique(parTable[cond1 & cond2 & cond3, col])
}


checkLhsIntTerms <- function(parTable) {
  bad <- getIntTerms(parTable, col = "lhs")
  pls_stopif(length(bad),
    "Interaction terms can (currently) not be treated as dependent variables!",
    "Independent variable interaction terms:", paste0(bad, collapse = ", ")
  )
}


getReflectiveLVs <- function(parTable) {
  unique(parTable[parTable$op == "=~", "lhs"])
}


getFormativeLVs <- function(parTable) {
  unique(parTable[parTable$op == "<~", "lhs"])
}


getLVs <- function(parTable) {
  # reflective <- getReflectiveLVs(parTable)
  # formative  <- getFormativeLVs(parTable)
  # Don't get reflective and formative constructs seperately,
  # as we want to keep the sorting in the partable
  unique(parTable[parTable$op %in% c("<~", "=~"), "lhs"])
}


getIndicators <- function(parTable, observed = TRUE, op = c("=~", "<~")) {
  indicators <- unique(parTable[parTable$op %in% op, "rhs"])

  if (observed) indicators <- indicators[!indicators %in% getLVs(parTable)]
  indicators
}


getReflectiveIndicators <- function(..., op = "=~") {
  getIndicators(..., op = op)
}


# Variables explicitly declared as path-less structural nodes (e.g. `x ~ 1`).
getDeclaredStructVars <- function(parTable) {
  unique(parTable[parTable$op == ADDITIONAL_STRUCT_VAR_OP, "lhs"])
}


getOVs <- function(parTable) {
  lVs    <- getLVs(parTable)
  select <- parTable$op %in% c("=~", "~", "~~", "<~")
  vars   <- unique(c(parTable$lhs[select], parTable$rhs[select],
                     getDeclaredStructVars(parTable)))

  vars[!vars %in% lVs & !grepl(":", vars)]
}


getStructVars <- function(parTable) {
  struct <- parTable[parTable$op == "~", , drop = FALSE]
  unique(c(struct$lhs, struct$rhs, getDeclaredStructVars(parTable)))
}


getStructOVs <- function(parTable) {
  intersect(getStructVars(parTable), getOVs(parTable))
}


getEtas <- function(parTable, isLV = FALSE, checkAny = TRUE) {
  lVs <- getLVs(parTable)

  cond.lhs <- parTable$op == "~"
  cond.rhs <- parTable$op %in% c("=~", "<~") & parTable$rhs %in% lVs

  if (isLV) cond.lhs <- cond.lhs & parTable$lhs %in% lVs

  etas.lhs <- parTable[cond.lhs, "lhs"]
  etas.rhs <- parTable[cond.rhs, "rhs"]

  etas <- unique(c(etas.rhs, etas.lhs))
  pls_stopif(checkAny && !length(etas), "No etas found")

  etas
}


getSortedEtas <- function(parTable, isLV = FALSE, checkAny = TRUE) {
  unsortedEtas <- getEtas(parTable, isLV = isLV, checkAny = checkAny)

  cond1 <- parTable$op == "~"
  cond2 <- parTable$op %in% c("=~", "<~") & parTable$rhs %in% unsortedEtas

  structExprs <- parTable[cond1, , drop = FALSE]
  measrExprs  <- parTable[cond2, , drop = FALSE]

  if (NROW(measrExprs)) {
    measr2struct <- measrExprs
    measr2struct$lhs <- measrExprs$rhs
    measr2struct$op  <- "~"
    measr2struct$rhs <- measrExprs$lhs

    structExprs <- rbind(structExprs, measr2struct)
  }

  sortedEtas  <- character(0L)

  while (length(sortedEtas) < length(unsortedEtas) && nrow(structExprs) > 0) {
    pls_stopif(all(unique(structExprs$lhs) %in% structExprs$rhs), "Model is non-recursive")

    for (i in seq_len(nrow(structExprs))) {
      if ((eta <- structExprs[i, "lhs"]) %in% structExprs$rhs) next

      sortedEtas  <- c(eta, sortedEtas)
      structExprs <- structExprs[structExprs$lhs != eta, , drop = FALSE]
      break
    }
  }

  if (!all(unsortedEtas %in% sortedEtas) ||
      length(sortedEtas) != length(unsortedEtas)) {
      pls_msg_warn("unable to sort etas")
      return(unsortedEtas)
  }

  sortedEtas
}


getXis <- function(parTable, etas = NULL, isLV = TRUE, checkAny = TRUE) {
  if (is.null(etas)) etas <- getEtas(parTable, isLV = isLV)
  # add all LVs which are not etas
  xis <- unique(parTable[parTable$op %in% c("=~", "<~") & !parTable$lhs %in% etas, "lhs"])

  if (!isLV) { # add any other variabels found in structural expressions
    xis <- unique(c(xis, parTable[parTable$op == "~" &
                                  !parTable$rhs %in% etas, "rhs"]))
  }

  xis <- xis[!grepl(":", xis)] # remove interaction terms

  pls_stopif(checkAny && !length(xis), "No xis found")
  xis
}


getRandomEffectLabels <- function(parTable) {
  lhs <- parTable$lhs
  op  <- parTable$op
  rhs <- parTable$rhs

  rlhs <- lhs[grepl("~", lhs) & op == "~~"]
  rrhs <- rhs[grepl("~", rhs) & op == "~~"]

  union(rlhs, rrhs)
}


getIndsLVs <- function(parTable, lVs, isOV = FALSE, ovs = NULL) {
  if (!length(lVs)) return(NULL)

  measr <- parTable[parTable$op %in% c("=~", "<~") & parTable$lhs %in% lVs, ]
  pls_stopif(!NROW(measr), paste0("No measurement expressions found, for", lVs))

  if (isOV) {
    if (is.null(ovs)) ovs <- getOVs(parTable)
    measr <- measr[measr$rhs %in% ovs, , drop = FALSE]
  }

  split <- split(measr$rhs, measr$lhs)
  split[vapply(split, FUN.VALUE = integer(1L), FUN = length) > 0L]
}


getHigherOrderLVs <- function(parTable) {
  lvs <- getLVs(parTable)
  cond <- parTable$op %in% c("=~", "<~") & parTable$rhs %in% lvs
  unique(parTable[cond, "lhs"])
}


getParTableFromParNames <- function(parnames) {
  split <- splitParameterNames(parnames)
  data.frame(lhs = split$lhs, op = split$op, rhs = split$rhs, stringsAsFactors = FALSE)
}


getParNamesFromParTable <- function(parTable) {
  paste0(parTable$lhs, parTable$op, parTable$rhs)
}


hasResidualCovariances <- function(parTable) {
  etas <- unique(parTable[parTable$op == "~", "lhs"])

  any(
    parTable$op == "~~" &
    (parTable$rhs %in% etas | parTable$lhs %in% etas) &
    parTable$lhs != parTable$rhs
  )
}


addReverseCovariancesToParTable <- function(parTable) {
  # The covariance x~~y can be specified as y~~x. If the user supplies
  # important information to one of these (e.g., y ~~ start(0.1) * x)
  # there is a risk that we internally represent the covariance as the opposite
  # (e.g., x~~y). To address this, we can add both directions to the parTable
  is.cov <- parTable$op == "~~" & parTable$lhs != parTable$rhs

  if (!any(is.cov))
    return(parTable)

  parTableCov <- parTable[is.cov, , drop = FALSE]
  parTableCov$lhs <- parTable[is.cov, "rhs"]
  parTableCov$rhs <- parTable[is.cov, "lhs"]

  rbind(parTable, parTableCov)
}


parTableInputRows <- function(lhs = "", op = "", rhs = "", mod = "",
                              label = "", start = NA_real_) {
  data.frame(
    lhs   = lhs,
    op    = op,
    rhs   = rhs,
    mod   = mod,
    label = label,
    start = start
  )
}