R/print_summary_stdmod.R

In stdmod: Standardized Moderation Effect and Its Confidence Interval

#' @title Print the Summary of a 'std_selected' Class Object
#'
#' @description Print the summary generated by [summary()] on the output
#'  of [std_selected()] or [std_selected_boot()].
#'
#' @return
#'  `x` is returned invisibly.
#'
#' @param x The output of [summary()].
#' @param ...  Arguments to be passed to [summary()].
#'
#' @param est_digits The number of digits
#' after the decimal to be displayed for
#' the coefficient estimates, their
#' standard errors, and bootstrap
#' confidence intervals (if present). Note
#' that the values will be rounded to
#' this number of digits before printing.
#' If all digits at this position are
#' zero for all values, the values may
#' be displayed with fewer digits.
#' Note that the coefficient table is
#' printed by [stats::printCoefmat()].
#' If some numbers are vary large, the
#' number of digits after the decimal
#' may be smaller than `est_digits` due
#' to a limit on the column width.
#' This value also determines the number
#' of digits for displayed R-squared
#' if `default_style` is `FALSE`.
#' Default if 4.
#'
#' @param t_digits The number of digits
#' after the decimal to be displayed
#' for the *t* statistic (in the column
#' `"t value"`). This value also
#' determines the number of digits for
#' the *F* statistic for the R-squared
#' if `default_style` is `FALSE`.
#' Default is 4.
#'
#' @param pvalue_less_than If a *p*-value
#' is less than this value, it will be
#' displayed with `"<(this value)".`
#' For example, if `pvalue_less_than`
#' is .001, the default, *p*-values less
#' than .001 will be displayed as
#' `<.001`. This value also determines
#' the printout of the *p*-value of
#' the *F* statistic if `default_style`
#' is `FALSE`. (This argument does what
#' `eps.Pvalue` does in
#' [stats::printCoefmat()].)
#'
#' @param default_style Logical. If
#' `FALSE`, the default, R-squared
#' and *F* statistic will be displayed
#' in a more readable style. If `TRUE`,
#' then the default style in the
#' printout of the `summary` of
#' [lm()] output will be used.
#'
#'
#' @author Shu Fai Cheung <https://orcid.org/0000-0002-9871-9448>
#'
#' @examples
#'
#' # Load a sample data set
#'
#' dat <- test_x_1_w_1_v_1_cat1_n_500
#'
#' # Do a moderated regression by lm
#' lm_raw <- lm(dv ~ iv*mod + v1 + cat1, dat)
#'
#' # Standardize all variables except for categorical variables.
#' # Interaction terms are formed after standardization.
#' lm_std <- std_selected(lm_raw, to_scale = ~ .,
#'                                to_center = ~ .)
#' summary(lm_std)
#'
#' # With bootstrapping
#' # nboot = 100 just for illustration. nboot >= 2000 should be used in read
#' # research.
#' lm_std_boot <- std_selected_boot(lm_raw, to_scale = ~ .,
#'                                          to_center = ~ .,
#'                                          nboot = 100)
#' summary(lm_std_boot)
#'
#' @export

