R/model_partable.R

In plssem: Complex Partial Least Squares Structural Equation Modeling

CI_QUANTILE <- stats::qnorm(0.975)


getParTableEstimates <- function(model,
                                 rm.tmp.ov = TRUE,
                                 clean.tmp.ind = TRUE,
                                 clean.tmp.mimic = TRUE) {
  est    <- model@params$values
  se     <- model@params$se
  labels <- model@params$labels
  names  <- names(est)

  split    <- splitParameterNames(names)
  lhs      <- split$lhs
  op       <- split$op
  rhs      <- split$rhs
  label    <- fillna(labels[names], "")

  parTable <- addZStatsParTable(data.frame(
    lhs      = lhs,
    op       = op,
    rhs      = rhs,
    label    = label,
    est      = est,
    se       = se
  ))

  if (rm.tmp.ov)
    parTable <- removeTempOvRowsParTable(parTable)

  if (clean.tmp.ind)
    parTable <- cleanTempIndRowsParTable(parTable)

  if (clean.tmp.mimic)
    parTable <- cleanTempMimicRowsParTable(parTable)

  plssemParTable(parTable)
}


parTableToParams <- function(parTable) {
  lhs <- parTable$lhs
  op  <- parTable$op
  rhs <- parTable$rhs
  est <- parTable$est
  se  <- parTable$se

  k      <- NROW(parTable)
  names  <- paste0(lhs, op, rhs)
  values <- stats::setNames(est, nm = names)

  list(
    names      = names,
    values     = values,
    se         = se,
    vcov       = NULL
  )
}


splitParameterNames <- function(names) {
  hasBeenSplit <- logical(length(names))

  lhs <- rep(NA_character_, length(names))
  op  <- rep(NA_character_, length(names))
  rhs <- rep(NA_character_, length(names))

  for (OP in OPERATORS) { # go by precedence
    split <- stringr::str_split_fixed(names, pattern = stringr::coll(OP), n = 2L)
    success <- stringr::str_detect(names, pattern = stringr::coll(OP))

    replace <- !hasBeenSplit & success
    hasBeenSplit <- hasBeenSplit | success

    lhs[replace] <- split[replace, 1L]
    rhs[replace] <- split[replace, 2L]
    op[replace]  <- OP
  }

  list(lhs = lhs, op = op, rhs = rhs)
}


removeTempOvRowsParTable <- function(parTable, clean.thr = TRUE) {

  if (clean.thr) {
    is.thr <- parTable$op == "|"
    parTable$lhs[is.thr] <- removeTempOvPrefix(parTable$lhs[is.thr])
    parTable$rhs[is.thr] <- removeTempOvPrefix(parTable$rhs[is.thr])
  }

  tmp <- hasTempOvPrefix(parTable$lhs) | hasTempOvPrefix(parTable$rhs)
  parTable[!tmp, , drop = FALSE]
}


cleanTempIndRowsParTable <- function(parTable) {
  rhs <- unique(parTable$rhs) # Only injected into the rhs column
  tmp <- rhs[hasTempIndSuffix(rhs)]
  cln <- removeTempIndSuffix(tmp)

  # We should remove any (co-)variances which are non-residuals, as it by
  # definition is an endogenous variable in the model
  parTable <- parTable[
    !((parTable$lhs %in% cln | parTable$rhs %in% cln) & parTable$op == "~~"),
    , drop = FALSE
  ]

  # Thresholds are properties of the original observed indicator. Internal
  # copies of a duplicated indicator must not create duplicate public rows.
  is.threshold <- parTable$op == "|"
  is.tmp.threshold <- is.threshold & (
    hasTempIndSuffix(parTable$lhs) | hasTempIndSuffix(parTable$rhs)
  )
  threshold.key <- paste(
    removeTempIndSuffix(parTable$lhs),
    parTable$op,
    removeTempIndSuffix(parTable$rhs),
    sep = "\r"
  )

  drop.threshold <- logical(NROW(parTable))
  for (key in unique(threshold.key[is.tmp.threshold])) {
    idx <- which(is.threshold & threshold.key == key)
    keep <- idx[!is.tmp.threshold[idx]]
    keep <- if (length(keep)) keep[[1L]] else idx[[1L]]
    drop.threshold[setdiff(idx, keep)] <- TRUE
  }
  parTable <- parTable[!drop.threshold, , drop = FALSE]

  parTable$rhs <- removeTempIndSuffix(parTable$rhs)
  parTable$lhs <- removeTempIndSuffix(parTable$lhs)

  parTable
}


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

  idx <- which(hasTempMimicSuffix(lhs) & op == "~")

  # redefine
  parTable[idx, "lhs"] <- rhs[idx]
  parTable[idx, "op"]  <- "=~"
  parTable[idx, "rhs"] <- lhs[idx]

  # clean
  parTable$lhs <- removeTempMimicSuffix(parTable$lhs)
  parTable$rhs <- removeTempMimicSuffix(parTable$rhs)

  parTable
}


addColonPI_ParTable <- function(parTable, model, label.renamed.prod = FALSE) {
  elems <- model@info$intTermElems

  if (length(elems) && !"label" %in% colnames(parTable))
    parTable$label <- ""

  if (label.renamed.prod)
    origLabels <- getParTableLabels(parTable, labelCol = "label")
  else
    origLabels <- parTable$label

  for (xz in names(elems)) {
    xzColon <- paste0(elems[[xz]], collapse = ":")
    rmatch <- parTable$rhs == xz
    lmatch <- parTable$lhs == xz

    parTable[rmatch | lmatch, "label"] <- origLabels[rmatch | lmatch]

    parTable[rmatch, "rhs"] <- xzColon
    parTable[lmatch, "lhs"] <- xzColon # shouldn't be necessary, but just in case
                                       # the user has done something weird...
  }

  parTable
}


addZStatsParTable <- function(parTable) {
  lhs      <- parTable$lhs
  op       <- parTable$op
  rhs      <- parTable$rhs
  est      <- parTable$est
  se       <- parTable$se
  label    <- parTable$label

  z        <- est / se
  pvalue   <- 2 * stats::pnorm(-abs(z))
  ci.lower <- est - CI_QUANTILE * se
  ci.upper <- est + CI_QUANTILE * se

  data.frame(
    lhs      = lhs,
    op       = op,
    rhs      = rhs,
    label    = label,
    est      = est,
    se       = se,
    z        = z,
    pvalue   = pvalue,
    ci.lower = ci.lower,
    ci.upper = ci.upper
  )
}