R/partial_correltable.R

In scipub: Summarize Data for Scientific Publication

#' Create partial correlation table (with stars for significance)
#'  for scientific publication
#'
#' The `partial_correltable` function can be used to create
#' partial correlation
#' table (with stars for significance) for scientific publication
#' This is intended to summarize partial correlations
#'  between (`vars`) from an input dataset (`data`),
#'  residualizing all `vars` by `partialvars`.
#' This function allows for numeric, binary, and factor
#'  variables as `partialvars`. but only numeric `vars`
#'  are used and any non-numeric `vars` will be dropped.
#'  All other flags follow from `scipub::correltable`.
#' Correlations are based on `stats::cor`, `use` and `method`
#'  follow from that function.
#' Stars indicate significance: `*p<.05, **p<.01, ***p<.001`
#' For formatting, variables can be renamed, numbers can be rounded,
#'  upper or lower triangle only can be selected (or whole matrix),
#'   and empty columns/rows can be dropped if using triangles.
#' For more compact columns, variable names can be numbered in the
#'  rows and column names will be corresponding numbers.
#' Requires `tidyverse` and `stats` libraries.
#' @param data The input dataset.
#' @param vars A list of the names of 2+ variables to correlate,
#'  e.g. c("Age","height","WASI"). All variables must be numeric.
#' @param var_names An optional list to rename the `vars` colnames
#'  in the output table, e.g. c("Age (years)","Height (inches)","IQ").
#'   Must match `vars` in length. If not supplied, `vars` will be printed as is.
#' @param partialvars A list of the names of 1+ variables to partial out,
#'  e.g. c("iq","Sex","Income"). Can include numeric, binary, factor variables.
#' @param partialvar_names An optional list to rename the `partialvars`
#' colnames in the output table, e.g. c("IQ (WASI)","Sex","Income").
#'   Must match `partialvar_names` in length.
#'   If not supplied, `partialvar_names` will be printed as is.
#' @param method Type of correlation to calculate c("pearson", "spearman"),
#'  based on `stats::cor`, default = "pearson".
#' @param use  Use pairwise.complete.obs or restrict to complete cases
#'  c("pairwise", "complete"), based on `stats::cor`, default = "pairwise".
#' @param round_n The number of decimal places to
#'  round all output to (default=2).
#' @param tri Select output formatting c("upper", "lower","all");
#'  KEEP the upper triangle, lower triangle, or all values, default ="upper"
#' @param cutempty If keeping only upper/lower triangle with `tri`,
#'  cut empty row/column, default=FALSE.
#' @param colnum For more concise column names, number row names and
#'  just use corresponding numbers as column names,
#'   default=FALSE, if TRUE overrides cutempty.
#' @param html Format as html in viewer or not (default=F, print in console),
#'  needs library(htmlTable) installed.
#' @return Output Table 1
#' @import 	dplyr
#' @importFrom 	purrr negate
#' @importFrom 	stats lm resid setNames as.formula
#' @import 	stringr
#' @importFrom 	tidyselect all_of
#' @export
#' @examples
#' \dontrun{
#' partial_correltable(
#'   data = psydat, vars = c("Age", "Height", "iq"),
#'   partialvars = c("Sex", "Income"),
#'   tri = "lower", html = TRUE
#' )
#'
#' partial_correltable(
#'   data = psydat, vars = c("Age", "Height", "iq"),
#'   var_names = c("Age (months)", "Height (inches)", "IQ"),
#'   partialvars = c("Sex", "Income"),
#'   tri = "upper", colnum = TRUE, html = TRUE
#' )
#'
#' partial_correltable(
#'   data = psydat, vars = c("Age", "Height", "iq"),
#'   var_names = c("Age (months)", "Height (inches)", "IQ"),
#'   partialvars = c("anxT"),
#'   partialvar_names = "Anxiety",
#'   tri = "all", html = TRUE
#' )
#' }



partial_correltable <- function(data,
                                vars = NULL,
                                var_names = vars,
                                partialvars = NULL,
                                partialvar_names = partialvars,
                                method = "pearson",
                                use = "pairwise",
                                round_n = 2,
                                tri = "upper",
                                cutempty = FALSE,
                                colnum = FALSE,
                                html = FALSE) {

  # Validate inputs
  validate_partial_inputs(data, vars, var_names, partialvars, partialvar_names)

  # Clean and prepare variables
  prepared <- prepare_variables(data, vars, var_names,
                                partialvars, partialvar_names)
  vars <- prepared$vars
  var_names <- prepared$var_names
  partialvars <- prepared$partialvars
  partialvar_names <- prepared$partialvar_names

  # Handle missing data
  data_info <- handle_missing_data(data, vars, partialvars, use)
  data_clean <- data_info$data

  resid_data <- residualize_variables(data_clean, vars, partialvars)

  # Check if correltable function is available
  if (!requireNamespace("scipub", quietly = TRUE)) {
    stop("Package 'scipub' required. Install with: install.packages('scipub')",
         call. = FALSE)
  }

  # Use correltable on residualized data
  corr_result <- scipub::correltable(
    data = resid_data,
    vars = vars,
    var_names = var_names,
    method = method,
    use = use,
    round_n = round_n,
    tri = tri,
    cutempty = cutempty,
    colnum = colnum,
    html = FALSE
  )

  # Build modified caption
  caption <- build_partial_caption(
    corr_result$caption,
    partialvar_names,
    data_info$exclusion_reason
  )

  # Return results
  if (html) {
    if (!requireNamespace("htmlTable", quietly = TRUE)) {
      stop("Package 'htmlTable' required for HTML output. Install with: install.packages('htmlTable')",
           call. = FALSE)
    }

    return(htmlTable::htmlTable(corr_result$table,
                                useViewer = TRUE,
                                caption = caption,
                                pos.caption = "bottom"))
  } else {
    return(list(table = corr_result$table, caption = caption))
  }
}