print.summary.std_selected <- function(x, ...,
                                       est_digits = 4,
                                       t_digits = 4,
                                       pvalue_less_than = .001,
                                       default_style = FALSE) {
  if (!is.null(x$std_selected_boot_call)) {
      cat("\nCall to std_selected_boot():\n")
      print(x$std_selected_boot_call)
    } else {
      cat("\nCall to std_selected():\n")
      print(x$std_selected_call)
    }
  scaled_or_centered <- any(c(!is.null(x$centered_terms), !is.null(x$scaled_terms)))
  if (!is.null(x$scaled_terms)) {
      scaled <- TRUE
    } else {
      scaled <- TRUE
    }
  opt_width <- 0.9 * getOption("width")
  cat("\n")
  tmp <- character(0)
  if (scaled_or_centered) {
      tmp <- c(tmp,
               strwrap("Selected variable(s) are centered by mean and/or scaled by SD"))
      if (!is.null(x$centered_terms)) {
          tmp <- c(tmp,
                   strwrap(paste(c("- Variable(s) centered:", x$centered_terms),
                                   collapse = " "),
                           exdent = 2))
        }
      if (!is.null(x$scaled_terms)) {
          tmp <- c(tmp,
                   strwrap(paste(c("- Variable(s) scaled:", x$scaled_terms),
                                   collapse = " "),
                           exdent = 2))
        }
    } else {
      tmp <- c(tmp,
               strwrap("No variables are centered by mean or scaled by SD by std_selected()."))
    }
  cat(tmp, sep = "\n")
  cat("\n")
  dat_sc <- format_dat_sc(x)
  print(dat_sc)
  tmp <- character(0)
  tmp <- c(tmp, "Note:")
  tmp <- c(tmp,
           strwrap("- Categorical variables will not be centered or scaled even if requested.",
                    exdent = 2))
  if (!is.null(x$nboot)) {
      tmp <- c(tmp,
               strwrap("- Nonparametric bootstrapping 95% confidence intervals computed.",
                       exdent = 2))
      tmp <- c(tmp,
               strwrap(paste0("- The number of bootstrap samples is ", x$nboot, "."),
                       exdent = 2))
    }
  cat("\n")
  cat(tmp, sep = "\n")
  x_rsq <- x$r.squared
  x_rsq_adj <- x$adj.r.squared
  x_fstatistic <- x$fstatistic
  x$coefficients[, "Estimate"] <- round(x$coefficients[, "Estimate"], est_digits)
  x$coefficients[, "Std. Error"] <- round(x$coefficients[, "Std. Error"], est_digits)
  if (!is.null(x$nboot)) {
      x$coefficients[, "CI Lower"] <- round(x$coefficients[, "CI Lower"], est_digits)
      x$coefficients[, "CI Upper"] <- round(x$coefficients[, "CI Upper"], est_digits)
    }
  x$coefficients[, "t value"] <- round(x$coefficients[, "t value"], t_digits)
  if (!default_style) {
      x$fstatistic <- NULL
    }
  NextMethod(eps.Pvalue = pvalue_less_than,
             dig.tst = t_digits)
  if (!default_style) {
      cat(format_rsq(rsq = x_rsq,
                       rsq_adj = x_rsq_adj,
                       digits = est_digits), sep = "\n")
      print_fstatistic(x_fstatistic,
                       f_digits = t_digits,
                       p_digits = ceiling(-log10(pvalue_less_than)))
      cat("\n")
    }
  if (!is.na(x$highest_order) && !identical(x$f_highest, NA)) {
      rsq_highest <- formatC(x$f_highest[2, "R.sq.change"],
                             digits = est_digits,
                             format = "f")
      cat("= Test the highest order term =",
          paste0("The highest order term             : ", x$highest_order),
          paste0("R-squared increase adding this term: ", rsq_highest),
          sep = "\n")
      print_fstatistic_change(x$f_highest,
                              f_digits = t_digits,
                              p_digits = ceiling(-log10(pvalue_less_than)))
      cat("\n")
    }
  tmp <- character(0)
  if (scaled_or_centered) {
      tmp1 <- paste("- Estimates and their statistics are based on the data after",
                     "mean-centering, scaling, or standardization.", collapse = " ")
      tmp <- c(tmp,
               strwrap(tmp1, exdent = 2))
    }
  if (scaled && is.null(x$nboot)) {
      tmp1 <- paste("- One or more variables are scaled by SD or",
                     "standardized. OLS standard errors and",
                     "confidence intervals may be biased for their",
                     "coefficients.",
                     "Please use `std_selected_boot()`.", collapse = " ")
      tmp <- c(tmp,
               strwrap(tmp1, exdent = 2))
    }
  if (!is.null(x$nboot)) {
      tmp <- c(tmp,
               strwrap("- [CI Lower, CI Upper] are bootstrap percentile confidence intervals.",
                       exdent = 2))
      tmp <- c(tmp,
               strwrap("- Std. Error are not bootstrap SEs.", exdent = 2))
    }
  if (length(tmp) > 0) {
      cat("Note:\n")
      cat(tmp, sep = "\n")
      cat("\n")
    }
  invisible(x)
}

