R/scales.R

In medewitt/datademon: This package calls some stock functions for use for data analysis

# Stolen from ggplot2
is.waive <- function (x) { inherits(x, "waiver") }
is.sec_axis <- function (x) { inherits(x, "AxisSecondary") }
is.formula <- function (x) { inherits(x, "formula") }

#' X & Y scales with opinionated pre-sets for percent & comma label formats
#'
#' The `_comma` ones set comma format for axis text and `expand=c(0,0)` (you need to set limits).
#'
#' The `_percent` ones set precent format for axis text and `expand=c(0,0)` (you need to set limits).
#'
#' @md
#' @param name The name of the scale. Used as axis or legend title. If
#'   `waiver()`, the default, the name of the scale is taken from the first
#'   mapping used for that aesthetic. If `NULL`, the legend title will be
#'   omitted.
#' @param breaks One of:
#'   - `NULL` for no breaks
#'   - `waiver()` for the default breaks computed by the
#'     transformation object
#'   - A numeric vector of positions
#'   - A function that takes the limits as input and returns breaks
#'     as output
#' @param minor_breaks One of:
#'   - `NULL` for no minor breaks
#'   - `waiver()` for the default breaks (one minor break between
#'     each major break)
#'   - A numeric vector of positions
#'   - A function that given the limits returns a vector of minor breaks.
#' @param labels One of:
#'   - `NULL` for no labels
#'   - `waiver()` for the default labels computed by the
#'     transformation object
#'   - A character vector giving labels (must be same length as `breaks`)
#'   - A function that takes the breaks as input and returns labels
#'     as output
#' @param limits A numeric vector of length two providing limits of the scale.
#'   Use `NA` to refer to the existing minimum or maximum.
#' @param oob Function that handles limits outside of the scale limits
#'   (out of bounds). The default replaces out of bounds values with NA.
#' @param na.value If `na.translate = TRUE`, what value aesthetic
#'   value should missing be displayed as? Does not apply to position scales
#'   where `NA` is always placed at the far right.
#' @param expand same as in ggplot2
#' @param trans Either the name of a transformation object, or the
#'   object itself. Built-in transformations include "asn", "atanh",
#'   "boxcox", "exp", "identity", "log", "log10", "log1p", "log2",
#'   "logit", "probability", "probit", "reciprocal", "reverse" and "sqrt".
#' @param position The position of the axis. "left" or "right" for vertical
#' scales, "top" or "bottom" for horizontal scales
#' @param sec.axis specify a secondary axis
#' @export
scale_x_percent <- function (name = waiver(), breaks = waiver(), minor_breaks = waiver(),
                             labels = scales::percent, limits = NULL, expand = c(0.01,0), oob = censor,
                             na.value = NA_real_, trans = "identity", position = "bottom",
                             sec.axis = waiver()) {

  if (!requireNamespace("scales", quietly = TRUE)) {
    stop("Pkg needed for this function to work. Please install it.",
         call. = FALSE)
  }

  if (!requireNamespace("ggplot2", quietly = TRUE)) {
    stop("Pkg needed for this function to work. Please install it.",
         call. = FALSE)
  }
  sc <- ggplot2::continuous_scale(c("x", "xmin", "xmax", "xend", "xintercept",
                                    "xmin_final", "xmax_final", "xlower", "xmiddle", "xupper"),
                                  "position_c", identity, name = name, breaks = breaks,
                                  minor_breaks = minor_breaks, labels = labels, limits = limits,
                                  expand = expand, oob = oob, na.value = na.value, trans = trans,
                                  guide = "none", position = position, super = ScaleContinuousPosition)
  if (!is.waive(sec.axis)) {
    if (is.formula(sec.axis))
      sec.axis <- sec_axis(sec.axis)
    if (!is.sec_axis(sec.axis))
      stop("Secondary axes must be specified using 'sec_axis()'")
    sc$secondary.axis <- sec.axis
  }
  sc
}

