R/dep_quantiles.R

In deprivateR: Calculating and Analyzing Measures of Deprivation in the United States

#' Return Quantiles of a Variable
#'
#' @description This helper function can be used to return quantiles of a
#'     deprivation index (or any other continuous distribution). This is useful
#'     for constructing independent variables for statistical analysis. The
#'     function supports splitting a distribution at the median (2 quantiles)
#'     through deciles (10 quantiles) if character labels are desired.
#'
#'
#' @param .data A tibble containing the data to be used for calculating quantiles.
#' @param source_var Required; the quoted or unquoted source variable to be
#'     divided into quantiles.
#' @param new_var Required; the quoted or unquoted name of the new variable to
#'     be created containing the quantile values.
#' @param n Required integer scalar; the number of quantiles to divide the source
#'     variable into. Defaults to \code{4L} (quartiles), but can be set to any
#'     value appropriate for your data as long as it is greater than or equal
#'     to \code{2L}.
#' @param return Required character scalar; one of either \code{"label"} (default)
#'     or \code{"factor"}. If \code{"label"}, the function will return a character
#'     vector of quantile labels. If \code{"factor"}, the function will return
#'     the underlying factor used in the creation of the quantiles measure.
#'
#' @returns A copy of \code{.data} with a new variable containing the requested
#'     quantile.
#'
#' @examples
#' ## load sample data
#' ndi_m <- dep_sample_data(index = "ndi_m")
#'
#' ## calculate NDI with sample data
#' ndi_m <- dep_calc_index(ndi_m, geography = "county", index = "ndi_m", year = 2022,
#'     return_percentiles = TRUE)
#'
#' ## calculate quantiles, return label
#' ndi_m <- dep_quantiles(ndi_m, source_var = NDI_M, new_var = ndi_m_quartiles_l)
#'
#' unique(sort(ndi_m$ndi_m_quartiles_l))
#'
#' ## calculate quantiles, return label
#' ndi_m <- dep_quantiles(ndi_m, source_var = NDI_M, new_var = ndi_m_quartiles_l6,
#'                        n = 6L)
#'
#' unique(sort(ndi_m$ndi_m_quartiles_l6))
#'
#' ## calculate quantiles, return factor
#' ndi_m <- dep_quantiles(ndi_m, source_var = NDI_M, new_var = ndi_m_quartiles_f,
#'     return = "factor")
#'
#' levels(ndi_m$ndi_m_quartiles_f)
#'
#' @export
dep_quantiles <- function(.data, source_var, new_var, n = 4L, return = "label"){

  # save parameters to list
  paramList <- as.list(match.call())

  # quote input variables
  if (!is.character(paramList$source_var)) {
    ref <- rlang::enquo(source_var)
  } else if (is.character(paramList$source_var)) {
    ref <- rlang::quo(!! rlang::sym(source_var))
  }

  refQ <- rlang::quo_name(rlang::enquo(ref))

  if (!is.character(paramList$new_var)) {
    new <- rlang::enquo(new_var)
  } else if (is.character(paramList$new_var)) {
    new <- rlang::quo(!! rlang::sym(new_var))
  }

  newQ <- rlang::quo_name(rlang::enquo(new))

  # check inputs
  if (!is.data.frame(.data)) {
    cli::cli_abort("The object passed to {.arg .data} must be a data frame.")
  }

  if (!refQ %in% names(.data)) {
    cli::cli_abort(c(
      "The variable name passed to {.arg source_var} does not exist in the data.",
      "i" = "Column {.val {refQ}} was not found."
    ))
  }

  if (newQ %in% names(.data)){
    cli::cli_warn("The variable name passed to {.arg new_var} already exists in the data. It will be overwritten.")
  }

  if (!is.integer(n)){
    cli::cli_abort(c(
      "The {.arg n} argument must be an integer.",
      "i" = "Include an {.code L} suffix to specify an integer value, e.g. {.code 4L}."
    ))
  }

  if (n < 2L){
    cli::cli_abort("The {.arg n} argument must be {.code 2L} or greater.")
  }

  if (!return %in% c("label", "factor")){
    cli::cli_abort(c(
      "The {.arg return} argument must be either {.val label} or {.val factor}.",
      "i" = "Got {.val {return}}."
    ))
  }

  ## calculate breaks
  out <- dep_map_breaks(
    .data = .data, var = !!refQ, new_var = "source_var_quantiles",
    classes = n, style = "quantile", show_warnings = FALSE
  )

  ## optionally clean-up labels
  if (return == "label"){

    ## stash levels to simplify
    levels <- levels(out[["source_var_quantiles"]])

    ## create labels
    if (n == 2L){

      out <- dplyr::mutate(out, !!newQ := dplyr::case_when(
        source_var_quantiles == levels[1] ~ "(1) Lower Than Median",
        source_var_quantiles == levels[2] ~ "(2) Greater Than Median"
      ))

    } else if (n == 3L){

      out <- dplyr::mutate(out, !!newQ := dplyr::case_when(
        source_var_quantiles == levels[1] ~ "(1) Lowest Tertile",
        source_var_quantiles == levels[2] ~ "(2) Middle Tertile",
        source_var_quantiles == levels[3] ~ "(3) Highest Tertile"
      ))

    } else {

      ## stash max level
      max_level <- length(levels)

      ## stash quantile label
      quantile_label <- dep_quantile_label(n)

      ## convert to numeric
      out <- dplyr::mutate(out, source_var_quantiles = as.numeric(source_var_quantiles))

      ## create quantile labels
      out <- dplyr::mutate(out, !!newQ := dplyr::case_when(
        source_var_quantiles == 1L ~ paste0("(1) Lowest ", quantile_label),
        source_var_quantiles == max_level ~ paste0("(", max_level, ") Highest ", quantile_label),
        TRUE ~ paste0("(", source_var_quantiles, ") ",
                      dep_ordinal(source_var_quantiles),
                      " ", quantile_label)
      ))

    }

    ## remove source_var_quantiles
    out <- dplyr::select(out, -source_var_quantiles)

  } else if (return == "factor"){

    out <- dplyr::rename(out, !!newQ := source_var_quantiles)

  }

  ## return output
  return(out)

}