format_dat_sc <- function(x) {
  dat_sc <- data.frame(centered_by = x$centered_by,
                      scaled_by   = x$scaled_by)
  nonnumeric <- attr(stats::terms(x), "dataClasses") != "numeric"
  dat_sc[nonnumeric, ] <- NA
  centered <- dat_sc$centered_by != 0
  scaled <- dat_sc$scaled_by != 1
  centered[is.na(centered)] <- FALSE
  scaled[is.na(scaled)] <- FALSE
  dat_sc$Note <- ""
  tmpfct <- function(xc, xs) {
      if (xc && xs) {
        return("Standardized (mean = 0, SD = 1)")
      }
      if (xc) return("Centered (mean = 0)")
      if (xs) return("Scaled (SD = 1)")
      return("")
    }
  dat_sc$Note <- format(mapply(tmpfct, centered, scaled))
  dat_sc[is.na(dat_sc$centered_by) &
        is.na(dat_sc$scaled_by), "Note"] <- "Nonnumeric"
  dat_sc$Note <- format(dat_sc$Note)
  dat_sc
}

#' @noRd

print_fstatistic <- function(fstatistic,
                             f_digits = 4,
                             p_digits = 3) {
     f <- fstatistic["value"]
     df1 <- fstatistic["numdf"]
     df2 <- fstatistic["dendf"]
     f_txt <- paste0("F(",
                     df1, ", ", df2, ") = ",
                     round(f, f_digits))
     p <- stats::pf(f, df1, df2, lower.tail = FALSE)
     p_txt <- format_pvalue(p,
                            eps = 10^(-p_digits))
     if (!grepl("^<", p_txt)) {
        p_txt <- paste0("= ", p_txt)
       }
     cat("ANOVA test of R-squared  : ",
         f_txt, ", p ", p_txt, "\n", sep = "")
  }

#' @noRd

print_fstatistic_change <- function(fstatistic,
                                    f_digits = 4,
                                    p_digits = 3) {
     f <- fstatistic[2, "F"]
     df1 <- fstatistic[2, "Df"]
     df2 <- fstatistic[2, "Res.Df"]
     f_txt <- paste0("F(",
                     df1, ", ", df2, ") = ",
                     round(f, f_digits))
     p <- fstatistic[2, "Pr(>F)"]
     p_txt <- format_pvalue(p,
                            eps = 10^(-p_digits))
     if (!grepl("^<", p_txt)) {
        p_txt <- paste0("= ", p_txt)
       }
     cat("F test of R-squared increase       : ",
         f_txt, ", p ", p_txt, "\n", sep = "")
  }

#' @noRd

format_pvalue <- function(p,
                          eps = 1e-3) {
    p_digits <- ceiling(-log10(eps))
    if (p < eps) {
        return(paste0("< ",
               formatC(eps,
                       digits = p_digits,
                       format = "f")))
      } else {
        return(formatC(p,
                       digits = p_digits,
                       format = "f"))
      }
  }

#' @noRd

format_rsq <- function(rsq, rsq_adj,
                       digits = 4) {
    x1 <- c("R-squared",
            "Adjusted R-squared")
    x2 <- formatC(c(rsq, rsq_adj),
                  digits = digits,
                  format = "f")
    x1max <- max(nchar(x1))
    i <- which(nchar(x1) != x1max)
    x1[i] <- paste0(x1[i],
                    paste0(rep(" ", x1max - nchar(x1[1])),
                           collapse = ""))
    paste0(x1, "       : ", x2)
  }