1
2#' Continuous scale constructor
3#'
4#' @export
5#' @param aesthetics The names of the aesthetics that this scale works with.
6#' @param scale_name The name of the scale that should be used for error messages
7#'   associated with this scale.
8#' @param palette A palette function that when called with a numeric vector with
9#'   values between 0 and 1 returns the corresponding output values
10#'   (e.g., [scales::area_pal()]).
11#' @param name The name of the scale. Used as the axis or legend title. If
12#'   `waiver()`, the default, the name of the scale is taken from the first
13#'   mapping used for that aesthetic. If `NULL`, the legend title will be
14#'   omitted.
15#' @param breaks One of:
16#'   - `NULL` for no breaks
17#'   - `waiver()` for the default breaks computed by the
18#'     [transformation object][scales::trans_new()]
19#'   - A numeric vector of positions
20#'   - A function that takes the limits as input and returns breaks
21#'     as output (e.g., a function returned by [scales::extended_breaks()]).
22#'     Also accepts rlang [lambda][rlang::as_function()] function notation.
23#' @param minor_breaks One of:
24#'   - `NULL` for no minor breaks
25#'   - `waiver()` for the default breaks (one minor break between
26#'     each major break)
27#'   - A numeric vector of positions
28#'   - A function that given the limits returns a vector of minor breaks. Also
29#'     accepts rlang [lambda][rlang::as_function()] function notation.
30#' @param n.breaks An integer guiding the number of major breaks. The algorithm
31#'   may choose a slightly different number to ensure nice break labels. Will
32#'   only have an effect if `breaks = waiver()`. Use `NULL` to use the default
33#'   number of breaks given by the transformation.
34#' @param labels One of:
35#'   - `NULL` for no labels
36#'   - `waiver()` for the default labels computed by the
37#'     transformation object
38#'   - A character vector giving labels (must be same length as `breaks`)
39#'   - A function that takes the breaks as input and returns labels
40#'     as output. Also accepts rlang [lambda][rlang::as_function()] function
41#'     notation.
42#' @param limits One of:
43#'   - `NULL` to use the default scale range
44#'   - A numeric vector of length two providing limits of the scale.
45#'     Use `NA` to refer to the existing minimum or maximum
46#'   - A function that accepts the existing (automatic) limits and returns
47#'     new limits. Also accepts rlang [lambda][rlang::as_function()] function
48#'     notation.
49#'   Note that setting limits on positional scales will **remove** data outside of the limits.
50#'   If the purpose is to zoom, use the limit argument in the coordinate system
51#'   (see [coord_cartesian()]).
52#' @param rescaler A function used to scale the input values to the
53#'   range \[0, 1]. This is always [scales::rescale()], except for
54#'   diverging and n colour gradients (i.e., [scale_colour_gradient2()],
55#'   [scale_colour_gradientn()]). The `rescaler` is ignored by position
56#'   scales, which always use [scales::rescale()]. Also accepts rlang
57#'   [lambda][rlang::as_function()] function notation.
58#' @param oob One of:
59#'   - Function that handles limits outside of the scale limits
60#'   (out of bounds). Also accepts rlang [lambda][rlang::as_function()]
61#'   function notation.
62#'   - The default ([scales::censor()]) replaces out of
63#'   bounds values with `NA`.
64#'   - [scales::squish()] for squishing out of bounds values into range.
65#'   - [scales::squish_infinite()] for squishing infinite values into range.
66#' @param na.value Missing values will be replaced with this value.
67#' @param trans For continuous scales, the name of a transformation object
68#'   or the object itself. Built-in transformations include "asn", "atanh",
69#'   "boxcox", "date", "exp", "hms", "identity", "log", "log10", "log1p", "log2",
70#'   "logit", "modulus", "probability", "probit", "pseudo_log", "reciprocal",
71#'   "reverse", "sqrt" and "time".
72#'
73#'   A transformation object bundles together a transform, its inverse,
74#'   and methods for generating breaks and labels. Transformation objects
75#'   are defined in the scales package, and are called `<name>_trans` (e.g.,
76#'   [scales::boxcox_trans()]). You can create your own
77#'   transformation with [scales::trans_new()].
78#' @param guide A function used to create a guide or its name. See
79#'   [guides()] for more information.
80#' @param expand For position scales, a vector of range expansion constants used to add some
81#'   padding around the data to ensure that they are placed some distance
82#'   away from the axes. Use the convenience function [expansion()]
83#'   to generate the values for the `expand` argument. The defaults are to
84#'   expand the scale by 5% on each side for continuous variables, and by
85#'   0.6 units on each side for discrete variables.
86#' @param position For position scales, The position of the axis.
87#' `left` or `right` for y axes, `top` or `bottom` for x axes.
88#' @param super The super class to use for the constructed scale
89#' @keywords internal
90continuous_scale <- function(aesthetics, scale_name, palette, name = waiver(),
91                             breaks = waiver(), minor_breaks = waiver(), n.breaks = NULL,
92                             labels = waiver(), limits = NULL, rescaler = rescale,
93                             oob = censor, expand = waiver(), na.value = NA_real_,
94                             trans = "identity", guide = "legend", position = "left",
95                             super = ScaleContinuous) {
96
97  aesthetics <- standardise_aes_names(aesthetics)
98
99  check_breaks_labels(breaks, labels)
100
101  position <- match.arg(position, c("left", "right", "top", "bottom"))
102
103  # If the scale is non-positional, break = NULL means removing the guide
104  if (is.null(breaks) && all(!is_position_aes(aesthetics))) {
105    guide <- "none"
106  }
107
108  trans <- as.trans(trans)
109  if (!is.null(limits) && !is.function(limits)) {
110    limits <- trans$transform(limits)
111  }
112
113  # Convert formula to function if appropriate
114  limits   <- allow_lambda(limits)
115  breaks   <- allow_lambda(breaks)
116  labels   <- allow_lambda(labels)
117  rescaler <- allow_lambda(rescaler)
118  oob      <- allow_lambda(oob)
119  minor_breaks <- allow_lambda(minor_breaks)
120
121  ggproto(NULL, super,
122    call = match.call(),
123
124    aesthetics = aesthetics,
125    scale_name = scale_name,
126    palette = palette,
127
128    range = continuous_range(),
129    limits = limits,
130    trans = trans,
131    na.value = na.value,
132    expand = expand,
133    rescaler = rescaler,
134    oob = oob,
135
136    name = name,
137    breaks = breaks,
138    minor_breaks = minor_breaks,
139    n.breaks = n.breaks,
140
141    labels = labels,
142    guide = guide,
143    position = position
144  )
145}
146
147#' Discrete scale constructor
148#'
149#' @export
150#' @inheritParams continuous_scale
151#' @param palette A palette function that when called with a single integer
152#'   argument (the number of levels in the scale) returns the values that
153#'   they should take (e.g., [scales::hue_pal()]).
154#' @param breaks One of:
155#'   - `NULL` for no breaks
156#'   - `waiver()` for the default breaks (the scale limits)
157#'   - A character vector of breaks
158#'   - A function that takes the limits as input and returns breaks
159#'     as output. Also accepts rlang [lambda][rlang::as_function()] function
160#'     notation.
161#' @param limits One of:
162#'   - `NULL` to use the default scale values
163#'   - A character vector that defines possible values of the scale and their
164#'     order
165#'   - A function that accepts the existing (automatic) values and returns
166#'     new ones. Also accepts rlang [lambda][rlang::as_function()] function
167#'     notation.
168#' @param drop Should unused factor levels be omitted from the scale?
169#'    The default, `TRUE`, uses the levels that appear in the data;
170#'    `FALSE` uses all the levels in the factor.
171#' @param na.translate Unlike continuous scales, discrete scales can easily show
172#'   missing values, and do so by default. If you want to remove missing values
173#'   from a discrete scale, specify `na.translate = FALSE`.
174#' @param na.value If `na.translate = TRUE`, what aesthetic value should the
175#'   missing values be displayed as? Does not apply to position scales
176#'   where `NA` is always placed at the far right.
177#' @keywords internal
178discrete_scale <- function(aesthetics, scale_name, palette, name = waiver(),
179                           breaks = waiver(), labels = waiver(), limits = NULL, expand = waiver(),
180                           na.translate = TRUE, na.value = NA, drop = TRUE,
181                           guide = "legend", position = "left", super = ScaleDiscrete) {
182
183  aesthetics <- standardise_aes_names(aesthetics)
184
185  check_breaks_labels(breaks, labels)
186
187  # Convert formula input to function if appropriate
188  limits <- allow_lambda(limits)
189  breaks <- allow_lambda(breaks)
190  labels <- allow_lambda(labels)
191
192  if (!is.function(limits) && (length(limits) > 0) && !is.discrete(limits)) {
193    warn(
194      glue(
195        "
196        Continuous limits supplied to discrete scale.
197        Did you mean `limits = factor(...)` or `scale_*_continuous()`?"
198      )
199    )
200  }
201
202  position <- match.arg(position, c("left", "right", "top", "bottom"))
203
204  # If the scale is non-positional, break = NULL means removing the guide
205  if (is.null(breaks) && all(!is_position_aes(aesthetics))) {
206    guide <- "none"
207  }
208
209  ggproto(NULL, super,
210    call = match.call(),
211
212    aesthetics = aesthetics,
213    scale_name = scale_name,
214    palette = palette,
215
216    range = discrete_range(),
217    limits = limits,
218    na.value = na.value,
219    na.translate = na.translate,
220    expand = expand,
221
222    name = name,
223    breaks = breaks,
224    labels = labels,
225    drop = drop,
226    guide = guide,
227    position = position
228  )
229}
230
231#' Binning scale constructor
232#'
233#' @export
234#' @inheritParams continuous_scale
235#' @param n.breaks The number of break points to create if breaks are not given
236#'   directly.
237#' @param nice.breaks Logical. Should breaks be attempted placed at nice values
238#'   instead of exactly evenly spaced between the limits. If `TRUE` (default)
239#'   the scale will ask the transformation object to create breaks, and this
240#'   may result in a different number of breaks than requested. Ignored if
241#'   breaks are given explicitly.
242#' @param right Should values on the border between bins be part of the right
243#'   (upper) bin?
244#' @param show.limits should the limits of the scale appear as ticks
245#' @keywords internal
246binned_scale <- function(aesthetics, scale_name, palette, name = waiver(),
247                         breaks = waiver(), labels = waiver(), limits = NULL,
248                         rescaler = rescale, oob = squish, expand = waiver(),
249                         na.value = NA_real_, n.breaks = NULL, nice.breaks = TRUE,
250                         right = TRUE, trans = "identity", show.limits = FALSE,
251                         guide = "bins", position = "left", super = ScaleBinned) {
252
253  aesthetics <- standardise_aes_names(aesthetics)
254
255  check_breaks_labels(breaks, labels)
256
257  position <- match.arg(position, c("left", "right", "top", "bottom"))
258
259  if (is.null(breaks) && !is_position_aes(aesthetics) && guide != "none") {
260    guide <- "none"
261  }
262
263  trans <- as.trans(trans)
264  if (!is.null(limits)) {
265    limits <- trans$transform(limits)
266  }
267
268  # Convert formula input to function if appropriate
269  limits   <- allow_lambda(limits)
270  breaks   <- allow_lambda(breaks)
271  labels   <- allow_lambda(labels)
272  rescaler <- allow_lambda(rescaler)
273  oob      <- allow_lambda(oob)
274
275  ggproto(NULL, super,
276    call = match.call(),
277
278    aesthetics = aesthetics,
279    scale_name = scale_name,
280    palette = palette,
281
282    range = continuous_range(),
283    limits = limits,
284    trans = trans,
285    na.value = na.value,
286    expand = expand,
287    rescaler = rescaler,
288    oob = oob,
289    n.breaks = n.breaks,
290    nice.breaks = nice.breaks,
291    right = right,
292    show.limits = show.limits,
293
294    name = name,
295    breaks = breaks,
296
297    labels = labels,
298    guide = guide,
299    position = position
300  )
301}
302
303#' @section Scales:
304#'
305#' All `scale_*` functions like [scale_x_continuous()] return a `Scale*`
306#' object like `ScaleContinuous`. Each of the `Scale*` objects is a [ggproto()]
307#' object, descended from the top-level `Scale`.
308#'
309#' Properties not documented in [continuous_scale()] or [discrete_scale()]:
310#'
311#' - `call` The call to [continuous_scale()] or [discrete_scale()] that constructed
312#'   the scale.
313#'
314#' - `range` One of `continuous_range()` or `discrete_range()`.
315#'
316#'
317#' Methods:
318#'
319#' - `is_discrete()` Returns `TRUE` if the scale is a discrete scale
320#'
321#' - `is_empty()` Returns `TRUE` if the scale contains no information (i.e.,
322#'   it has no information with which to calculate its `limits`).
323#'
324#' - `clone()` Returns a copy of the scale that can be trained
325#'   independently without affecting the original scale.
326#'
327#' - `transform()` Transforms a vector of values using `self$trans`.
328#'   This occurs before the `Stat` is calculated.
329#'
330#' - `train()` Update the `self$range` of observed (transformed) data values with
331#'   a vector of (possibly) new values.
332#'
333#' - `reset()` Reset the `self$range` of observed data values. For discrete
334#'   position scales, only the continuous range is reset.
335#'
336#' - `map()` Map transformed data values to some output value as
337#'   determined by `self$rescale()` and `self$palette` (except for position scales,
338#'   which do not use the default implementation of this method). The output corresponds
339#'   to the transformed data value in aesthetic space (e.g., a color, line width, or size).
340#'
341#' - `rescale()` Rescale transformed data to the the range 0, 1. This is most useful for
342#'   position scales. For continuous scales, `rescale()` uses the `rescaler` that
343#'   was provided to the constructor. `rescale()` does not apply `self$oob()` to
344#'   its input, which means that discrete values outside `limits` will be `NA`, and
345#'   values that are outside `range` will have values less than 0 or greater than 1.
346#'   This allows guides more control over how out-of-bounds values are displayed.
347#'
348#' - `transform_df()`, `train_df()`, `map_df()` These `_df` variants
349#'   accept a data frame, and apply the `transform`, `train`, and `map` methods
350#'   (respectively) to the columns whose names are in `self$aesthetics`.
351#'
352#' - `get_limits()` Calculates the final scale limits in transformed data space
353#'   based on the combination of `self$limits` and/or the range of observed values
354#'   (`self$range`).
355#'
356#' - `get_breaks()` Calculates the final scale breaks in transformed data space
357#'   based on on the combination of `self$breaks`, `self$trans$breaks()` (for
358#'   continuous scales), and `limits`. Breaks outside of `limits` are assigned
359#'   a value of `NA` (continuous scales) or dropped (discrete scales).
360#'
361#' - `get_labels()` Calculates labels for a given set of (transformed) `breaks`
362#'   based on the combination of `self$labels` and `breaks`.
363#'
364#' - `get_breaks_minor()` For continuous scales, calculates the final scale minor breaks
365#'   in transformed data space based on the rescaled `breaks`, the value of `self$minor_breaks`,
366#'   and the value of `self$trans$minor_breaks()`. Discrete scales always return `NULL`.
367#'
368#' - `make_title()` Hook to modify the title that is calculated during guide construction
369#'   (for non-position scales) or when the `Layout` calculates the x and y labels
370#'   (position scales).
371#'
372#' These methods are only valid for position (x and y) scales:
373#'
374#' - `dimension()` For continuous scales, the dimension is the same concept as the limits.
375#'   For discrete scales, `dimension()` returns a continuous range, where the limits
376#'   would be placed at integer positions. `dimension()` optionally expands
377#'   this range given an expantion of length 4 (see [expansion()]).
378#'
379#' - `break_info()` Returns a `list()` with calculated values needed for the `Coord`
380#'   to transform values in transformed data space. Axis and grid guides also use
381#'   these values to draw guides. This is called with
382#'   a (usually expanded) continuous range, such as that returned by `self$dimension()`
383#'   (even for discrete scales). The list has components `major_source`
384#'   (`self$get_breaks()` for continuous scales, or `seq_along(self$get_breaks())`
385#'   for discrete scales), `major` (the rescaled value of `major_source`, ignoring
386#'   `self$rescaler`), `minor` (the rescaled value of `minor_source`, ignoring
387#'   `self$rescaler`), `range` (the range that was passed in to `break_info()`),
388#'   `labels` (the label values, one for each element in `breaks`).
389#'
390#' - `axis_order()` One of `c("primary", "secondary")` or `c("secondary", "primary")`
391#'
392#' - `make_sec_title()` Hook to modify the title for the second axis that is calculated
393#'   when the `Layout` calculates the x and y labels.
394#'
395#' @rdname ggplot2-ggproto
396#' @format NULL
397#' @usage NULL
398#' @export
399Scale <- ggproto("Scale", NULL,
400
401  call = NULL,
402  aesthetics = aes(),
403  scale_name = NULL,
404  palette = function() {
405    abort("Not implemented")
406  },
407
408  range = ggproto(NULL, Range),
409  limits = NULL,
410  na.value = NA,
411  expand = waiver(),
412
413  name = waiver(),
414  breaks = waiver(),
415  labels = waiver(),
416  guide = "legend",
417  position = "left",
418
419
420  is_discrete = function() {
421    abort("Not implemented")
422  },
423
424  train_df = function(self, df) {
425    if (empty(df)) return()
426
427    aesthetics <- intersect(self$aesthetics, names(df))
428    for (aesthetic in aesthetics) {
429      self$train(df[[aesthetic]])
430    }
431    invisible()
432  },
433
434  train = function(self, x) {
435    abort("Not implemented")
436  },
437
438  reset = function(self) {
439    self$range$reset()
440  },
441
442  is_empty = function(self) {
443    is.null(self$range$range) && is.null(self$limits)
444  },
445
446  transform_df = function(self, df) {
447    if (empty(df)) {
448      return()
449    }
450
451    aesthetics <- intersect(self$aesthetics, names(df))
452    if (length(aesthetics) == 0) {
453      return()
454    }
455
456    lapply(df[aesthetics], self$transform)
457  },
458
459  transform = function(self, x) {
460    abort("Not implemented")
461  },
462
463  map_df = function(self, df, i = NULL) {
464    if (empty(df)) {
465      return()
466    }
467
468    aesthetics <- intersect(self$aesthetics, names(df))
469    names(aesthetics) <- aesthetics
470    if (length(aesthetics) == 0) {
471      return()
472    }
473
474    if (is.null(i)) {
475      lapply(aesthetics, function(j) self$map(df[[j]]))
476    } else {
477      lapply(aesthetics, function(j) self$map(df[[j]][i]))
478    }
479  },
480
481  map = function(self, x, limits = self$get_limits()) {
482    abort("Not implemented")
483  },
484
485  rescale = function(self, x, limits = self$get_limits(), range = self$dimension()) {
486    abort("Not implemented")
487  },
488
489  get_limits = function(self) {
490    if (self$is_empty()) {
491      return(c(0, 1))
492    }
493
494    if (is.null(self$limits)) {
495      self$range$range
496    } else if (is.function(self$limits)) {
497      self$limits(self$range$range)
498    } else {
499      self$limits
500    }
501  },
502
503  dimension = function(self, expand = expansion(0, 0), limits = self$get_limits()) {
504    abort("Not implemented")
505  },
506
507  get_breaks = function(self, limits = self$get_limits()) {
508    abort("Not implemented")
509  },
510
511  break_positions = function(self, range = self$get_limits()) {
512    self$map(self$get_breaks(range))
513  },
514
515  get_breaks_minor = function(self, n = 2, b = self$break_positions(), limits = self$get_limits()) {
516    abort("Not implemented")
517  },
518
519  get_labels = function(self, breaks = self$get_breaks()) {
520    abort("Not implemented")
521  },
522
523  clone = function(self) {
524    abort("Not implemented")
525  },
526
527  break_info = function(self, range = NULL) {
528    abort("Not implemented")
529  },
530
531  axis_order = function(self) {
532    ord <- c("primary", "secondary")
533    if (self$position %in% c("right", "bottom")) {
534      ord <- rev(ord)
535    }
536    ord
537  },
538
539  make_title = function(title) {
540    title
541  },
542
543  make_sec_title = function(title) {
544    title
545  }
546)
547
548check_breaks_labels <- function(breaks, labels) {
549  if (is.null(breaks)) {
550    return(TRUE)
551  }
552  if (is.null(labels)) {
553    return(TRUE)
554  }
555
556  bad_labels <- is.atomic(breaks) && is.atomic(labels) &&
557    length(breaks) != length(labels)
558  if (bad_labels) {
559    abort("`breaks` and `labels` must have the same length")
560  }
561
562  TRUE
563}
564
565
566#' @rdname ggplot2-ggproto
567#' @format NULL
568#' @usage NULL
569#' @export
570ScaleContinuous <- ggproto("ScaleContinuous", Scale,
571  range = continuous_range(),
572  na.value = NA_real_,
573  rescaler = rescale,
574  oob = censor,
575  minor_breaks = waiver(),
576  n.breaks = NULL,
577  trans = identity_trans(),
578
579  is_discrete = function() FALSE,
580
581  train = function(self, x) {
582    if (length(x) == 0) {
583      return()
584    }
585    self$range$train(x)
586  },
587
588  is_empty = function(self) {
589    has_data <- !is.null(self$range$range)
590    has_limits <- is.function(self$limits) || (!is.null(self$limits) && all(is.finite(self$limits)))
591    !has_data && !has_limits
592  },
593
594  transform = function(self, x) {
595    new_x <- self$trans$transform(x)
596    axis <- if ("x" %in% self$aesthetics) "x" else "y"
597    check_transformation(x, new_x, self$scale_name, axis)
598    new_x
599  },
600
601  map = function(self, x, limits = self$get_limits()) {
602    x <- self$rescale(self$oob(x, range = limits), limits)
603
604    uniq <- unique(x)
605    pal <- self$palette(uniq)
606    scaled <- pal[match(x, uniq)]
607
608    ifelse(!is.na(scaled), scaled, self$na.value)
609  },
610
611  rescale = function(self, x, limits = self$get_limits(), range = limits) {
612    self$rescaler(x, from = range)
613  },
614
615  get_limits = function(self) {
616    if (self$is_empty()) {
617      return(c(0, 1))
618    }
619
620    if (is.null(self$limits)) {
621      self$range$range
622    } else if (is.function(self$limits)) {
623      # if limits is a function, it expects to work in data space
624      self$trans$transform(self$limits(self$trans$inverse(self$range$range)))
625    } else {
626      # NA limits for a continuous scale mean replace with the min/max of data
627      ifelse(is.na(self$limits), self$range$range, self$limits)
628    }
629  },
630
631  dimension = function(self, expand = expansion(0, 0), limits = self$get_limits()) {
632    expand_limits_scale(self, expand, limits)
633  },
634
635  get_breaks = function(self, limits = self$get_limits()) {
636    if (self$is_empty()) {
637      return(numeric())
638    }
639
640    # Limits in transformed space need to be converted back to data space
641    limits <- self$trans$inverse(limits)
642
643    if (is.null(self$breaks)) {
644      return(NULL)
645    }
646
647    if (identical(self$breaks, NA)) {
648      abort("Invalid breaks specification. Use NULL, not NA")
649    }
650
651    if (zero_range(as.numeric(limits))) {
652      breaks <- limits[1]
653    } else if (is.waive(self$breaks)) {
654      if (!is.null(self$n.breaks) && trans_support_nbreaks(self$trans)) {
655        breaks <- self$trans$breaks(limits, self$n.breaks)
656      } else {
657        if (!is.null(self$n.breaks)) {
658          warn("Ignoring n.breaks. Use a trans object that supports setting number of breaks")
659        }
660        breaks <- self$trans$breaks(limits)
661      }
662    } else if (is.function(self$breaks)) {
663      breaks <- self$breaks(limits)
664    } else {
665      breaks <- self$breaks
666    }
667
668    # Breaks in data space need to be converted back to transformed space
669    breaks <- self$trans$transform(breaks)
670    # Any breaks outside the dimensions are flagged as missing
671    breaks <- censor(breaks, self$trans$transform(limits), only.finite = FALSE)
672
673    breaks
674  },
675
676  get_breaks_minor = function(self, n = 2, b = self$break_positions(), limits = self$get_limits()) {
677    if (zero_range(as.numeric(limits))) {
678      return()
679    }
680
681    if (is.null(self$minor_breaks)) {
682      return(NULL)
683    }
684
685    if (identical(self$minor_breaks, NA)) {
686      abort("Invalid minor_breaks specification. Use NULL, not NA")
687    }
688
689    if (is.waive(self$minor_breaks)) {
690      if (is.null(b)) {
691        breaks <- NULL
692      } else {
693        breaks <- self$trans$minor_breaks(b, limits, n)
694      }
695    } else if (is.function(self$minor_breaks)) {
696      # Find breaks in data space, and convert to numeric
697      breaks <- self$minor_breaks(self$trans$inverse(limits))
698      breaks <- self$trans$transform(breaks)
699    } else {
700      breaks <- self$trans$transform(self$minor_breaks)
701    }
702
703    # Any minor breaks outside the dimensions need to be thrown away
704    discard(breaks, limits)
705  },
706
707  get_labels = function(self, breaks = self$get_breaks()) {
708    if (is.null(breaks)) {
709      return(NULL)
710    }
711
712    breaks <- self$trans$inverse(breaks)
713
714    if (is.null(self$labels)) {
715      return(NULL)
716    }
717
718    if (identical(self$labels, NA)) {
719      abort("Invalid labels specification. Use NULL, not NA")
720    }
721
722    if (is.waive(self$labels)) {
723      labels <- self$trans$format(breaks)
724    } else if (is.function(self$labels)) {
725      labels <- self$labels(breaks)
726    } else {
727      labels <- self$labels
728    }
729
730    if (length(labels) != length(breaks)) {
731      abort("Breaks and labels are different lengths")
732    }
733    if (is.list(labels)) {
734      # Guard against list with empty elements
735      labels[vapply(labels, length, integer(1)) == 0] <- ""
736      # Make sure each element is scalar
737      labels <- lapply(labels, `[`, 1)
738
739      if (any(vapply(labels, is.language, logical(1)))) {
740        labels <- do.call(expression, labels)
741      } else {
742        labels <- unlist(labels)
743      }
744    }
745
746    labels
747  },
748
749  clone = function(self) {
750    new <- ggproto(NULL, self)
751    new$range <- continuous_range()
752    new
753  },
754
755  break_info = function(self, range = NULL) {
756    # range
757    if (is.null(range)) range <- self$dimension()
758
759    # major breaks
760    major <- self$get_breaks(range)
761
762    # labels
763    labels <- self$get_labels(major)
764
765    # drop oob breaks/labels by testing major == NA
766    if (!is.null(labels)) labels <- labels[!is.na(major)]
767    if (!is.null(major)) major <- major[!is.na(major)]
768
769    # minor breaks
770    minor <- self$get_breaks_minor(b = major, limits = range)
771    if (!is.null(minor)) minor <- minor[!is.na(minor)]
772
773    # rescale breaks [0, 1], which are used by coord/guide
774    major_n <- rescale(major, from = range)
775    minor_n <- rescale(minor, from = range)
776
777    list(
778      range = range,
779      labels = labels,
780      major = major_n,
781      minor = minor_n,
782      major_source = major,
783      minor_source = minor
784    )
785  },
786
787  print = function(self, ...) {
788    show_range <- function(x) paste0(formatC(x, digits = 3), collapse = " -- ")
789
790    cat("<", class(self)[[1]], ">\n", sep = "")
791    cat(" Range:  ", show_range(self$range$range), "\n", sep = "")
792    if (is.function(self$limits)) {
793      cat(" Limits: function()\n")
794    } else {
795      cat(" Limits: ", show_range(self$dimension()), "\n", sep = "")
796    }
797  }
798)
799
800
801#' @rdname ggplot2-ggproto
802#' @format NULL
803#' @usage NULL
804#' @export
805ScaleDiscrete <- ggproto("ScaleDiscrete", Scale,
806  drop = TRUE,
807  na.value = NA,
808  n.breaks.cache = NULL,
809  palette.cache = NULL,
810
811  is_discrete = function() TRUE,
812
813  train = function(self, x) {
814    if (length(x) == 0) {
815      return()
816    }
817    self$range$train(x, drop = self$drop, na.rm = !self$na.translate)
818  },
819
820  transform = function(x) {
821    x
822  },
823
824  map = function(self, x, limits = self$get_limits()) {
825    n <- sum(!is.na(limits))
826    if (!is.null(self$n.breaks.cache) && self$n.breaks.cache == n) {
827      pal <- self$palette.cache
828    } else {
829      if (!is.null(self$n.breaks.cache)) {
830        warn("Cached palette does not match requested")
831      }
832      pal <- self$palette(n)
833      self$palette.cache <- pal
834      self$n.breaks.cache <- n
835    }
836
837    if (!is_null(names(pal))) {
838      # if pal is named, limit the pal by the names first,
839      # then limit the values by the pal
840      idx_nomatch <- is.na(match(names(pal), limits))
841      pal[idx_nomatch] <- NA
842      pal_match <- pal[match(as.character(x), names(pal))]
843      pal_match <- unname(pal_match)
844    } else {
845      # if pal is not named, limit the values directly
846      pal_match <- pal[match(as.character(x), limits)]
847    }
848
849    if (self$na.translate) {
850      ifelse(is.na(x) | is.na(pal_match), self$na.value, pal_match)
851    } else {
852      pal_match
853    }
854  },
855
856  rescale = function(self, x, limits = self$get_limits(), range = c(1, length(limits))) {
857    rescale(x, match(as.character(x), limits), from = range)
858  },
859
860  dimension = function(self, expand = expansion(0, 0), limits = self$get_limits()) {
861    expand_limits_discrete(limits, expand = expand)
862  },
863
864  get_breaks = function(self, limits = self$get_limits()) {
865    if (self$is_empty()) {
866      return(numeric())
867    }
868
869    if (is.null(self$breaks)) {
870      return(NULL)
871    }
872
873    if (identical(self$breaks, NA)) {
874      abort("Invalid breaks specification. Use NULL, not NA")
875    }
876
877    if (is.waive(self$breaks)) {
878      breaks <- limits
879    } else if (is.function(self$breaks)) {
880      breaks <- self$breaks(limits)
881    } else {
882      breaks <- self$breaks
883    }
884
885    # Breaks only occur only on values in domain
886    in_domain <- intersect(breaks, limits)
887    structure(in_domain, pos = match(in_domain, breaks))
888  },
889
890  get_breaks_minor = function(...) NULL,
891
892  get_labels = function(self, breaks = self$get_breaks()) {
893    if (self$is_empty()) {
894      return(character())
895    }
896
897    if (is.null(breaks)) {
898      return(NULL)
899    }
900
901    if (is.null(self$labels)) {
902      return(NULL)
903    }
904
905    if (identical(self$labels, NA)) {
906      abort("Invalid labels specification. Use NULL, not NA")
907    }
908
909    if (is.waive(self$labels)) {
910      if (is.numeric(breaks)) {
911        # Only format numbers, because on Windows, format messes up encoding
912        format(breaks, justify = "none")
913      } else {
914        as.character(breaks)
915      }
916    } else if (is.function(self$labels)) {
917      self$labels(breaks)
918    } else {
919      if (!is.null(names(self$labels))) {
920        # If labels have names, use them to match with breaks
921        labels <- breaks
922
923        map <- match(names(self$labels), labels, nomatch = 0)
924        labels[map] <- self$labels[map != 0]
925        labels
926      } else {
927        labels <- self$labels
928
929        # Need to ensure that if breaks were dropped, corresponding labels are too
930        pos <- attr(breaks, "pos")
931        if (!is.null(pos)) {
932          labels <- labels[pos]
933        }
934        labels
935      }
936    }
937  },
938
939  clone = function(self) {
940    new <- ggproto(NULL, self)
941    new$range <- discrete_range()
942    new
943  },
944
945  break_info = function(self, range = NULL) {
946    # for discrete, limits != range
947    limits <- self$get_limits()
948
949    major <- self$get_breaks(limits)
950    if (is.null(major)) {
951      labels <- major_n <- NULL
952    } else {
953
954      labels <- self$get_labels(major)
955
956      major <- self$map(major)
957      major <- major[!is.na(major)]
958
959      # rescale breaks [0, 1], which are used by coord/guide
960      major_n <- rescale(major, from = range)
961    }
962
963    list(
964      range = range,
965      labels = labels,
966      major = major_n,
967      minor = NULL,
968      major_source = major,
969      minor_source = NULL
970    )
971  }
972)
973
974#' @rdname ggplot2-ggproto
975#' @format NULL
976#' @usage NULL
977#' @export
978ScaleBinned <- ggproto("ScaleBinned", Scale,
979  range = continuous_range(),
980  na.value = NA_real_,
981  rescaler = rescale,
982  oob = squish,
983  n.breaks = NULL,
984  nice.breaks = TRUE,
985  right = TRUE,
986  after.stat = FALSE,
987  show.limits = FALSE,
988
989  is_discrete = function() FALSE,
990
991  train = function(self, x) {
992    if (!is.numeric(x)) {
993      abort("Binned scales only support continuous data")
994    }
995
996    if (length(x) == 0) {
997      return()
998    }
999    self$range$train(x)
1000  },
1001
1002  transform = function(self, x) {
1003    new_x <- self$trans$transform(x)
1004    axis <- if ("x" %in% self$aesthetics) "x" else "y"
1005    check_transformation(x, new_x, self$scale_name, axis)
1006    new_x
1007  },
1008
1009  map = function(self, x, limits = self$get_limits()) {
1010    if (self$after.stat) {
1011      x
1012    } else {
1013      breaks <- self$get_breaks(limits)
1014      breaks <- sort(unique(c(limits[1], breaks, limits[2])))
1015
1016      x <- self$rescale(self$oob(x, range = limits), limits)
1017      breaks <- self$rescale(breaks, limits)
1018
1019      x_binned <- cut(x, breaks,
1020        labels = FALSE,
1021        include.lowest = TRUE,
1022        right = self$right
1023      )
1024
1025      if (!is.null(self$palette.cache)) {
1026        pal <- self$palette.cache
1027      } else {
1028        pal <- self$palette(breaks[-1] - diff(breaks) / 2)
1029        self$palette.cache <- pal
1030      }
1031
1032      scaled <- pal[x_binned]
1033      ifelse(!is.na(scaled), scaled, self$na.value)
1034    }
1035  },
1036
1037  rescale = function(self, x, limits = self$get_limits(), range = limits) {
1038    self$rescaler(x, from = range)
1039  },
1040
1041  dimension = function(self, expand = c(0, 0, 0, 0)) {
1042    expand_range4(self$get_limits(), expand)
1043  },
1044
1045  get_breaks = function(self, limits = self$get_limits()) {
1046    if (self$is_empty()) return(numeric())
1047
1048    limits <- self$trans$inverse(limits)
1049
1050    if (is.null(self$breaks)) {
1051      return(NULL)
1052    } else if (identical(self$breaks, NA)) {
1053      abort("Invalid breaks specification. Use NULL, not NA")
1054    } else if (is.waive(self$breaks)) {
1055      if (self$nice.breaks) {
1056        if (!is.null(self$n.breaks) && trans_support_nbreaks(self$trans)) {
1057          breaks <- self$trans$breaks(limits, n = self$n.breaks)
1058        } else {
1059          if (!is.null(self$n.breaks)) {
1060            warn("Ignoring n.breaks. Use a trans object that supports setting number of breaks")
1061          }
1062          breaks <- self$trans$breaks(limits)
1063        }
1064      } else {
1065        n.breaks <- self$n.breaks %||% 5 # same default as trans objects
1066        breaks <- seq(limits[1], limits[2], length.out = n.breaks + 2)
1067        breaks <- breaks[-c(1, length(breaks))]
1068      }
1069
1070      # Ensure terminal bins are same width if limits not set
1071      if (is.null(self$limits)) {
1072        # Remove calculated breaks if they coincide with limits
1073        breaks <- setdiff(breaks, limits)
1074        nbreaks <- length(breaks)
1075        if (nbreaks >= 2) {
1076          new_limits <- c(2 * breaks[1] - breaks[2], 2 * breaks[nbreaks] - breaks[nbreaks - 1])
1077          if (breaks[nbreaks] > limits[2]) {
1078            new_limits[2] <- breaks[nbreaks]
1079            breaks <- breaks[-nbreaks]
1080          }
1081          if (breaks[1] < limits[1]) {
1082            new_limits[1] <- breaks[1]
1083            breaks <- breaks[-1]
1084          }
1085          limits <- new_limits
1086        } else {
1087          bin_size <- max(breaks[1] - limits[1], limits[2] - breaks[1])
1088          limits <- c(breaks[1] - bin_size, breaks[1] + bin_size)
1089        }
1090        self$limits <- self$trans$transform(limits)
1091      }
1092    } else if (is.function(self$breaks)) {
1093      if ("n.breaks" %in% names(formals(environment(self$breaks)$f))) {
1094        n.breaks <- self$n.breaks %||% 5 # same default as trans objects
1095        breaks <- self$breaks(limits, n.breaks = n.breaks)
1096      } else {
1097        if (!is.null(self$n.breaks)) {
1098          warn("Ignoring n.breaks. Use a breaks function that supports setting number of breaks")
1099        }
1100        breaks <- self$breaks(limits)
1101      }
1102    } else {
1103      breaks <- self$breaks
1104    }
1105
1106    # Breaks must be within limits
1107    breaks <- breaks[breaks >= limits[1] & breaks <= limits[2]]
1108    self$breaks <- breaks
1109
1110    self$trans$transform(breaks)
1111  },
1112
1113  get_breaks_minor = function(...) NULL,
1114
1115  get_labels = function(self, breaks = self$get_breaks()) {
1116    if (is.null(breaks)) return(NULL)
1117
1118    breaks <- self$trans$inverse(breaks)
1119
1120    if (is.null(self$labels)) {
1121      return(NULL)
1122    } else if (identical(self$labels, NA)) {
1123      abort("Invalid labels specification. Use NULL, not NA")
1124    } else if (is.waive(self$labels)) {
1125      labels <- self$trans$format(breaks)
1126    } else if (is.function(self$labels)) {
1127      labels <- self$labels(breaks)
1128    } else {
1129      labels <- self$labels
1130    }
1131    if (length(labels) != length(breaks)) {
1132      abort("Breaks and labels are different lengths")
1133    }
1134    labels
1135  },
1136
1137  clone = function(self) {
1138    new <- ggproto(NULL, self)
1139    new$range <- continuous_range()
1140    new
1141  },
1142
1143  break_info = function(self, range = NULL) {
1144    # range
1145    if (is.null(range)) range <- self$dimension()
1146
1147    # major breaks
1148    major <- self$get_breaks(range)
1149
1150    if (!is.null(self$palette.cache)) {
1151      pal <- self$palette.cache
1152    } else {
1153      pal <- self$palette(length(major) + 1)
1154    }
1155
1156    if (self$show.limits) {
1157      limits <- self$get_limits()
1158      major <- sort(unique(c(limits, major)))
1159    }
1160
1161    # labels
1162    labels <- self$get_labels(major)
1163
1164    list(range = range, labels = labels,
1165         major = pal, minor = NULL,
1166         major_source = major, minor_source = NULL)
1167  }
1168)
1169
1170# In place modification of a scale to change the primary axis
1171scale_flip_position <- function(scale) {
1172  scale$position <- switch(scale$position,
1173    top = "bottom",
1174    bottom = "top",
1175    left = "right",
1176    right = "left",
1177    scale$position
1178  )
1179  invisible()
1180}
1181
1182check_transformation <- function(x, transformed, name, axis) {
1183  if (any(is.finite(x) != is.finite(transformed))) {
1184    type <- if (name == "position_b") {
1185      "binned"
1186    } else if (name == "position_c") {
1187      "continuous"
1188    } else {
1189      "discrete"
1190    }
1191    warn(glue("Transformation introduced infinite values in {type} {axis}-axis"))
1192  }
1193}
1194
1195trans_support_nbreaks <- function(trans) {
1196  "n" %in% names(formals(trans$breaks))
1197}
1198
1199allow_lambda <- function(x) {
1200  if (is_formula(x)) as_function(x) else x
1201}
1202