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