R/scales.R

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

# Documentation -----------------------------------------------------------

#' @name scale_vctr
#' @title Position scales for vctr classes
#'
#' @inheritParams ggplot2::continuous_scale
#' @param sec.axis \code{\link[ggplot2]{sec_axis}} is used to specify a
#'   secondary axis.
#'
#'
#' @examples
#' NULL
NULL


# User facing -------------------------------------------------------------

#' @export
#' @rdname scale_vctr
scale_x_vctr <- function(
  name   = waiver(),
  breaks = waiver(), minor_breaks = waiver(), n.breaks = NULL,
  labels = waiver(), limits = NULL,
  expand = waiver(), oob = censor,
  na.value = NA_real_, trans = vec_identity_trans,
  guide = waiver(), position = "bottom",
  sec.axis = waiver()
) {
  sc <- vctr_scale(
    c("x", "xmin", "xmax", "xend", "xintercept", "xmin_final", "xmax_final",
      "xlower", "xmiddle", "xupper", "x0"),
    "position_c", identity, name = name, breaks = breaks, n.breaks = n.breaks,
    minor_breaks = minor_breaks, labels = labels, limits = limits,
    expand = expand, oob = oob, na.value = na.value, trans = trans,
    guide = guide, position = position, super = ScaleContinuousVctr
  )
  .int$set_sec_axis(sec.axis, sc)
}

#' @export
#' @rdname scale_vctr
scale_y_vctr <- function(
  name   = waiver(),
  breaks = waiver(), minor_breaks = waiver(), n.breaks = NULL,
  labels = waiver(), limits = NULL,
  expand = waiver(), oob = censor,
  na.value = NA_real_, trans = vec_identity_trans,
  guide = waiver(), position = "left",
  sec.axis = waiver()
) {
  sc <- vctr_scale(
    c("y", "ymin", "ymax", "yend", "yintercept", "ymin_final", "ymax_final",
      "lower", "middle", "upper", "y0"),
    "position_c", identity, name = name, breaks = breaks, n.breaks = n.breaks,
    minor_breaks = minor_breaks, labels = labels, limits = limits,
    expand = expand, oob = oob, na.value = na.value, trans = trans,
    guide = guide, position = position, super = ScaleContinuousVctr
  )
  .int$set_sec_axis(sec.axis, sc)
}

# Internal constructor ----------------------------------------------------

vctr_scale <- function(
  aesthetics, scale_name, palette, name = waiver(), breaks = waiver(),
  minor_breaks = waiver(), n.breaks = NULL, labels = waiver(), limits = NULL,
  rescaler = vec_rescale, oob = censor, expand = waiver(), na.value = NA_real_,
  trans = "identity", guide = "legend", position = "left",
  super = ScaleContinuousVctr
) {
  aesthetics <- standardise_aes_names(aesthetics)

  .int$check_breaks_labels(breaks, labels)

  position <- match.arg(position, c("left", "right", "top", "bottom"))

  if (is.null(breaks) && all(!.int$is_position_aes(aesthetics))) {
    guide <- "none"
  }
  trans <- scales::as.trans(trans)
  if (!is.null(limits) && !is.function(limits)) {
    limits <- trans$transform(limits)
  }

  ggproto(
    NULL, super, call = match.call(),
    aesthetics = aesthetics,
    scale_name = scale_name,
    palette = palette,
    range = vctr_range(aesthetics[1]),
    limits = limits,
    trans = trans,
    na.value = na.value,
    expand = expand,
    rescaler = rescaler,
    oob = oob,
    name = name,
    breaks = breaks,
    minor_breaks = minor_breaks,
    n.breaks = n.breaks,
    labels = labels,
    guide = guide,
    position = position
  )
}

# Autofinding -------------------------------------------------------------

#' @export
scale_type.vctrs_vctr <- function(x) {
  "vctr"
}

# Range ggproto -----------------------------------------------------------

# ggproto
RangeVctr <- ggproto(
  "RangeContinuous",
  ggplot2:::Range,
  aes = NULL,
  train = function(self, x) {
    self$range <- train_vctr(x, self$range, self$aes)
  }
)

# vctr training
train_vctr <- function(new, existing = NULL, aes = NULL) {
  if (is.null(new)) {
    return(existing)
  }
  # Take range of the union of new and existing
  vec_range(new, existing, na.rm = TRUE, finite = TRUE, aes = aes)
}

# constructor of the ggproto
vctr_range <- function(aes) {
  ggproto(NULL, RangeVctr, aes = aes)
}

# Scale ggproto -----------------------------------------------------------

ScaleContinuousVctr <- ggproto(
  "ScaleContinuousVctr",
  ScaleContinuous,
  clone = function(self) {
    new <- ggproto(NULL, self)
    new$range <- vctr_range(new$aesthetics[1])
    new
  },
  map = function(self, x, limits = self$get_limits()) {
    scaled <- self$oob(x, range = limits)
    scaled[is.na(scaled)] <- vec_cast(self$na.value, scaled)
    scaled
  },
  get_breaks = function(self, limits = self$get_limits()) {
    # Reason for overriding get_breaks:
    # zero_range(as.numeric()) required coercing to numeric,
    # probably better to have vctr-classes define their own zero_range() method.
    if (self$is_empty()) {
      return(numeric())
    }

    limits <- self$trans$inverse(limits)

    if (is.null(self$breaks)) {
      return(NULL)
    }

    if (identical(self$breaks, NA)) {
      abort("Invalid breaks specification. Use NULL, not NA")
    }

    if (vec_zero_range(limits)) {
      breaks <- limits[1]
    } else if (inherits(self$breaks, "waiver")) {
      if (!is.null(self$n.breaks) && trans_support_nbreaks(self$trans)) {
        breaks <- self$trans$breaks(limits, self$n.breaks)
      } else {
        if (!is.null(self$n.breaks)) {
          warn("Ignoring n.breaks. Use a trans object that supports setting number of breaks")
        }
        breaks <- self$trans$breaks(limits)
      }
    } else if (is.function(self$breaks)) {
      breaks <- self$breaks(limits)
    } else {
      breaks <- self$breaks
    }

    # Breaks in data space need to be converted back to transformed space
    breaks <- self$trans$transform(breaks)
    # Any breaks outside the dimensions are flagged as missing
    breaks <- censor(breaks, self$trans$transform(limits), only.finite = FALSE)

    breaks
  },
  get_breaks_minor = function(self, n = 2, b = self$break_positions(), limits = self$get_limits()) {
    # Reason for overriding get_breaks_minor:
    # The reason for major breaks hold true for minor breaks as well
    # Also, discard doesn't work well with vectors
    if (vec_zero_range(limits)) {
      return()
    }

    if (is.null(self$minor_breaks)) {
      return(NULL)
    }

    if (identical(self$minor_breaks, NA)) {
      abort("Invalid minor_breaks specification. Use NULL, not NA")
    }

    if (inherits(self$minor_breaks, "waiver")) {
      if (is.null(b)) {
        breaks <- NULL
      } else {
        breaks <- self$trans$minor_breaks(b, limits, n)
      }
    } else if (is.function(self$minor_breaks)) {
      # Find breaks in data space, and convert to numeric
      breaks <- self$minor_breaks(self$trans$inverse(limits))
      breaks <- self$trans$transform(breaks)
    } else {
      breaks <- self$trans$transform(self$minor_breaks)
    }

    # Any minor breaks outside the dimensions need to be thrown away
    discard_oob(breaks, limits)
  },
  final_transformer = vec_force_flat
)