R/interval_vctr_methods.R

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

#' @export
#' @method vec_range interval_vctr
vec_range.interval_vctr <- function(..., na.rm = FALSE, finite = FALSE, aes = NULL) {
  x <- list(...)
  x <- vec_c(!!!x)
  if (finite) {
    x <- x[is.finite(x)]
  }
  if (na.rm) {
    x <- x[!is.na(start(x)) & !is.na(end(x))]
  }
  x <- new_interval_vctr(min(start(x), na.rm = na.rm),
                         max(end(x), na.rm = na.rm))
  x
}

#' @export
#' @method censor interval_vctr
censor.interval_vctr <- function(x, range = new_interval_vctr(0, 1),
                                 only.finite = TRUE) {
  force(range)
  finite <- if (only.finite) {
    is.finite(x)
  } else {
    TRUE
  }
  x[finite & start(x) < start(range)] <- NA_real_
  x[finite & end(x) > end(range)] <- NA_real_
  x
}

#' @export
#' @method censor.numeric interval_vctr
censor.numeric.interval_vctr <- function(x, range = new_interval_vctr(0, 1),
                                         only.finite = TRUE) {
  force(range)
  finite <- if (only.finite) {
    is.finite(x)
  } else {
    TRUE
  }
  x[finite & x < start(range)] <- NA_real_
  x[finite & x > end(range)] <- NA_real_
  x
}

#' @export
#' @method vec_rescale interval_vctr
vec_rescale.interval_vctr <- function(
  x, to = new_interval_vctr(0, 1),
  from = vec_range(x, na.rm = TRUE, finite = TRUE), ...
) {
  start(x) <- (start(x) - start(from)) / width(from) * width(to) + start(to)
  end(x) <- (end(x) - start(from)) / width(from) * width(to) + start(to)
  x
}

# Needed for rescaling breaks in light of interval_vctr 'from' argument
#' @export
#' @method vec_rescale.default.default interval_vctr
vec_rescale.default.default.interval_vctr <- function(
  x, to = c(0, 1),
  from = range(x, na.rm = TRUE, finite = TRUE),
  ...) {
  from <- c(start(from), end(from))
  scales::rescale(x, to, from = from, ...)
}

#' @export
#' @method vec_zero_range interval_vctr
vec_zero_range.interval_vctr <- function(x = new_interval_vctr(),
                                         tol = 1000 * .Machine$double.eps) {
  x <- vec_range(x)
  x <- unname(vec_c(!!!vec_data(x)))
  scales::zero_range(x, tol = tol)
}

#' @export
#' @method vec_force_flat interval_vctr
vec_force_flat.interval_vctr <- function(x, limits = NULL, method = NA_character_) {
  vec_assert(method, character())
  x <- switch(method,
              "xmin" = start(x),
              "xmax" = end(x),
              (start(x) + end(x)) / 2)
  if (is.null(limits)) {
    limits <- range(x, na.rm = TRUE, finite = TRUE)
  } else if  (inherits(limits, "interval_vctr")) {
    limits <- vec_range(limits)
    limits <- c(start(limits), end(limits))
  }

  scales::rescale(x, from = limits)
}

#' @export
#' @method vec_force_flat.default interval_vctr
vec_force_flat.default.interval_vctr <- function(x, limits = NULL, method = NA_character_) {
  vec_assert(method, character())
  limits <- vec_range(limits)
  limits <- c(start(limits), end(limits))
  x <- switch(method, vec_cast(x, numeric()))
  scales::rescale(x, from = limits)
}

#' @export
#' @method vec_major_breaks interval_vctr
vec_major_breaks.interval_vctr <- function(x, n = 5, ...) {
  x <- vec_range(x)
  scales::extended_breaks(n)(c(start(x), end(x)))
}

#' @export
#' @method vec_minor_breaks interval_vctr
vec_minor_breaks.interval_vctr <- function(b, limits, n) {
  scales::regular_minor_breaks()(b, limits, n)
}

#' @export
#' @method vec_expand_limits interval_vctr
vec_expand_limits.interval_vctr <- function(limits, expand = expansion(0, 0),
                                            coord_limits = NULL) {
  if (all(!is.finite(limits))) {
    limits <- new_interval_vctr(-Inf, Inf)
  }

  start <- pmin(start(limits), end(limits))
  end <- pmax(start(limits), end(limits))

  if (!is.null(coord_limits)) {

    if (inherits(coord_limits, "interval_vctr")) {
      start <- start(coord_limits) %|% start
      end <- end(coord_limits) %|% end
    } else {
      if (length(coord_limits) != 2L) {
        stop("The coordinate limits must be length 2, NULL or a length 1 interval_vctr")
      }
      start <- coord_limits[1] %|% start
      end <- coord_limits[2] %|% end
    }
  }

  start <- scales::expand_range(c(start, end), expand[1], expand[2])[1]
  end <- scales::expand_range(c(start, end), expand[3], expand[4])[2]
  new_interval_vctr(start, end)
}