#' @rdname scale_x_percent
#' @export
scale_y_percent <- function (name = waiver(), breaks = waiver(), minor_breaks = waiver(),
                             labels = scales::percent, limits = NULL, expand = c(0.01,0), oob = censor,
                             na.value = NA_real_, trans = "identity", position = "left",
                             sec.axis = waiver()) {
  sc <- ggplot2::continuous_scale(c("y", "ymin", "ymax", "yend", "yintercept",
                                    "ymin_final", "ymax_final", "lower", "middle", "upper"),
                                  "position_c", identity, name = name, breaks = breaks,
                                  minor_breaks = minor_breaks, labels = labels, limits = limits,
                                  expand = expand, oob = oob, na.value = na.value, trans = trans,
                                  guide = "none", position = position, super = ScaleContinuousPosition)
  if (!is.waive(sec.axis)) {
    if (is.formula(sec.axis))
      sec.axis <- ggplot2::sec_axis(sec.axis)
    if (!is.sec_axis(sec.axis))
      stop("Secondary axes must be specified using 'sec_axis()'")
    sc$secondary.axis <- sec.axis
  }
  sc
}

#' @rdname scale_x_percent
#' @export
scale_x_comma <- function (name = waiver(), breaks = waiver(), minor_breaks = waiver(),
                           labels = scales::comma, limits = NULL, expand = c(0.01,0), oob = censor,
                           na.value = NA_real_, trans = "identity", position = "bottom",
                           sec.axis = waiver()) {
  sc <- ggplot2::continuous_scale(c("x", "xmin", "xmax", "xend", "xintercept",
                                    "xmin_final", "xmax_final", "xlower", "xmiddle", "xupper"),
                                  "position_c", identity, name = name, breaks = breaks,
                                  minor_breaks = minor_breaks, labels = labels, limits = limits,
                                  expand = expand, oob = oob, na.value = na.value, trans = trans,
                                  guide = "none", position = position, super = ScaleContinuousPosition)
  if (!is.waive(sec.axis)) {
    if (is.formula(sec.axis))
      sec.axis <- ggplot2::sec_axis(sec.axis)
    if (!is.sec_axis(sec.axis))
      stop("Secondary axes must be specified using 'sec_axis()'")
    sc$secondary.axis <- sec.axis
  }
  sc
}


#' @rdname scale_x_percent
#' @export
scale_y_comma <- function (name = waiver(), breaks = waiver(), minor_breaks = waiver(),
                           labels = scales::comma, limits = NULL, expand = c(0.01,0), oob = censor,
                           na.value = NA_real_, trans = "identity", position = "left",
                           sec.axis = waiver()) {
  sc <- ggplot2::continuous_scale(c("y", "ymin", "ymax", "yend", "yintercept",
                                    "ymin_final", "ymax_final", "lower", "middle", "upper"),
                                  "position_c", identity, name = name, breaks = breaks,
                                  minor_breaks = minor_breaks, labels = labels, limits = limits,
                                  expand = expand, oob = oob, na.value = na.value, trans = trans,
                                  guide = "none", position = position, super = ScaleContinuousPosition)
  if (!is.waive(sec.axis)) {
    if (is.formula(sec.axis))
      sec.axis <- ggplot2::sec_axis(sec.axis)
    if (!is.sec_axis(sec.axis))
      stop("Secondary axes must be specified using 'sec_axis()'")
    sc$secondary.axis <- sec.axis
  }
  sc
}

#'@export
scale_x_likert_six <- function(name = waiver(), breaks = waiver(), minor_breaks = waiver(),
                                expand = c(0.01,0), oob = censor,
                                na.value = NA_real_, trans = "identity", position = "bottom",
                                sec.axis = waiver()){

  sc <-
    ggplot2::scale_x_discrete(
      limit = c("1", "2", "3", "4", "5", "6"),
      labels = c(
        "Strongly \n Agree",
        "Agree",
        "Slightly\n Agree",
        "Slightly\n Disagree",
        "Disagree",
        "Strongly\n Disagree"
      ),
      position = position
    )
}