R/print_sbt_ustd_boot.R

In semboottools: Bootstrapping Helpers for Structural Equation Modelling

#' @title Print a 'sbt_ustd_boot' Object
#'
#' @description Print method for a
#' 'sbt_ustd_boot' object, which
#' is the output of
#' [parameterEstimates_boot()].
#'
#' @details
#' The default format of the printout,
#' `"lavaan.printer"`,
#' is a compact version of the lavaan-style
#' printout, generated by `lavaan.printer`.
#' Alternatively, users can request a format
#' similar to that of the printout
#' of the summary of a `lavaan` output
#' by setting `output` to `"text"`. This
#' format can be used if `"lavaan.printer"`
#' failed.
#'
#' Users can also print the content just
#' as a data frame by setting `output`
#' to `"table"`. Not easy to read much
#' more compact.
#'
#' @param x Object of the class
#' `sbt_ustd_boot`, the output of
#' [parameterEstimates_boot()].
#'
#' @param ... Optional arguments to be
#' passed to [print()] methods.
#'
#' @param nd The number of digits
#' after the decimal place. Default
#' is 3.
#'
#' @param output String. How the results
#' are printed. If set to `"table"`,
#' the results are printed in a table
#' format similar to that of
#' [lavaan::parameterEstimates()].
#' If set to `"text"`, the results will be
#' printed in a text format similar to
#' the printout of the output of
#' [summary()] of
#' a 'lavaan'-class object. If set
#' to `"lavaan.printer"`, the default,
#' `lavaan.printer`
#' will be used to print a more compact
#' version of the `"text"` output.
#'
#' @param drop_cols The name(s) of the
#' column(s) to drop
#' if output format is `"lavaan.printer"`.
#' Default is `"Z"`, to fit the print
#' out to the usual screen width of 80.
#'
#' @seealso [parameterEstimates_boot()]
#'
#' @examples
#' library(lavaan)
#' set.seed(5478374)
#' n <- 50
#' x <- runif(n) - .5
#' m <- .40 * x + rnorm(n, 0, sqrt(1 - .40))
#' y <- .30 * m + rnorm(n, 0, sqrt(1 - .30))
#' dat <- data.frame(x = x, y = y, m = m)
#' model <-
#' '
#' m ~ a*x
#' y ~ b*m
#' ab := a*b
#' '
#'
#' # Should set bootstrap to at least 2000 in real studies
#' fit <- sem(model, data = dat, fixed.x = FALSE)
#'
#' fit <- store_boot(fit,
#'                   do_bootstrapping = TRUE,
#'                   R = 100,
#'                   iseed = 1234)
#'
#' est <- parameterEstimates_boot(fit)
#' est
#'
#' @return
#'  `x` is returned invisibly. Called for its side effect.
#'
#' @author Shu Fai Cheung
#' <https://orcid.org/0000-0002-9871-9448>
#'
#' @export

