R/print_est_change.R

In semfindr: Influential Cases in Structural Equation Modeling

#' @title Print an 'est_change' Class Object
#'
#' @description Print the content of an 'est_change'-class object.
#'
#' @details All the functions on case influence
#' on parameter estimates, [est_change()],
#' [est_change_approx()], [est_change_raw()],
#' and [est_change_raw_approx()], return
#' an `est_change`-class object. This method will print
#' the output based on the type of changes and method
#' used.
#'
#' @return
#'  `x` is returned invisibly. Called for its side effect.
#'
#' @param x An 'est_change'-class object.
#'
#' @param digits The number of digits after the decimal.
#' Default is 3.
#'
#' @param first Numeric. If not `NULL`, it prints
#' only the first *k* cases, *k* equal to `first`.
#' Default is 10.
#'
#' @param sort_by String. Should be `"est"`, `"gcd"`,
#' or `NULL`.
#' If the output was generated
#' by [est_change_raw()]
#' or [est_change_raw_approx()] and `sort_by` is
#' not `NULL`, then
#' each column is sorted individually, with case IDs inserted
#' before each column. If the output was generated by
#' [est_change()] or [est_change_approx()] and `sort_by`
#' is not `NULL`, then `sort_by` determines how the cases are sorted.
#' If `by` is `"est"`, the cases are sorted as for
#' the output of [est_change_raw()]. If `by` is `"gcd"`,
#' the default for the output of [est_change()] or
#' [est_change_approx()],
#' then cases are sorted by generalized Cook's distance
#' or approximate generalized Cook's distance, depending on
#' which column is available.
#'
#' @param ... Other arguments. They will be ignored.
#'
#' @seealso [est_change_raw()], [est_change_raw_approx()],
#' [est_change()], [est_change_approx()]
#'
#' @examples
#'
#' library(lavaan)
#'
#' # A path model
#'
#' dat <- pa_dat
#' mod <-
#' "
#' m1 ~ a1 * iv1 + a2 * iv2
#' dv ~ b * m1
#' a1b := a1 * b
#' a2b := a2 * b
#' "
#' # Fit the model
#' fit <- lavaan::sem(mod, dat)
#' summary(fit)
#'
#' # Approximate case influence
#' out <- est_change_approx(fit)
#' out
#' print(out, sort_by = "est")
#' out <- est_change_raw_approx(fit)
#' print(out, first = 3)
#'
#' # Examine four selected cases
#' fit_rerun <- lavaan_rerun(fit, parallel = FALSE,
#'                           to_rerun = c(2, 3, 5, 7))
#' est_change(fit_rerun)
#' est_change_raw(fit_rerun)
#'
#' @export

