1#' Positional scales for binning continuous data (x & y)
2#'
3#' `scale_x_binned()` and `scale_y_binned()` are scales that discretize
4#' continuous position data. You can use these scales to transform continuous
5#' inputs before using it with a geom that requires discrete positions. An
6#' example is using `scale_x_binned()` with [geom_bar()] to create a histogram.
7#'
8#' @inheritParams binned_scale
9#'
10#' @family position scales
11#' @name scale_binned
12#' @aliases NULL
13#'
14#' @examples
15#' # Create a histogram by binning the x-axis
16#' ggplot(mtcars) +
17#'   geom_bar(aes(mpg)) +
18#'   scale_x_binned()
19NULL
20
21#' @rdname scale_binned
22#'
23#' @export
24scale_x_binned <- function(name = waiver(), n.breaks = 10, nice.breaks = TRUE,
25                           breaks = waiver(), labels = waiver(), limits = NULL,
26                           expand = waiver(), oob = squish, na.value = NA_real_,
27                           right = TRUE, show.limits = FALSE, trans = "identity",
28                           guide = waiver(), position = "bottom") {
29  binned_scale(
30    ggplot_global$x_aes,
31    scale_name = "position_b", palette = identity, name = name, breaks = breaks,
32    labels = labels, limits = limits, expand = expand, oob = oob, na.value = na.value,
33    n.breaks = n.breaks, nice.breaks = nice.breaks, right = right, trans = trans,
34    show.limits = show.limits, guide = guide, position = position, super = ScaleBinnedPosition
35  )
36}
37
38#' @rdname scale_binned
39#'
40#' @export
41scale_y_binned <- function(name = waiver(), n.breaks = 10, nice.breaks = TRUE,
42                           breaks = waiver(), labels = waiver(), limits = NULL,
43                           expand = waiver(), oob = squish, na.value = NA_real_,
44                           right = TRUE, show.limits = FALSE, trans = "identity",
45                           guide = waiver(), position = "left") {
46  binned_scale(
47    ggplot_global$y_aes,
48    scale_name = "position_b", palette = identity, name = name, breaks = breaks,
49    labels = labels, limits = limits, expand = expand, oob = oob, na.value = na.value,
50    n.breaks = n.breaks, nice.breaks = nice.breaks, right = right, trans = trans,
51    show.limits = show.limits, guide = guide, position = position, super = ScaleBinnedPosition
52  )
53}
54
55#' @rdname ggplot2-ggproto
56#' @format NULL
57#' @usage NULL
58#' @export
59ScaleBinnedPosition <- ggproto("ScaleBinnedPosition", ScaleBinned,
60  after.stat = FALSE,
61
62  train = function(self, x) {
63    if (!is.numeric(x)) {
64      abort("Binned scales only support continuous data")
65    }
66
67    if (length(x) == 0 || self$after.stat) return()
68    self$range$train(x)
69  },
70
71  map = function(self, x, limits = self$get_limits()) {
72    breaks <- self$get_breaks(limits)
73    all_breaks <- unique(sort(c(limits[1], breaks, limits[2])))
74
75    if (self$after.stat) {
76      # Backtransform to original scale
77      x_binned <- cut(x, seq_len(length(all_breaks) + 1) - 0.5,
78        labels = FALSE,
79        include.lowest = TRUE,
80        right = self$right
81      )
82      (x - x_binned + .5) * diff(all_breaks)[x_binned] + all_breaks[x_binned]
83    } else {
84      x <- as.numeric(self$oob(x, limits))
85      x <- ifelse(!is.na(x), x, self$na.value)
86      x_binned <- cut(x, all_breaks,
87        labels = FALSE,
88        include.lowest = TRUE,
89        right = self$right
90      )
91
92      x_binned # Return integer form so stat treat it like a discrete scale
93    }
94  },
95  reset = function(self) {
96    self$after.stat <- TRUE
97    limits <- self$get_limits()
98    breaks <- self$get_breaks(limits)
99    self$range$reset()
100    self$range$train(c(limits, breaks))
101  },
102
103  get_breaks = function(self, limits = self$get_limits()) {
104    breaks <- ggproto_parent(ScaleBinned, self)$get_breaks(limits)
105    if (self$show.limits) {
106      breaks <- sort(unique(c(self$get_limits(), breaks)))
107    }
108    breaks
109  }
110)
111