R/switch-functions.R

In statsExpressions: Tidy Dataframes and Expressions with Statistical Details

#' @name extract_stats_type
#' @title Switch the type of statistics.
#'
#' @description
#'
#' Relevant mostly for `{ggstatsplot}` and `{statsExpressions}` packages, where
#' different statistical approaches are supported via this argument: parametric,
#' non-parametric, robust, and Bayesian. This switch function converts strings
#' entered by users to a common pattern for convenience.
#'
#' `stats_type_switch()` is an alias of `extract_stats_type()`.
#'
#' @param type A character specifying the type of statistical approach:
#'   - `"parametric"`
#'   - `"nonparametric"`
#'   - `"robust"`
#'   - `"bayes"`
#'
#' You can specify just the initial letter (e.g. `"np"` or `"bf"`). Matching is
#' on the initial lowercase letter only, so any other value (including
#' capitalized values such as `"Bayes"`) falls back to `"parametric"` without a
#' warning.
#'
#' @returns A character vector of the same length as `type`, with values
#'   `"parametric"`, `"nonparametric"`, `"robust"`, or `"bayes"`.
#'
#' @autoglobal
#'
#' @examples
#' extract_stats_type("p")
#' extract_stats_type("bf")
#' extract_stats_type(c("np", "robust", "Bayes"))
#' @export
extract_stats_type <- function(type) {
  case_when(
    grepl("^n", type) ~ "nonparametric",
    grepl("^r", type) ~ "robust",
    grepl("^b", type) ~ "bayes",
    TRUE ~ "parametric"
  )
}

#' @rdname extract_stats_type
#' @export
stats_type_switch <- extract_stats_type

#' @noRd
extract_estimate_type <- function(x) {
  case_when(
    .grepl("pearson's c", x) ~ list(quote(widehat(italic("C"))["Pearson"])),
    .grepl("cohen's d", x) ~ list(quote(widehat(italic("d"))["Cohen"])),
    .grepl("hedges' g", x) ~ list(quote(widehat(italic("g"))["Hedges"])),
    .grepl("biserial", x) ~ list(quote(
      widehat(italic("r"))["biserial"]^"rank"
    )),
    .grepl("cramer", x) ~ list(quote(widehat(italic("V"))["Cramer"])),
    .grepl("cohen's g", x) ~ list(quote(widehat(italic("g"))["Cohen"])),
    .grepl("r-squared", x) ~ list(quote(widehat(italic(R^"2"))["Bayesian"])),
    .grepl("spearman", x) ~ list(quote(widehat(rho)["Spearman"])),
    grepl("^bayesian pearson", x) ~ list(quote(widehat(rho)["Pearson"])),
    grepl("posterior|t-", x) ~ list(quote(widehat(delta)["difference"])),
    grepl("difference$", x) ~ list(quote(widehat(delta)["R"]^"AKP")),
    grepl("average$", x) ~ list(quote(widehat(delta)["R-avg"]^"AKP")),
    grepl("^eta2", x) ~ list(quote(widehat(eta["p"]^2))),
    grepl("^omega2", x) ~ list(quote(widehat(omega["p"]^2))),
    grepl("^trimmed", x) ~ list(quote(widehat(mu)["trimmed"])),
    grepl("^epsilon2", x) ~ list(quote(widehat(epsilon)["ordinal"]^2)),
    grepl("^explanatory", x) ~ list(quote(widehat(xi))),
    grepl("^meta", x) ~ list(quote(widehat(beta)["summary"]^"meta")),
    grepl("^pearson", x) ~ list(quote(widehat(italic("r"))["Pearson"])),
    grepl("^winsor", x) ~ list(quote(widehat(italic("r"))["Winsorized"])),
    grepl("^kendall", x) ~ list(quote(widehat(italic("W"))["Kendall"])),
    TRUE ~ list(NULL)
  )
}

#' @noRd
extract_statistic_text <- function(x) {
  case_when(
    grepl("^welch", x) ~ list(quote(italic("t")["Welch"])),
    grepl("afex| of means$", x) ~ list(quote(italic("F")["Fisher"])),
    grepl("^boot", x) ~ list(quote(italic("t")["bootstrapped"])),
    grepl("^spearman", x) ~ list(quote(italic("S"))),
    grepl("t-test$|correlation$", x) ~ list(quote(italic("t")["Student"])),
    .grepl("wilcoxon rank", x) ~ list(quote(italic("W")["Mann-Whitney"])),
    .grepl("wilcoxon signed", x) ~ list(quote(italic("V")["Wilcoxon"])),
    .grepl("variances", x) ~ list(quote(italic("F")["Welch"])),
    .grepl("yuen", x) ~ list(quote(italic("t")["Yuen"])),
    .grepl("heteroscedastic", x) ~ list(quote(italic("F")["trimmed-means"])),
    .grepl("meta", x) ~ list(quote(italic("z"))),
    .grepl("friedman", x) ~ list(quote(chi["Friedman"]^2)),
    .grepl("kruskal", x) ~ list(quote(chi["Kruskal-Wallis"]^2)),
    .grepl("probabilities", x) ~ list(quote(chi["gof"]^2)),
    .grepl("pearson's chi", x) ~ list(quote(chi["Pearson"]^2)),
    .grepl("mcnemar's chi", x) ~ list(quote(chi["McNemar"]^2)),
    TRUE ~ list(NULL)
  )
}

#' @noRd
prior_switch <- function(x) {
  case_when(
    .grepl("contingency", x) ~ list(quote(italic("a")["Gunel-Dickey"])),
    .grepl("correlation", x) ~ list(quote(italic("r")["beta"]^"JZS")),
    TRUE ~ list(quote(italic("r")["Cauchy"]^"JZS"))
  )
}

#' @note Don't curry using `purrr::partial()` because it causes `"Found a .Internal call"` warning.
#' @noRd
.grepl <- function(pattern, x) grepl(pattern, x, fixed = TRUE)

#' @title Select the parametric effect size for mean-difference tests
#' @description Maps the user-facing `effsize.type` to the corresponding
#'   `{effectsize}` function (Hedges' *g* when unbiased, Cohen's *d* when
#'   biased). Shared by [one_sample_test()] and [two_sample_test()].
#' @noRd
.mean_difference_effsize <- function(effsize.type) {
  switch(
    match.arg(effsize.type, c("g", "d", "unbiased", "biased")),
    g = ,
    unbiased = effectsize::hedges_g,
    d = ,
    biased = effectsize::cohens_d
  )
}

#' @title Select the test and effect-size functions for mean-difference tests
#' @description Maps the statistical `type` to the base-R test function and its
#'   companion `{effectsize}` function: the *parametric* approach pairs the
#'   *t*-test with Hedges' *g* / Cohen's *d* (via `.mean_difference_effsize()`),
#'   while the *non-parametric* approach pairs the Wilcoxon test with the
#'   rank-biserial correlation. Shared by [one_sample_test()] and
#'   [two_sample_test()].
#' @noRd
.mean_difference_fns <- function(type, effsize.type) {
  if (type == "parametric") {
    list(test = stats::t.test, es = .mean_difference_effsize(effsize.type))
  } else {
    list(test = stats::wilcox.test, es = effectsize::rank_biserial)
  }
}