print.sbt_ustd_boot <- function(x,
                                ...,
                                nd = 3,
                                output = c("lavaan.printer", "text", "table"),
                                drop_cols = "Z") {
  output <- match.arg(output)
  x_call <- attr(x, "call")
  if (output == "table") {
    NextMethod()
    return(invisible(x))
  }
  ptable <- attr(x, "partable")
  est0 <- x
  class(est0) <- class(est0)[-which(class(est0) == "sbt_ustd_boot")]
  est1 <- est0
  est1$id <- seq_len(nrow(est1))
  # i0 <- colnames(x) %in% c("se", "z", "pvalue",
  #                          "ci.lower", "ci.upper")
  # est1 <- merge(est1,
  #               x[, !i0])
  i0 <- colnames(ptable) %in% c("est", "se",
                                "user", "free",
                                "ustart", "plabel",
                                "start",
                                "id")
  est1 <- merge(est1, ptable[, !i0])
  est1 <- est1[order(est1$id), ]
  est1$id <- NULL
  class(est1) <- class(est0)
  pe_attrib <- attr(x, "pe_attrib")
  tmp <- !(names(pe_attrib) %in% names(attributes(est1)))
  attributes(est1) <- c(attributes(est1),
                        pe_attrib[tmp])
  class(est1) <- c("lavaan.parameterEstimates", class(est1))
  if (output == "lavaan.printer") {
    level <- attr(x, "level")
    boot_ci_type <- attr(x, "boot_ci_type")
    has_boot_p <- !is.null(est1$boot.p)
    boot_est_ustd_i <- attr(x, "boot_est_ustd")
    # TODO:
    # - Revise store_boot() to store more information
    if (!is.null(boot_est_ustd_i)) {
      R <- sum(stats::complete.cases(boot_est_ustd_i))
    } else {
      R <- NA
    }
    est2 <- lavaan.printer::parameterEstimates_table_list(est1,
                      rename_cols = c("P(>|z|)" = "p",
                                      "S.E." = "SE",
                                      "boot.ci.lower" = "bCI.Lo",
                                      "boot.ci.upper" = "bCI.Up",
                                      "boot.se" = "bSE",
                                      "boot.p" = "bp"),
                      header_funs = list(hdr_bootstrap),
                      header_funs_args = list(list(level = level,
                                                   boot_ci_type = boot_ci_type,
                                                   has_boot_p = has_boot_p,
                                                   R = R)),
                      footer_funs = list(ftr_bootstrap),
                      footer_funs_args = list(list(cnames = colnames(est1))))
    lavaan.printer::print_parameterEstimates_table_list(est2,
                                                        nd = nd,
                                                        drop = drop_cols)
  } else {
    level <- attr(x, "level")
    est2 <- est1
    out <- utils::capture.output(print(est2, nd = nd))
    i <- grepl("  Standard errors  ", out, fixed = TRUE)
    j <- nchar(out[i])

    st1 <- "  Bootstrap Confidence Interval:"
    tmp <- "  - Confidence Level"
    tmp2 <- paste0(formatC(level * 100, digits = 1, format = "f"),
                    "%")
    st2 <- paste0(tmp,
                  paste0(rep(" ", j - nchar(tmp) - nchar(tmp2)),
                          collapse = ""),
                  tmp2)
    tmp <- "  - Bootstrap CI Type"
    tmp2 <- switch(attr(x, "boot_ci_type"),
                    perc = "Percentile",
                    bc = "Bias-Corrected",
                    bca.simple = "Bias-Corrected")
    st2b <- paste0(tmp,
                    paste0(rep(" ", j - nchar(tmp) - nchar(tmp2)),
                          collapse = ""),
                    tmp2)
    if (!is.null(est2$boot.p)) {
      tmp <- "  - Bootstrap P-Value"
      tmp2 <- "Asymmetric P-Value"
      st2c <- paste0(tmp,
                    paste0(rep(" ", j - nchar(tmp) - nchar(tmp2)),
                            collapse = ""),
                    tmp2)
    } else {
      st2c <- NULL
    }
    out <- c(out[seq_len(which(i))],
              st1,
              st2,
              st2b,
              st2c,
              out[-seq_len(which(i))])
    cat(out, sep = "\n")
  }
  return(invisible(x))
}

#' @noRd

hdr_bootstrap <- function(x,
                          level,
                          boot_ci_type,
                          has_boot_p,
                          R) {
  out0 <- data.frame(Field = "Valid Bootstrap Samples:",
                      Value = as.character(R))
  out1 <- data.frame(Field = "Level of Confidence:",
                      Value = sprintf("%3.1f%%", level * 100))
  out2 <- data.frame(Field = "CI Type:",
                      Value = switch(boot_ci_type,
                                    perc = "Percentile",
                                    bc = "Bias-Corrected",
                                    bca.simple = "Bias-Corrected"))
  if (has_boot_p) {
    out3 <- data.frame(Field = "P-Value:",
                        Value = "Asymmetric")
  } else {
    out3 <- NULL
  }
  out <- rbind(out0,
                out1,
                out2,
                out3)
  colnames(out) <- NULL
  attr(out, "section_title") <- "Bootstrapping:"
  out
}

ftr_bootstrap <- function(x,
                          cnames) {
  out0 <- character(0)
  if ("se" %in% cnames) {
    out0 <- c(out0,
              "- SE: Original standard errors.")
  }
  if ("pvalue" %in% cnames) {
    out0 <- c(out0,
              "- p: Original p-values.")
  }
  if ("ci.lower" %in% cnames) {
    out0 <- c(out0,
              "- CI.Lo, CI.Up: Original confidence intervals.")
  }
  if ("boot.se" %in% cnames) {
    out0 <- c(out0,
              "- bSE: Bootstrap standard errors.")
  }
  if ("boot.ci.lower" %in% cnames) {
    out0 <- c(out0,
              "- bCI.Lo, bCI.Up: Bootstrap confidence intervals.")
  }
  if ("boot.p" %in% cnames) {
    out0 <- c(out0,
              "- bp: Bootstrap p-values.")
  }
  attr(out0, "section_title") <- "Footnote:"
  attr(out0, "print_fun") <- "cat"
  attr(out0, "strwrap_args") <- list(exdent = 2)
  out0
}