print.est_change <- function(x,
                             digits = 3,
                             first = 10,
                             sort_by = c("gcd", "est"),
                             ...) {
    if (is.null(first)) {
        first <- nrow(x)
      }
    first <- min(nrow(x), first)
    i <- seq_len(first)
    est_change_type <- attr(x, "change_type")
    est_method <- attr(x, "method")
    est_call <- attr(x, "call")
    est_std <- attr(x, "standardized")
    is_user <- isTRUE(attr(x, "user_function"))
    call_name <- as.character(est_call[[1]])
    sort_by <- match.arg(sort_by)
    if (is.null(sort_by)) {
        sort <- FALSE
        by <- NULL
      } else {
        sort <- TRUE
        by <- sort_by
      }
    if (!identical(est_change_type, "standardized")) {
        by <- "est"
      }
    gcd_name <- switch(call_name,
                       est_change_raw = NULL,
                       est_change_raw_approx = NULL,
                       est_change = "gcd",
                       est_change_approx = "gcd_approx")
    if (!is.null(gcd_name)) {
        gcd_name2 <- switch(gcd_name,
                            gcd = "generalized Cook's distance",
                            gcd_approx = "approximate generalized Cook's distance")
      } else {
        gcd_name2 <- NULL
      }
    pnames <- switch(est_change_type,
                     raw = colnames(x),
                     standardized = setdiff(colnames(x), gcd_name))
    id <- rownames(x)

    if (identical(est_change_type, "raw")) {
        if (sort) {
            fct <- function(pname, xx, digits) {
                out_1 <- xx[order(abs(xx[, pname]), decreasing = TRUE),
                            pname, drop = FALSE]
                out_2 <- data.frame(id = rownames(out_1),
                                    p = round(out_1[, pname],
                                              digits = digits))
                out_2 <- out_2[i, ]
                colnames(out_2) <- c("id", pname)
                out_2
              }
            out <- lapply(pnames, fct, xx = x, digits = digits)
            out <- do.call(cbind, out)
            rownames(out) <- NULL
          } else {
            out <- as.data.frame(round(x, digits = digits))
            out <- out[i, , drop = FALSE]
          }
      }

    if (identical(est_change_type, "standardized")) {
        fallback_to_est <- FALSE
        gcd_na <- FALSE
        if (any(is.na(x[, gcd_name]))) {
            gcd_na <- TRUE
            # fallback_to_est <- TRUE
            # by <- "est"
          }
        if (sort) {
            if (identical(by, "gcd")) {
                out_1 <- x[order(x[, gcd_name], decreasing = TRUE), , drop = FALSE]
                out <- as.data.frame(round(out_1, digits = digits))
                out <- out[i, , drop = FALSE]
              } else {
                fct <- function(pname, xx, digits) {
                    out_1 <- xx[order(abs(xx[, pname]), decreasing = TRUE),
                                pname, drop = FALSE]
                    out_2 <- data.frame(id = rownames(out_1),
                                        p = round(out_1[, pname],
                                                  digits = digits))
                    out_2 <- out_2[i, ]
                    colnames(out_2) <- c("id", pname)
                    out_2
                  }
                out <- lapply(colnames(x), fct, xx = x, digits = digits)
                out <- do.call(cbind, out)
                rownames(out) <- NULL
              }
          } else {
            out <- as.data.frame(round(x, digits = digits))
            out <- out[i, , drop = FALSE]
          }
      }

    tmp <- ifelse(est_std, "Standardized Parameter Estimates",
                           "Parameter Estimates")
    if (is_user) {
        tmp <- "User Function"
      }
    tmp2 <- switch(est_method,
                   leave_one_out = "",
                   approx = "Approximate ")
    tmp3 <- switch(est_change_type,
                   standardized = "Standardized ",
                   "")
    cat("\n-- ",
        tmp2,
        tmp3,
        "Case Influence on ",
        tmp,
        " --", sep = "")
    cat("\n\n")
    print(out)

    cat("\nNote:\n")

    cat("- Changes are ",
        tolower(tmp2),
        tolower(tmp3),
        "raw changes if a case is included.\n", sep = "")

    if (first != nrow(x)) {
        cat("- Only the first ",
            first,
            " case(s) is/are displayed.",
            " Set ", sQuote("first"),
            " to NULL to display all cases.",
            "\n", sep = "")
      } else {
        cat("- All stored cases are displayed.\n")
      }

    if (sort) {
        if (identical(est_change_type, "raw")) {
            cat("- Cases sorted by the absolute changes for each variable.\n")
          } else {
            if (fallback_to_est) {
                cat("- Cannot sort by ",
                    sQuote(gcd_name),
                    ". At least one NA on ",
                    sQuote(gcd_name), ".\n", sep = "")
              }
            if (identical(by, "gcd")) {
                cat("- Cases sorted by ", gcd_name2, ".\n", sep = "")
              } else {
                cat("- Cases sorted by the absolute values of change or ",
                    gcd_name2, ".\n", sep = "")
              }
            if (gcd_na) {
                cat("- One or more cases are missing on ",
                    gcd_name2,
                    ".\n", sep = "")
              }
          }
      }

    invisible(x)
  }