R/out_of_bounds.R

In teunbrand/ggvctrcoords: Coordinates and scales for ggplot2 using the vctrs package

# We make several of the out-of-bounds related functions from the scales package
# as generics so specific methods can be written for `x` and `range` argument
# classes.

#' @name out_of_bounds
#' @title Out-of-bounds functions
#' @description These functions were taken from the scales package and made as
#'   S3 generics such that S3 methods can be written for these depending on the
#'   classes of the \code{x} and \code{range} arguments.
#' @param x A vector on which an out-of-bounds operation must be performed.
#' @param range An indicator or range outside of which \code{x} is considered
#' @param only.finite If \code{TRUE} (the default), will only modify finite
#'   values. out-of-bounds.
#' @seealso The documentation for these functions in the scales package:
#'   \code{\link[scales]{censor}}, \code{\link[scales]{squish}} and
#'   \code{\link[scales]{squish_infinite}}.
NULL

# Censoring ---------------------------------------------------------------

#' @export
#' @rdname out_of_bounds
censor <- function(x, range = c(0, 1), only.finite = TRUE) {
  UseMethod("censor")
}

#' @export
#' @method censor vctrs_vctr
censor.vctrs_vctr <- function(x, range = c(0, 1), only.finite = TRUE) {
  range <- vec_cast(range, x)
  na_value <- vec_init(x)
  finite <- if (only.finite)
    is.finite(x)
  else TRUE
  x[finite & x < range[1]] <- na_value
  x[finite & x > range[2]] <- na_value
  x
}

#' @export
#' @export censor.numeric
#' @method censor numeric
#' @rdname out_of_bounds
censor.numeric <- function(x, range = c(0, 1), only.finite = TRUE) {
  UseMethod("censor.numeric", range)
}

#' @export
#' @method censor integer
censor.integer <- function(x, range = c(0, 1), only.finite = TRUE) {
  UseMethod("censor.numeric", range)
}

#' @export
#' @method censor.numeric default
censor.numeric.default <- function(x, range = c(0, 1), only.finite = TRUE) {
  scales::censor(x, range, only.finite)
}

# Squishing ---------------------------------------------------------------

#' @export
#' @rdname out_of_bounds
squish <- function(x, range = c(0, 1), only.finite = TRUE) {
  UseMethod("squish")
}

#' @export
#' @export squish.numeric
#' @method squish numeric
#' @rdname out_of_bounds
squish.numeric <- function(x, range = c(0, 1), only.finite = TRUE) {
  UseMethod("squish.numeric", range)
}

#' @export
#' @method squish integer
squish.integer <- function(x, range = c(0, 1), only.finite = TRUE) {
  UseMethod("squish.numeric", range)
}

#' @method squish.numeric default
squish.numeric.default <- function(x, range = c(0, 1), only.finite = TRUE) {
  scales::squish(x, range, only.finite)
}

# Squishing infinites -----------------------------------------------------

#' @export
#' @rdname out_of_bounds
squish_infinite <- function(x, range = c(0, 1)) {
  UseMethod("squish_infinite")
}

#' @export
#' @export squish_infinite.numeric
#' @method squish_infinite numeric
#' @rdname out_of_bounds
squish_infinite.numeric <- function(x, range = c(0, 1)) {
  UseMethod("squish_infinite.numeric", range)
}

#' @export
#' @method squish_infinite integer
squish_infinite.integer <- function(x, range = c(0, 1)) {
  UseMethod("squish_infinite.numeric", range)
}

#' @method squish_infinite.numeric default
squish_infinite.numeric.default <- function(x, range = c(0, 1)) {
  scales::squish_infinite(x, range)
}

# Discarding --------------------------------------------------------------

# We're assuming that this doesn't need to do anything else than excluding the
# NA's  produced by censor.
discard_oob <- function(x, range) {
  if (is.null(x)) {
    return(NULL)
  }
  # Note range has no default because we rely on censor to provide default
  if(!missing(range)) {
    x <- censor(x, range = range, only.finite = FALSE)
  } else {
    x <- censor(x, only.finite = FALSE)
  }
  x <- x[!is.na(x)]
  x
}