dep_quantile_label <- function(x){

  ## identify quantile label
  if (x == 4L){
    out <- "Quartile"
  } else if (x == 5L){
    out <- "Quintile"
  } else if (x == 6L){
    out <- "Sextile"
  } else if (x == 7L){
    out <- "Septile"
  } else if (x == 8L){
    out <- "Octile"
  } else if (x == 9L){
    out <- "Nonile"
  } else if (x == 10L){
    out <- "Decile"
  } else {
    out <- "Quantile"
  }

  ## return output
  return(out)

}

dep_ordinal <- function(x){

  ## lookup table for word-form ordinals (title case)
  ordinal_words <- c(
    "First", "Second", "Third", "Fourth", "Fifth",
    "Sixth", "Seventh", "Eighth", "Ninth", "Tenth",
    "Eleventh", "Twelfth", "Thirteenth", "Fourteenth", "Fifteenth",
    "Sixteenth", "Seventeenth", "Eighteenth", "Nineteenth", "Twentieth"
  )

  ## use lookup for 1-20, fallback to numeric suffix for higher values
  suffix_map <- c("1" = "st", "2" = "nd", "3" = "rd")
  numeric_suffix <- ifelse(
    x %% 100 %in% 11:13, "th",
    ifelse(as.character(x %% 10) %in% names(suffix_map),
           suffix_map[as.character(x %% 10)], "th")
  )

  out <- ifelse(
    x >= 1 & x <= 20,
    ordinal_words[x],
    paste0(x, numeric_suffix)
  )

  ## return output
  return(out)

}