diff --git a/DESCRIPTION b/DESCRIPTION index 022d9c6172..22f4670da0 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -173,20 +173,21 @@ Collate: 'grob-dotstack.R' 'grob-null.R' 'grouping.R' + 'guide-.R' + 'guide-axis.R' + 'guide-legend.R' 'guide-bins.R' 'guide-colorbar.R' 'guide-colorsteps.R' - 'guide-legend.R' + 'layer.R' + 'guide-none.R' 'guides-.R' - 'guides-axis.R' 'guides-grid.R' - 'guides-none.R' 'hexbin.R' 'import-standalone-obj-type.R' 'import-standalone-types-check.R' 'labeller.R' 'labels.R' - 'layer.R' 'layer-sf.R' 'layout.R' 'limits.R' diff --git a/NAMESPACE b/NAMESPACE index 21f2e522fa..41676e5022 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -55,12 +55,12 @@ S3method(ggplot_add,"NULL") S3method(ggplot_add,"function") S3method(ggplot_add,Coord) S3method(ggplot_add,Facet) +S3method(ggplot_add,Guides) S3method(ggplot_add,Layer) S3method(ggplot_add,Scale) S3method(ggplot_add,by) S3method(ggplot_add,data.frame) S3method(ggplot_add,default) -S3method(ggplot_add,guides) S3method(ggplot_add,labels) S3method(ggplot_add,list) S3method(ggplot_add,theme) @@ -75,30 +75,6 @@ S3method(grobWidth,absoluteGrob) S3method(grobWidth,zeroGrob) S3method(grobX,absoluteGrob) S3method(grobY,absoluteGrob) -S3method(guide_gengrob,axis) -S3method(guide_gengrob,bins) -S3method(guide_gengrob,colorbar) -S3method(guide_gengrob,guide_none) -S3method(guide_gengrob,legend) -S3method(guide_geom,axis) -S3method(guide_geom,bins) -S3method(guide_geom,colorbar) -S3method(guide_geom,guide_none) -S3method(guide_geom,legend) -S3method(guide_merge,axis) -S3method(guide_merge,bins) -S3method(guide_merge,colorbar) -S3method(guide_merge,guide_none) -S3method(guide_merge,legend) -S3method(guide_train,axis) -S3method(guide_train,bins) -S3method(guide_train,colorbar) -S3method(guide_train,colorsteps) -S3method(guide_train,guide_none) -S3method(guide_train,legend) -S3method(guide_transform,axis) -S3method(guide_transform,default) -S3method(guide_transform,guide_none) S3method(heightDetails,titleGrob) S3method(heightDetails,zeroGrob) S3method(interleave,default) @@ -228,6 +204,13 @@ export(GeomText) export(GeomTile) export(GeomViolin) export(GeomVline) +export(Guide) +export(GuideAxis) +export(GuideBins) +export(GuideColourbar) +export(GuideColoursteps) +export(GuideLegend) +export(GuideNone) export(Layout) export(Position) export(PositionDodge) @@ -433,13 +416,8 @@ export(guide_colorbar) export(guide_colorsteps) export(guide_colourbar) export(guide_coloursteps) -export(guide_gengrob) -export(guide_geom) export(guide_legend) -export(guide_merge) export(guide_none) -export(guide_train) -export(guide_transform) export(guides) export(has_flipped_aes) export(is.Coord) @@ -472,6 +450,7 @@ export(mean_sdl) export(mean_se) export(median_hilow) export(merge_element) +export(new_guide) export(panel_cols) export(panel_rows) export(position_dodge) diff --git a/NEWS.md b/NEWS.md index fc37b8305b..a205faf2ea 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,28 @@ # ggplot2 (development version) +* The guide system, as the last remaining chunk of ggplot2, has been rewritten + in ggproto. The axes and legends now inherit from a class, which makes + them extensible in the same manner as geoms, stats, facets and coords + (#3329, @teunbrand). In addition, the following changes were made: + * Styling theme parts of the guide now inherit from the plot's theme + (#2728). + * Styling non-theme parts of the guides accept objects, so that + the following is possible: `guide_colourbar(frame = element_rect(...))`. + * Primary axis titles are now placed at the primary guide, so that + `guides(x = guide_axis(position = "top"))` will display the title at the + top by default (#4650). + * Unknown secondary axis guide positions are now inferred as the opposite + of the primary axis guide when the latter has a known `position` (#4650). + * `guide_colourbar()`, `guide_coloursteps()` and `guide_bins()` gain a + `ticks.length` argument. + * In `guide_bins()`, the title no longer arbitrarily becomes offset from + the guide when it has long labels. + * The `order` argument of guides now strictly needs to be a length-1 + integer (#4958). + * More informative error for mismatched + `direction`/`theme(legend.direction = ...)` arguments (#4364, #4930). + * `guide_coloursteps()` and `guide_bins()` sort breaks (#5152). + * `geom_label()` now uses the `angle` aesthetic (@teunbrand, #2785) * 'lines' units in `geom_label()`, often used in the `label.padding` argument, are now are relative to the text size. This causes a visual change, but fixes diff --git a/R/coord-.R b/R/coord-.R index d08756da0a..46deae8444 100644 --- a/R/coord-.R +++ b/R/coord-.R @@ -60,31 +60,7 @@ Coord <- ggproto("Coord", aspect = function(ranges) NULL, labels = function(self, labels, panel_params) { - # If panel params contains guides information, use it. - # Otherwise use the labels as is, for backward-compatibility - if (is.null(panel_params$guides)) { - return(labels) - } - - positions_x <- c("top", "bottom") - positions_y <- c("left", "right") - - list( - x = lapply(c(1, 2), function(i) { - panel_guide_label( - panel_params$guides, - position = positions_x[[i]], - default_label = labels$x[[i]] - ) - }), - y = lapply(c(1, 2), function(i) { - panel_guide_label( - panel_params$guides, - position = positions_y[[i]], - default_label = labels$y[[i]] - ) - }) - ) + labels }, render_fg = function(panel_params, theme) element_render(theme, "panel.border"), @@ -120,58 +96,75 @@ Coord <- ggproto("Coord", setup_panel_guides = function(self, panel_params, guides, params = list()) { aesthetics <- c("x", "y", "x.sec", "y.sec") names(aesthetics) <- aesthetics + is_sec <- grepl("sec$", aesthetics) + + # Do guide setup + guides <- guides$setup( + panel_params, aesthetics, + default = params$guide_default %||% guide_axis(), + missing = params$guide_missing %||% guide_none() + ) + guide_params <- guides$get_params(aesthetics) + + # Resolve positions + scale_position <- lapply(panel_params[aesthetics], `[[`, "position") + guide_position <- lapply(guide_params, `[[`, "position") + guide_position[!is_sec] <- Map( + function(guide, scale) guide %|W|% scale, + guide = guide_position[!is_sec], + scale = scale_position[!is_sec] + ) + opposite <- c( + "top" = "bottom", "bottom" = "top", + "left" = "right", "right" = "left" + ) + guide_position[is_sec] <- Map( + function(sec, prim) sec %|W|% unname(opposite[prim]), + sec = guide_position[is_sec], + prim = guide_position[!is_sec] + ) + guide_params <- Map( + function(params, pos) { + params[["position"]] <- pos + params + }, + params = guide_params, + pos = guide_position + ) - # If the panel_params doesn't contain the scale, do not use a guide for that aesthetic - idx <- vapply(aesthetics, function(aesthetic) { - scale <- panel_params[[aesthetic]] - !is.null(scale) && inherits(scale, "ViewScale") - }, logical(1L)) - aesthetics <- aesthetics[idx] - - # resolve the specified guide from the scale and/or guides - guides <- lapply(aesthetics, function(aesthetic) { - resolve_guide( - aesthetic, - panel_params[[aesthetic]], - guides, - default = guide_axis(), - null = guide_none() - ) - }) - - # resolve the guide definition as a "guide" S3 - guides <- lapply(guides, validate_guide) - - # if there is a "position" specification in the scale, pass this on to the guide - # ideally, this should be specified in the guide - guides <- lapply(aesthetics, function(aesthetic) { - guide <- guides[[aesthetic]] - scale <- panel_params[[aesthetic]] - # position could be NULL here for an empty scale - guide$position <- guide$position %|W|% scale$position - guide - }) + # Update positions + guides$update_params(guide_params) panel_params$guides <- guides panel_params }, - train_panel_guides = function(self, panel_params, layers, default_mapping, params = list()) { + train_panel_guides = function(self, panel_params, layers, params = list()) { + aesthetics <- c("x", "y", "x.sec", "y.sec") # If the panel_params doesn't contain the scale, there's no guide for the aesthetic - aesthetics <- intersect(aesthetics, names(panel_params$guides)) - + aesthetics <- intersect(aesthetics, names(panel_params$guides$aesthetics)) names(aesthetics) <- aesthetics - panel_params$guides <- lapply(aesthetics, function(aesthetic) { - axis <- substr(aesthetic, 1, 1) - guide <- panel_params$guides[[aesthetic]] - guide <- guide_train(guide, panel_params[[aesthetic]]) - guide <- guide_transform(guide, self, panel_params) - guide <- guide_geom(guide, layers, default_mapping) - guide - }) + guides <- panel_params$guides$get_guide(aesthetics) + empty <- vapply(guides, inherits, logical(1), "GuideNone") + guide_params <- panel_params$guides$get_params(aesthetics) + aesthetics <- aesthetics[!empty] + + guide_params[!empty] <- Map( + function(guide, guide_param, scale) { + guide_param <- guide$train(guide_param, scale) + guide_param <- guide$transform(guide_param, self, panel_params) + guide_param <- guide$get_layer_key(guide_param, layers) + guide_param + }, + guide = guides[!empty], + guide_param = guide_params[!empty], + scale = panel_params[aesthetics] + ) + + panel_params$guides$update_params(guide_params) panel_params }, @@ -187,7 +180,10 @@ Coord <- ggproto("Coord", is_free = function() FALSE, setup_params = function(data) { - list() + list( + guide_default = guide_axis(), + guide_missing = guide_none() + ) }, setup_data = function(data, params = list()) { diff --git a/R/coord-cartesian-.R b/R/coord-cartesian-.R index d4d3181b90..cf4f5d31bd 100644 --- a/R/coord-cartesian-.R +++ b/R/coord-cartesian-.R @@ -144,24 +144,38 @@ view_scales_from_scale <- function(scale, coord_limits = NULL, expand = TRUE) { view_scales } -panel_guide_label <- function(guides, position, default_label) { - guide <- guide_for_position(guides, position) %||% guide_none(title = waiver()) - guide$title %|W|% default_label -} - panel_guides_grob <- function(guides, position, theme) { - guide <- guide_for_position(guides, position) %||% guide_none() - guide_gengrob(guide, theme) + pair <- guide_for_position(guides, position) %||% + list(guide = guide_none(), params = NULL) + pair$guide$draw(theme, pair$params) } guide_for_position <- function(guides, position) { + params <- guides$params has_position <- vapply( - guides, - function(guide) identical(guide$position, position), - logical(1) + params, function(p) identical(p$position, position), logical(1) ) + if (!any(has_position)) { + return(NULL) + } + + # Subset guides and parameters + guides <- guides$get_guide(has_position) + params <- params[has_position] + # Pair up guides with parameters + pairs <- Map(list, guide = guides, params = params) - guides <- guides[has_position] - guides_order <- vapply(guides, function(guide) as.numeric(guide$order)[1], numeric(1)) - Reduce(guide_merge, guides[order(guides_order)]) + # Early exit, nothing to merge + if (length(pairs) == 1) { + return(pairs[[1]]) + } + + # TODO: There must be a smarter way to merge these + order <- order(vapply(params, function(p) as.numeric(p$order), numeric(1))) + Reduce( + function(old, new) { + old$guide$merge(old$params, new$guide, new$params) + }, + pairs[order] + ) } diff --git a/R/coord-polar.R b/R/coord-polar.R index 61d74e31ab..f9bb6395da 100644 --- a/R/coord-polar.R +++ b/R/coord-polar.R @@ -154,6 +154,14 @@ CoordPolar <- ggproto("CoordPolar", Coord, details }, + setup_panel_guides = function(self, panel_params, guides, params = list()) { + panel_params + }, + + train_panel_guides = function(self, panel_params, layers, default_mapping, params = list()) { + panel_params + }, + transform = function(self, data, panel_params) { data <- rename_data(self, data) diff --git a/R/guide-.R b/R/guide-.R new file mode 100644 index 0000000000..a1c194bf99 --- /dev/null +++ b/R/guide-.R @@ -0,0 +1,344 @@ +#' Guide constructor +#' +#' A constructor function for guides, which performs some standard compatability +#' checks between the guide and provided arguments. +#' +#' @param ... Named arguments that match the parameters of `super$params` or +#' the theme elements in `super$elements`. +#' @param available_aes A vector of character strings listing the aesthetics +#' for which the guide can be drawn. +#' @param super The super class to use for the constructed guide. Should be a +#' Guide class object. +#' +#' @return A `Guide` ggproto object. +#' @keywords internal +#' @export +new_guide <- function(..., available_aes = "any", super) { + + pf <- parent.frame() + super <- check_subclass(super, "Guide", env = pf) + + args <- list2(...) + + # Set parameters + param_names <- names(super$params) + params <- intersect(names(args), param_names) + params <- defaults(args[params], super$params) + + # Set elements + elems_names <- names(super$elements) + elems <- intersect(names(args), elems_names) + elems <- defaults(args[elems], super$elements) + + # Warn about extra arguments + extra_args <- setdiff(names(args), union(param_names, elems_names)) + if (length(extra_args) > 0) { + cli::cli_warn(paste0( + "Ignoring unknown {cli::qty(extra_args)} argument{?s} to ", + "{.fn {snake_class(super)}}: {.arg {extra_args}}." + )) + } + + # Stop when some required parameters are missing. + # This should only happen with mis-constructed guides + required_params <- names(Guide$params) + missing_params <- setdiff(required_params, names(params)) + if (length(missing_params) > 0) { + cli::cli_abort(paste0( + "The following parameter{?s} {?is/are} required for setting up a guide, ", + "but {?is/are} missing: {.field {missing_params}}" + )) + } + + # Ensure 'order' is length 1 integer + params$order <- vec_cast(params$order, 0L, x_arg = "order", call = pf) + vec_assert(params$order, 0L, size = 1L, arg = "order", call = pf) + + ggproto( + NULL, super, + params = params, + elements = elems, + available_aes = available_aes + ) +} + +#' @section Guides: +#' +#' The `guide_*()` functions, such as `guide_legend()` return an object that +#' is responsible for displaying how objects in the plotting panel are related +#' to actual values. +#' +#' Each of the `Guide*` object is a [ggproto()] object, descended from the +#' top-level `Guide`, and each implements their own methods for drawing. +#' +#' To create a new type of Guide object, you typically will want to override +#' one or more of the following: +#' +#' TODO: Fill this in properly +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +Guide <- ggproto( + "Guide", + + # `params` is a list of initial parameters that gets updated upon + # construction. After construction, parameters are manged by the + # `GuidesList` class. + params = list( + title = waiver(), + name = character(), + position = waiver(), + direction = NULL, + order = 0, + hash = character() + ), + + # A list of theme elements that should be calculated + elements = list(), + + # The aesthetics for which this guide is appropriate + available_aes = character(), + + # The `hashables` are the parameters of the guide that are used to generate a + # unique hash that determines whether other guides are compatible. + hashables = exprs(title, name), + + # Training has the task of updating parameters based the scale. + # There are 3 sub-tasks: + # 1. Extract a key from the scale + # 2. (Optionally) extract further decoration from the scale (e.g. the + # colour bar). + # 3. Extract further parameters + train = function(self, params = self$params, scale, aesthetic = NULL, ...) { + params$aesthetic <- aesthetic %||% scale$aesthetics[1] + params$key <- inject(self$extract_key(scale, !!!params)) + if (is.null(params$key)) { + return(NULL) + } + params$decor <- inject(self$extract_decor(scale, !!!params)) + self$extract_params(scale, params, self$hashables, ...) + }, + + # Setup parameters that are only available after training + # TODO: Maybe we only need the hash on demand during merging? + extract_params = function(scale, params, hashables, ...) { + # Make hash + params$hash <- hash(lapply(unname(hashables), eval_tidy, data = params)) + params + }, + + # Function for generating a `key` data.frame from the scale + extract_key = function(scale, aesthetic, ...) { + breaks <- scale$get_breaks() + if (length(breaks) == 0) { + return(NULL) + } + + mapped <- scale$map(breaks) + labels <- scale$get_labels(breaks) + + key <- data_frame(mapped, .name_repair = ~ aesthetic) + key$.value <- breaks + key$.label <- labels + + if (is.numeric(breaks)) { + key[is.finite(breaks), , drop = FALSE] + } else { + key + } + }, + + # Function for extracting decoration from the scale. + # This is for `guide_colourbar` to extract the bar as well as the key, + # and might be a good extension point. + extract_decor = function(scale, aesthetic, ...) { + return(invisible()) # By default, nothing else needs to be extracted + }, + + # Function for merging multiple guides. + # Mostly applies to `guide_legend()` and `guide_binned()`. + # Defaults to returning the *other* guide, because this parent class is + # mostly a virtual class and children should implement their own merges. + merge = function(self, params, new_guide, new_params) { + return(list(guide = new_guide, params = new_params)) + }, + + # Function for applying coord-transformation. + # Mostly applied to position guides, such as `guide_axis()`. + transform = function(self, params, coord, ...) { + cli::cli_abort(c( + "{.fn {snake_class(self)}} does not implement a {.fn transform} method.", + "i" = "Did you mean to use {.fn guide_axis}?" + )) + }, + + # Function for extracting information from the layers. + # Mostly applies to `guide_legend()` and `guide_binned()` + get_layer_key = function(params, layers) { + return(params) + }, + + # Called at start of the `draw` method. Typically used to either overrule + # user-specified parameters or populate extra parameters derived from + # the guide's direction or position. + setup_params = function(params) { + params + }, + + # Converts the `elements` field to proper elements to be accepted by + # `element_grob()`. String-interpolates aesthetic/position dependent elements. + setup_elements = function(params, elements, theme) { + is_char <- vapply(elements, is.character, logical(1)) + elements[is_char] <- lapply(elements[is_char], calc_element, theme = theme) + elements + }, + + # Called after `setup_elements` to overrule any element defaults descended + # from the theme. + override_elements = function(params, elements, theme) { + elements + }, + + # Main drawing function that organises more specialised aspects of guide + # drawing. + draw = function(self, theme, params = self$params) { + + key <- params$key + + # Setup parameters and theme + params <- self$setup_params(params) + elems <- self$setup_elements(params, self$elements, theme) + elems <- self$override_elements(params, elems, theme) + + # Allow early exit when key is empty + if (prod(dim(key)) == 0) { + out <- self$draw_early_exit(params, elems) + return(out) + } + + # Build grobs + grobs <- list( + title = self$build_title(params$title, elems, params), + labels = self$build_labels(key, elems, params), + ticks = self$build_ticks(key, elems, params) + ) + grobs$decor <- self$build_decor(params$decor, grobs, elems, params) + + # Arrange and assemble grobs + sizes <- self$measure_grobs(grobs, params, elems) + layout <- self$arrange_layout(key, sizes, params) + self$assemble_drawing(grobs, layout, sizes, params, elems) + }, + + # Makes measurements of grobs that can be used in the layout or assembly + # stages of guide drawing. + measure_grobs = function(grobs, params, elements) { + return(invisible()) + }, + + # Takes care of where grobs should be added to the output gtable. + arrange_layout = function(key, sizes, params) { + return(invisible()) + }, + + # Combines grobs into a single gtable. + assemble_drawing = function(grobs, layout, sizes, params, elements) { + zeroGrob() + }, + + # Renders the guide title + build_title = function(label, elements, params) { + ggname( + "guide.title", + element_grob( + elements$title, + label = label, + margin_x = TRUE, + margin_y = TRUE + ) + ) + }, + + # Renders the guide labels + # TODO: See if we can generalise label drawing for many guides + build_labels = function(key, elements, params) { + zeroGrob() + }, + + # Renders 'decor', which can have different meanings for different guides. + # The other grobs are provided, as a colourbar might use the ticks for example + build_decor = function(decor, grobs, elements, params) { + zeroGrob() + }, + + # Renders tickmarks + build_ticks = function(key, elements, params, position = params$position) { + + if (!is.list(key)) { + breaks <- key + } else { + breaks <- key[[params$aes]] + } + n_breaks <- length(breaks) + + # Early exit if there are no breaks + if (n_breaks < 1) { + return(zeroGrob()) + } + + tick_len <- rep(elements$ticks_length %||% unit(0.2, "npc"), + length.out = n_breaks) + + # Resolve mark + mark <- unit(rep(breaks, each = 2), "npc") + + # Resolve ticks + pos <- unname(c(top = 1, bottom = 0, left = 0, right = 1)[position]) + dir <- -2 * pos + 1 + pos <- unit(rep(pos, 2 * n_breaks), "npc") + dir <- rep(vec_interleave(0, dir), n_breaks) * tick_len + tick <- pos + dir + + # Build grob + flip_element_grob( + elements$ticks, + x = tick, y = mark, + id.lengths = rep(2, n_breaks), + flip = position %in% c("top", "bottom") + ) + }, + + draw_early_exit = function(self, params, elements) { + zeroGrob() + } +) + +# Helper function that may facilitate flipping theme elements by +# swapping x/y related arguments to `element_grob()` +flip_element_grob = function(..., flip = FALSE) { + if (!flip) { + ans <- element_grob(...) + return(ans) + } + args <- list(...) + translate <- names(args) %in% names(flip_names) + names(args)[translate] <- flip_names[names(args)[translate]] + do.call(element_grob, args) +} + +# The flippable arguments for `flip_element_grob()`. +flip_names = c( + "x" = "y", + "y" = "x", + "width" = "height", + "height" = "width", + "hjust" = "vjust", + "vjust" = "hjust", + "margin_x" = "margin_y", + "margin_y" = "margin_x" +) + +# Shortcut for position argument matching +.trbl <- c("top", "right", "bottom", "left") + diff --git a/R/guide-axis.R b/R/guide-axis.R new file mode 100644 index 0000000000..221157fb7f --- /dev/null +++ b/R/guide-axis.R @@ -0,0 +1,498 @@ + +#' Axis guide +#' +#' Axis guides are the visual representation of position scales like those +#' created with [scale_(x|y)_continuous()][scale_x_continuous()] and +#' [scale_(x|y)_discrete()][scale_x_discrete()]. +#' +#' @inheritParams guide_legend +#' @param check.overlap silently remove overlapping labels, +#' (recursively) prioritizing the first, last, and middle labels. +#' @param angle Compared to setting the angle in [theme()] / [element_text()], +#' this also uses some heuristics to automatically pick the `hjust` and `vjust` that +#' you probably want. +#' @param n.dodge The number of rows (for vertical axes) or columns (for +#' horizontal axes) that should be used to render the labels. This is +#' useful for displaying labels that would otherwise overlap. +#' @param order A positive `integer` of length 1 that specifies the order of +#' this guide among multiple guides. This controls in which order guides are +#' merged if there are multiple guides for the same position. If 0 (default), +#' the order is determined by a secret algorithm. +#' @param position Where this guide should be drawn: one of top, bottom, +#' left, or right. +#' +#' @export +#' +#' @examples +#' # plot with overlapping text +#' p <- ggplot(mpg, aes(cty * 100, hwy * 100)) + +#' geom_point() + +#' facet_wrap(vars(class)) +#' +#' # axis guides can be customized in the scale_* functions or +#' # using guides() +#' p + scale_x_continuous(guide = guide_axis(n.dodge = 2)) +#' p + guides(x = guide_axis(angle = 90)) +#' +#' # can also be used to add a duplicate guide +#' p + guides(x = guide_axis(n.dodge = 2), y.sec = guide_axis()) +guide_axis <- function(title = waiver(), check.overlap = FALSE, angle = NULL, + n.dodge = 1, order = 0, position = waiver()) { + new_guide( + title = title, + + # customisations + check.overlap = check.overlap, + angle = angle, + n.dodge = n.dodge, + + # parameter + available_aes = c("x", "y"), + + # general + order = order, + position = position, + name = "axis", + super = GuideAxis + ) +} + +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +GuideAxis <- ggproto( + "GuideAxis", Guide, + + params = list( + title = waiver(), + name = "axis", + hash = character(), + position = waiver(), + direction = NULL, + angle = NULL, + n.dodge = 1, + order = 0, + check.overlap = FALSE + ), + + available_aes = c("x", "y"), + + hashables = exprs(title, key$.value, key$.label, name), + + elements = list( + line = "axis.line", + text = "axis.text", + ticks = "axis.ticks", + ticks_length = "axis.ticks.length" + ), + + extract_params = function(scale, params, hashables, ...) { + params$name <- paste0(params$name, "_", params$aesthetic) + Guide$extract_params(scale, params, hashables) + }, + + transform = function(self, params, coord, panel_params) { + key <- params$key + position <- params$position + + if (is.null(position) || nrow(key) == 0) { + return(params) + } + + aesthetics <- names(key)[!grepl("^\\.", names(key))] + if (!all(c("x", "y") %in% aesthetics)) { + other_aesthetic <- setdiff(c("x", "y"), aesthetics) + override_value <- if (position %in% c("bottom", "left")) -Inf else Inf + key[[other_aesthetic]] <- override_value + } + key <- coord$transform(key, panel_params) + params$key <- key + + # Ported over from `warn_for_position_guide` + # This is trying to catch when a user specifies a position perpendicular + # to the direction of the axis (e.g., a "y" axis on "top"). + # The strategy is to check that two or more unique breaks are mapped + # to the same value along the axis. + breaks_are_unique <- !duplicated(key$.value) + if (empty(key) || sum(breaks_are_unique) == 1) { + return(params) + } + + if (position %in% c("top", "bottom")) { + position_aes <- "x" + } else if (position %in% c("left", "right")) { + position_aes <- "y" + } else { + return(params) + } + + if (length(unique(key[[position_aes]][breaks_are_unique])) == 1) { + cli::cli_warn(c( + "Position guide is perpendicular to the intended axis.", + "i" = "Did you mean to specify a different guide {.arg position}?" + )) + } + + return(params) + }, + + merge = function(self, params, new_guide, new_params) { + if (!inherits(new_guide, "GuideNone")) { + cli::cli_warn(c( + "{.fn {snake_class(self)}}: Discarding guide on merge.", + "i" = "Do you have more than one guide with the same {.arg position}?" + )) + } + return(list(guide = self, params = params)) + }, + + setup_elements = function(params, elements, theme) { + axis_elem <- c("line", "text", "ticks", "ticks_length") + is_char <- vapply(elements[axis_elem], is.character, logical(1)) + axis_elem <- axis_elem[is_char] + elements[axis_elem] <- lapply( + paste( + unlist(elements[axis_elem]), + params$aes, params$position, sep = "." + ), + calc_element, theme = theme + ) + elements + }, + + override_elements = function(params, elements, theme) { + label <- elements$text + if (!inherits(label, "element_text")) { + return(elements) + } + label_overrides <- axis_label_element_overrides( + params$position, params$angle + ) + # label_overrides is an element_text, but label_element may not be; + # to merge the two elements, we just copy angle, hjust, and vjust + # unless their values are NULL + label$angle <- label_overrides$angle %||% label$angle + label$hjust <- label_overrides$hjust %||% label$hjust + label$vjust <- label_overrides$vjust %||% label$vjust + + elements$text <- label + return(elements) + }, + + setup_params = function(params) { + position <- arg_match0(params$position, .trbl) + direction <- if (position %in% c("left", "right")) { + "vertical" + } else { + "horizontal" + } + + # TODO: delete following comment at some point: + # I found the 'position_*'/'non-position_*' and '*_dim' names confusing. + # For my own understanding, these have been renamed as follows: + # * 'aes' and 'orth_aes' for the aesthetic direction and the direction + # orthogonal to the aesthetic direction, respectively. + # * 'para_sizes' and 'orth_size(s)' for the dimension parallel to the + # aesthetic and orthogonal to the aesthetic respectively. + # I also tried to trim down the verbosity of the variable names a bit + + new_params <- c("aes", "orth_aes", "para_sizes", "orth_size", "orth_sizes", + "vertical", "measure_gtable", "measure_text") + if (direction == "vertical") { + params[new_params] <- list( + "y", "x", "heights", "width", "widths", + TRUE, gtable_width, grobWidth + ) + } else { + params[new_params] <- list( + "x", "y", "widths", "height", "heights", + FALSE, gtable_height, grobHeight + ) + } + + new_params <- list( + opposite = unname(setNames(.trbl, .trbl[c(3,4,1,2)])[position]), + secondary = position %in% c("top", "right"), + lab_first = position %in% c("top", "left"), + orth_side = if (position %in% c("top", "right")) 0 else 1, + direction = direction, + position = position + ) + c(params, new_params) + }, + + build_title = function(label, elements, params) { + zeroGrob() + }, + + # The decor in the axis guide is the axis line + build_decor = function(decor, grobs, elements, params) { + exec( + element_grob, + element = elements$line, + !!params$aes := unit(c(0, 1), "npc"), + !!params$orth_aes := unit(rep(params$orth_side, 2), "npc") + ) + }, + + build_labels = function(key, elements, params) { + labels <- key$.label + n_labels <- length(labels) + + if (n_labels < 1) { + return(list(zeroGrob())) + } + + pos <- key[[params$aes]] + + if (is.list(labels)) { + if (any(vapply(labels, is.language, logical(1)))) { + labels <- do.call(expression, labels) + } else { + labels <- unlist(labels) + } + } + + dodge_pos <- rep(seq_len(params$n.dodge %||% 1), length.out = n_labels) + dodge_indices <- unname(split(seq_len(n_labels), dodge_pos)) + + lapply(dodge_indices, function(indices) { + draw_axis_labels( + break_positions = pos[indices], + break_labels = labels[indices], + label_element = elements$text, + is_vertical = params$vertical, + check.overlap = params$check.overlap %||% FALSE + ) + }) + }, + + measure_grobs = function(grobs, params, elements) { + + # Below, we include a spacer measurement. This measurement is used + # to offset subsequent rows/columns in the gtable in case the tick length is + # negative. This causes the text to align nicely at panel borders. + # In case tick length is positive, this will just be a 0-size empty row + # or column. + + measure <- params$measure_text + + length <- elements$ticks_length + spacer <- max(unit(0, "pt"), -1 * length) + labels <- do.call(unit.c, lapply(grobs$label, measure)) + title <- measure(grobs$title) + + sizes <- unit.c(length, spacer, labels, title) + if (params$lab_first) { + sizes <- rev(sizes) + } + sizes + }, + + arrange_layout = function(key, sizes, params) { + + layout <- seq_along(sizes) + + if (params$lab_first) { + layout <- rev(layout) + } + # Set gap for spacer + layout <- layout[-2] + + layout <- list(1, -1, layout, layout) + nms <- if (params$vertical) c("t", "b", "l", "r") else c("l", "r", "t", "b") + setNames(layout, nms) + }, + + assemble_drawing = function(grobs, layout, sizes, params, elements) { + + axis_line <- grobs$decor + + # Unlist the 'label' grobs + z <- if (params$position == "left") c(2, 1, 3) else 1:3 + z <- rep(z, c(1, length(grobs$label), 1)) + grobs <- c(list(grobs$ticks), grobs$label, list(grobs$title)) + + # Initialise empty gtable + gt <- exec( + gtable, + !!params$orth_sizes := sizes, + !!params$para_sizes := unit(1, "npc"), + name = "axis" + ) + + # Add grobs + gt <- gtable_add_grob( + gt, grobs, + t = layout$t, b = layout$b, l = layout$l, r = layout$r, + clip = "off", z = z + ) + + # Set justification viewport + vp <- exec( + viewport, + !!params$orth_aes := unit(params$orth_side, "npc"), + !!params$orth_size := params$measure_gtable(gt), + just = params$opposite + ) + + # Assemble with axis line + absoluteGrob( + gList(axis_line, gt), + width = gtable_width(gt), + height = gtable_height(gt), + vp = vp + ) + }, + + draw_early_exit = function(self, params, elements) { + line <- self$build_decor(elements = elements, params = params) + absoluteGrob( + gList(line), + width = grobWidth(line), + height = grobHeight(line) + ) + } +) + +# TODO: If #3972 gets implemented, reconsider the usefulness of this function. +# We still need the `draw_axis` function because most coords other than +# `coord_cartesian()` ignore guides. See #3972 + +#' Grob for axes +#' +#' @param break_position position of ticks +#' @param break_labels labels at ticks +#' @param axis_position position of axis (top, bottom, left or right) +#' @param theme A complete [theme()] object +#' @param check.overlap silently remove overlapping labels, +#' (recursively) prioritizing the first, last, and middle labels. +#' @param angle Compared to setting the angle in [theme()] / [element_text()], +#' this also uses some heuristics to automatically pick the `hjust` and `vjust` that +#' you probably want. +#' @param n.dodge The number of rows (for vertical axes) or columns (for +#' horizontal axes) that should be used to render the labels. This is +#' useful for displaying labels that would otherwise overlap. +#' +#' @noRd +#' +draw_axis <- function(break_positions, break_labels, axis_position, theme, + check.overlap = FALSE, angle = NULL, n.dodge = 1) { + guide <- guide_axis(check.overlap = check.overlap, + angle = angle, + n.dodge = n.dodge, + position = axis_position) + params <- guide$params + aes <- if (axis_position %in% c("top", "bottom")) "x" else "y" + key <- data_frame( + break_positions, break_positions, break_labels, + .name_repair = ~ c(aes, ".value", ".label") + ) + params$key <- key + guide$draw(theme, params) +} + +draw_axis_labels <- function(break_positions, break_labels, label_element, is_vertical, + check.overlap = FALSE) { + + position_dim <- if (is_vertical) "y" else "x" + label_margin_name <- if (is_vertical) "margin_x" else "margin_y" + + n_breaks <- length(break_positions) + break_positions <- unit(break_positions, "native") + + if (check.overlap) { + priority <- axis_label_priority(n_breaks) + break_labels <- break_labels[priority] + break_positions <- break_positions[priority] + } + + labels_grob <- exec( + element_grob, label_element, + !!position_dim := break_positions, + !!label_margin_name := TRUE, + label = break_labels, + check.overlap = check.overlap + ) +} + +#' Determine the label priority for a given number of labels +#' +#' @param n The number of labels +#' +#' @return The vector `seq_len(n)` arranged such that the +#' first, last, and middle elements are recursively +#' placed at the beginning of the vector. +#' @noRd +#' +axis_label_priority <- function(n) { + if (n <= 0) { + return(numeric(0)) + } + + c(1, n, axis_label_priority_between(1, n)) +} + +axis_label_priority_between <- function(x, y) { + n <- y - x + 1 + if (n <= 2) { + return(numeric(0)) + } + + mid <- x - 1 + (n + 1) %/% 2 + c( + mid, + axis_label_priority_between(x, mid), + axis_label_priority_between(mid, y) + ) +} + +#' Override axis text angle and alignment +#' +#' @param axis_position One of bottom, left, top, or right +#' @param angle The text angle, or NULL to override nothing +#' +#' @return An [element_text()] that contains parameters that should be +#' overridden from the user- or theme-supplied element. +#' @noRd +#' +axis_label_element_overrides <- function(axis_position, angle = NULL) { + if (is.null(angle)) { + return(element_text(angle = NULL, hjust = NULL, vjust = NULL)) + } + + # it is not worth the effort to align upside-down labels properly + check_number_decimal(angle, min = -90, max = 90) + + if (axis_position == "bottom") { + element_text( + angle = angle, + hjust = if (angle > 0) 1 else if (angle < 0) 0 else 0.5, + vjust = if (abs(angle) == 90) 0.5 else 1 + ) + } else if (axis_position == "left") { + element_text( + angle = angle, + hjust = if (abs(angle) == 90) 0.5 else 1, + vjust = if (angle > 0) 0 else if (angle < 0) 1 else 0.5, + ) + } else if (axis_position == "top") { + element_text( + angle = angle, + hjust = if (angle > 0) 0 else if (angle < 0) 1 else 0.5, + vjust = if (abs(angle) == 90) 0.5 else 0 + ) + } else if (axis_position == "right") { + element_text( + angle = angle, + hjust = if (abs(angle) == 90) 0.5 else 0, + vjust = if (angle > 0) 1 else if (angle < 0) 0 else 0.5, + ) + } else { + cli::cli_abort(c( + "Unrecognized {.arg axis_position}: {.val {axis_position}}", + "i" = "Use one of {.val top}, {.val bottom}, {.val left} or {.val right}" + )) + } +} diff --git a/R/guide-bins.R b/R/guide-bins.R index 362e35f7b2..bfdd9d0701 100644 --- a/R/guide-bins.R +++ b/R/guide-bins.R @@ -1,3 +1,6 @@ +#' @include guide-legend.R +NULL + #' A binned version of guide_legend #' #' This guide is a version of the [guide_legend()] guide for binned scales. It @@ -8,7 +11,11 @@ #' guide if they are mapped in the same way. #' #' @inheritParams guide_legend -#' @param axis Logical. Should a small axis be drawn along the guide +#' @param axis A theme object for rendering a small axis along the guide. +#' Usually, the object of `element_line()` is expected (default). If +#' `element_blank()`, no axis is drawn. For backward compatibility, can also +#' be a logical which translates `TRUE` to `element_line()` and `FALSE` to +#' `element_blank()`. #' @param axis.colour,axis.linewidth Graphic specifications for the look of the #' axis. #' @param axis.arrow A call to `arrow()` to specify arrows at the end of the @@ -18,6 +25,12 @@ #' scale. This argument is ignored if `labels` is given as a vector of #' values. If one or both of the limits is also given in `breaks` it will be #' shown irrespective of the value of `show.limits`. +#' @param ticks A theme object for rendering tick marks at the colourbar. +#' Usually, the object of `element_line()` is expected. If `element_blank()`, +#' no tick marks are drawn. If `NULL` (default), the `axis` argument is +#' re-used as `ticks` argument (without arrow). +#' @param ticks.length A numeric or a [grid::unit()] object specifying the +#' length of tick marks between the keys. #' #' @section Use with discrete scale: #' This guide is intended to show binned data and work together with ggplot2's @@ -62,37 +75,76 @@ guide_bins <- function( # title title = waiver(), title.position = NULL, - title.theme = NULL, - title.hjust = NULL, - title.vjust = NULL, + title.theme = NULL, + title.hjust = NULL, + title.vjust = NULL, # label - label = TRUE, + label = TRUE, label.position = NULL, - label.theme = NULL, - label.hjust = NULL, - label.vjust = NULL, + label.theme = NULL, + label.hjust = NULL, + label.vjust = NULL, # key - keywidth = NULL, + keywidth = NULL, keyheight = NULL, # ticks - axis = TRUE, - axis.colour = "black", - axis.linewidth = 0.5, - axis.arrow = NULL, + axis = TRUE, + axis.colour = "black", + axis.linewidth = NULL, + axis.arrow = NULL, + + ticks = NULL, + ticks.length = unit(0.2, "npc"), # general - direction = NULL, + direction = NULL, default.unit = "line", override.aes = list(), - reverse = FALSE, - order = 0, - show.limits = NULL, - ...) { + reverse = FALSE, + order = 0, + show.limits = NULL, + ... +) { + + if (!(is.null(keywidth) || is.unit(keywidth))) { + keywidth <- unit(keywidth, default.unit) + } + if (!(is.null(keyheight) || is.unit(keyheight))) { + keyheight <- unit(keyheight, default.unit) + } + if (!is.unit(ticks.length)) { + ticks.length <- unit(ticks.length, default.unit) + } + if (!is.null(title.position)) { + title.position <- arg_match0(title.position, .trbl) + } + if (!is.null(direction)) { + direction <- arg_match0(direction, c("horizontal", "vertical")) + } + if (!is.null(label.position)) { + label.position <- arg_match0(label.position, .trbl) + } - structure(list2( + if (is.logical(axis)) { + axis <- if (axis) element_line() else element_rect() + } + if (inherits(axis, "element_line")) { + axis$colour <- axis.colour %||% axis$colour %||% "black" + axis$linewidth <- axis.linewidth %||% axis$linewidth %||% (0.5 / .pt) + axis$arrow <- axis.arrow %||% axis$arrow + } else { + axis <- element_blank() + } + + if (is.null(ticks)) { + ticks <- axis + ticks$arrow <- NULL + } + + new_guide( # title title = title, title.position = title.position, @@ -108,19 +160,17 @@ guide_bins <- function( label.vjust = label.vjust, # key - keywidth = keywidth, + keywidth = keywidth, keyheight = keyheight, # ticks - axis = axis, - axis.colour = axis.colour, - axis.linewidth = axis.linewidth, - axis.arrow = axis.arrow, + line = axis, + ticks = ticks, + ticks_length = ticks.length, # general direction = direction, override.aes = rename_aes(override.aes), - default.unit = default.unit, reverse = reverse, order = order, show.limits = show.limits, @@ -128,520 +178,283 @@ guide_bins <- function( # parameter available_aes = c("any"), ..., - name = "bins"), - class = c("guide", "bins") + name = "bins", + super = GuideBins ) } +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL #' @export -guide_train.bins <- function(guide, scale, aesthetic = NULL) { - breaks <- scale$get_breaks() - breaks <- breaks[!is.na(breaks)] - if (length(breaks) == 0 || all(is.na(breaks))) { - return() - } - show_limits <- guide$show.limits %||% scale$show.limits %||% FALSE - if (show_limits && (is.character(scale$labels) || is.numeric(scale$labels))) { - cli::cli_warn(c( - "{.arg show.limits} is ignored when {.arg labels} are given as a character vector", - "i" = "Either add the limits to {.arg breaks} or provide a function for {.arg labels}" - )) - show_limits <- FALSE - } - # in the key data frame, use either the aesthetic provided as - # argument to this function or, as a fall back, the first in the vector - # of possible aesthetics handled by the scale - aes_column_name <- aesthetic %||% scale$aesthetics[1] - - if (is.numeric(breaks)) { - limits <- scale$get_limits() - if (!is.numeric(scale$breaks)) { - breaks <- breaks[!breaks %in% limits] - } - all_breaks <- unique0(c(limits[1], breaks, limits[2])) - bin_at <- all_breaks[-1] - diff(all_breaks) / 2 - } else { - # If the breaks are not numeric it is used with a discrete scale. We check - # if the breaks follow the allowed format "(, ]", and if it - # does we convert it into bin specs - bin_at <- breaks - breaks <- as.character(breaks) - breaks <- strsplit(gsub("\\(|\\)|\\[|\\]", "", breaks), ",\\s?") - breaks <- as.numeric(unlist(breaks)) - if (anyNA(breaks)) { - cli::cli_abort(c( - "Breaks not formatted correctly for a bin legend.", - "i" = "Use {.code (, ]} format to indicate bins" - )) - } - all_breaks <- breaks[c(1, seq_along(bin_at) * 2)] - limits <- all_breaks[c(1, length(all_breaks))] - breaks <- all_breaks[-c(1, length(all_breaks))] - } - key <- data_frame(c(scale$map(bin_at), NA), .name_repair = ~ aes_column_name) - labels <- scale$get_labels(breaks) - show_limits <- rep(show_limits, 2) - if (is.character(scale$labels) || is.numeric(scale$labels)) { - limit_lab <- c(NA, NA) - } else { - limit_lab <- scale$get_labels(limits) - } - if (!breaks[1] %in% limits) { - labels <- c(limit_lab[1], labels) - } else { - show_limits[1] <- TRUE - } - if (!breaks[length(breaks)] %in% limits) { - labels <- c(labels, limit_lab[2]) - } else { - show_limits[2] <- TRUE - } - key$.label <- labels - guide$show.limits <- show_limits - - if (guide$reverse) { - key <- key[rev(seq_len(nrow(key))), ] - # Move last row back to last - aesthetics <- setdiff(names(key), ".label") - key[, aesthetics] <- key[c(seq_len(nrow(key))[-1], 1), aesthetics] - } +GuideBins <- ggproto( + "GuideBins", GuideLegend, + + params = list( + title = waiver(), + title.position = NULL, + title.theme = NULL, + title.hjust = NULL, + title.vjust = NULL, + + label = TRUE, + label.position = NULL, + label.theme = NULL, + label.hjust = NULL, + label.vjust = NULL, + + keywidth = NULL, + keyheight = NULL, + + direction = NULL, + override.aes = list(), + reverse = FALSE, + order = 0, + show.limits = FALSE, + + name = "bins", + hash = character(), + position = NULL, + direction = NULL + ), + + elements = c( + GuideLegend$elements, + list( + line = "line", + ticks = "line", + ticks_length = unit(0.2, "npc") + ) + ), - guide$key <- key - guide$hash <- with( - guide, - hash(list(title, key$.label, direction, name)) - ) - guide -} + extract_key = function(scale, aesthetic, show.limits = FALSE, + reverse = FALSE, ...) { -#' @export -guide_merge.bins <- function(guide, new_guide) { - guide$key <- merge(guide$key, new_guide$key, sort = FALSE) - guide$override.aes <- c(guide$override.aes, new_guide$override.aes) - if (any(duplicated(names(guide$override.aes)))) { - cli::cli_warn("Duplicated {.arg override.aes} is ignored.") - } - guide$override.aes <- guide$override.aes[!duplicated(names(guide$override.aes))] - guide -} + breaks <- scale$get_breaks() -#' @export -guide_geom.bins <- function(guide, layers, default_mapping) { - # arrange common data for vertical and horizontal guide - guide$geoms <- lapply(layers, function(layer) { - matched <- matched_aes(layer, guide) + parsed <- parse_binned_breaks(scale, breaks) + if (is.null(parsed)) { + return(parsed) + } + limits <- parsed$limits + breaks <- parsed$breaks - # check if this layer should be included - include <- include_layer_in_guide(layer, matched) + key <- data_frame(c(scale$map(parsed$bin_at), NA), + .name_repair = ~ aesthetic) + key$.value <- (seq_along(key[[1]]) - 1) / (nrow(key) - 1) + key$.show <- NA - if (!include) { - return(NULL) + labels <- scale$get_labels(breaks) + if (is.character(scale$labels) || is.numeric(scale$labels)) { + limit_lab <- c(NA, NA) + } else { + limit_lab <- scale$get_labels(limits) } - - if (length(matched) > 0) { - # Filter out set aesthetics that can't be applied to the legend - n <- lengths(layer$aes_params) - params <- layer$aes_params[n == 1] - - aesthetics <- layer$computed_mapping - modifiers <- aesthetics[is_scaled_aes(aesthetics) | is_staged_aes(aesthetics)] - - data <- try_fetch( - layer$geom$use_defaults(guide$key[matched], params, modifiers), - error = function(cnd) { - cli::cli_warn("Failed to apply {.fn after_scale} modifications to legend", parent = cnd) - layer$geom$use_defaults(guide$key[matched], params, list()) - } - ) + if (!breaks[1] %in% limits) { + labels <- c(limit_lab[1], labels) + } else { + key$.show[1] <- TRUE + } + if (!breaks[length(breaks)] %in% limits) { + labels <- c(labels, limit_lab[2]) } else { - data <- layer$geom$use_defaults(NULL, layer$aes_params)[rep(1, nrow(guide$key)), ] + key$.show[nrow(key)] <- TRUE } - # override.aes in guide_legend manually changes the geom - data <- modify_list(data, guide$override.aes) + key$.label <- labels - list( - draw_key = layer$geom$draw_key, - data = data, - params = c(layer$computed_geom_params, layer$computed_stat_params) - ) - }) + return(key) + }, - # remove null geom - guide$geoms <- compact(guide$geoms) + extract_params = function(scale, params, hashables, + title = waiver(), direction = NULL, ...) { - # Finally, remove this guide if no layer is drawn - if (length(guide$geoms) == 0) guide <- NULL - guide -} + show.limits <- params$show.limits %||% scale$show.limits %||% FALSE -#' @export -guide_gengrob.bins <- function(guide, theme) { - guide$key$.label[c(1, nrow(guide$key))[!guide$show.limits]] <- NA - - # default setting - if (guide$direction == "horizontal") { - label.position <- guide$label.position %||% "bottom" - if (!label.position %in% c("top", "bottom")) { - cli::cli_warn("Ignoring invalid {.arg label.position}") - label.position <- "bottom" + if (show.limits && + (is.character(scale$labels) || is.numeric(scale$labels))) { + cli::cli_warn(c(paste0( + "{.arg show.limits} is ignored when {.arg labels} are given as a ", + "character vector." + ), "i" = paste0( + "Either add the limits to {.arg breaks} or provide a function for ", + "{.arg labels}." + ))) + show.limits <- FALSE } - } else { - label.position <- guide$label.position %||% "right" - if (!label.position %in% c("left", "right")) { - cli::cli_warn("Ignoring invalid {.arg label.position}") - label.position <- "right" - } - } - - n_keys <- nrow(guide$key) - 1 + show.limits <- rep(show.limits, length.out = 2) - # obtain the theme for the legend title. We need this both for the title grob - # and to obtain the title fontsize. - title.theme <- guide$title.theme %||% calc_element("legend.title", theme) + key <- params$key + show <- key$.show[c(1, nrow(key))] + show.limits <- ifelse(is.na(show), show.limits, show) + key$.show <- NULL + params$show.limits <- show.limits - title.hjust <- guide$title.hjust %||% theme$legend.title.align %||% title.theme$hjust %||% 0 - title.vjust <- guide$title.vjust %||% title.theme$vjust %||% 0.5 - - grob.title <- ggname("guide.title", - element_grob( - title.theme, - label = guide$title, - hjust = title.hjust, - vjust = title.vjust, - margin_x = TRUE, - margin_y = TRUE - ) - ) + if (params$reverse) { + key <- key[rev(seq_len(nrow(key))), , drop = FALSE] + key$.value <- 1 - key$.value + } - title_width <- width_cm(grob.title) - title_height <- height_cm(grob.title) - title_fontsize <- title.theme$size %||% calc_element("legend.title", theme)$size %||% - calc_element("text", theme)$size %||% 11 + params$title <- scale$make_title( + params$title %|W|% scale$name %|W|% title + ) + params$direction <- arg_match0( + params$direction %||% direction, + c("horizontal", "vertical"), arg_nm = "direction" + ) + if (params$direction == "vertical") { + key$.value <- 1 - key$.value + } - # gap between keys etc - # the default horizontal and vertical gap need to be the same to avoid strange - # effects for certain guide layouts - hgap <- width_cm(theme$legend.spacing.x %||% (0.5 * unit(title_fontsize, "pt"))) - vgap <- height_cm(theme$legend.spacing.y %||% (0.5 * unit(title_fontsize, "pt"))) + params$key <- key + valid_label_pos <- switch( + params$direction, + "horizontal" = c("bottom", "top"), + "vertical" = c("right", "left") + ) + params$label.position <- params$label.position %||% valid_label_pos[1] + if (!params$label.position %in% valid_label_pos) { + cli::cli_abort(paste0( + "When {.arg direction} is {.val {params$direction}}, ", + "{.arg label.position} must be one of {.or {.val {valid_label_pos}}}, ", + "not {.val {params$label.position}}." + )) + } - # Labels + Guide$extract_params(scale, params, hashables) + }, + + setup_params = function(params) { + params <- GuideLegend$setup_params(params) + params$byrow <- FALSE + params$rejust_labels <- FALSE + params$nrow <- params$ncol <- params$n_breaks <- params$n_key_layers <- 1 + params$multikey_decor <- FALSE + params + }, + + override_elements = function(params, elements, theme) { + elements$ticks <- combine_elements(elements$ticks, theme$line) + elements$line <- combine_elements(elements$line, theme$line) + GuideLegend$override_elements(params, elements, theme) + }, + + build_labels = function(key, elements, params) { + key$.label[c(1, nrow(key))[!params$show.limits]] <- "" + + just <- if (params$direction == "horizontal") { + elements$text$vjust + } else { + elements$text$hjust + } - # first get the label theme, we need it below even when there are no labels - label.theme <- guide$label.theme %||% calc_element("legend.text", theme) + list(labels = flip_element_grob( + elements$text, + label = key$.label, + x = unit(key$.value, "npc"), + y = rep(just, nrow(key)), + margin_x = FALSE, + margin_y = TRUE, + flip = params$direction == "vertical" + )) + }, - if (!guide$label || is.null(guide$key$.label)) { - grob.labels <- rep(list(zeroGrob()), nrow(guide$key)) - } else { - # get the defaults for label justification. The defaults are complicated and depend - # on the direction of the legend and on label placement - just_defaults <- label_just_defaults.bins(guide$direction, label.position) - # don't set expressions left-justified - if (just_defaults$hjust == 0 && any(is.expression(guide$key$.label))) just_defaults$hjust <- 1 - - # We break inheritance for hjust and vjust, because that's more intuitive here; it still allows manual - # setting of hjust and vjust if desired. The alternative is to ignore hjust and vjust altogether, which - # seems worse - if (is.null(guide$label.theme$hjust) && is.null(theme$legend.text$hjust)) label.theme$hjust <- NULL - if (is.null(guide$label.theme$vjust) && is.null(theme$legend.text$vjust)) label.theme$vjust <- NULL - - # label.theme in param of guide_legend() > theme$legend.text.align > default - hjust <- guide$label.hjust %||% theme$legend.text.align %||% label.theme$hjust %||% - just_defaults$hjust - vjust <- guide$label.vjust %||% label.theme$vjust %||% - just_defaults$vjust - - grob.labels <- lapply(guide$key$.label, function(label, ...) { - g <- element_grob( - element = label.theme, - label = label, - hjust = hjust, - vjust = vjust, - margin_x = TRUE, - margin_y = TRUE - ) - ggname("guide.label", g) - }) - grob.labels[c(1, length(grob.labels))[!guide$show.limits]] <- list(zeroGrob()) - } + build_ticks = function(key, elements, params, position = params$position) { + key$.value[c(1, nrow(key))[!params$show.limits]] <- NA + Guide$build_ticks(key$.value, elements, params, params$label.position) + }, - label_widths <- width_cm(grob.labels) - label_heights <- height_cm(grob.labels) + build_decor = function(decor, grobs, elements, params) { + params$n_breaks <- nkeys <- nrow(params$key) - 1 - # Keys - key_width <- width_cm( - guide$keywidth %||% theme$legend.key.width %||% theme$legend.key.size - ) - key_height <- height_cm( - guide$keyheight %||% theme$legend.key.height %||% theme$legend.key.size - ) + dim <- if (params$direction == "vertical") c(nkeys, 1) else c(1, nkeys) - key_size <- lapply(guide$geoms, function(g) g$data$size / 10) - key_size_mat <- inject(cbind(!!!key_size)) + sizes <- measure_legend_keys( + params$decor, nkeys, dim, byrow = FALSE, + default_width = elements$key.width, + default_height = elements$key.height + ) + sizes <- lapply(sizes, function(x) rep_len(max(x), length(x))) + + decor <- GuideLegend$build_decor(decor, grobs, elements, params) + n_layers <- length(decor) / nkeys + key_id <- rep(seq_len(nkeys), each = n_layers) + key_nm <- paste("key", key_id, c("bg", seq_len(n_layers - 1))) + if (params$direction == "vertical") { + top <- key_id + left <- 1 + } else { + top <- 1 + left <- key_id + } + gt <- gtable( + widths = unit(sizes$widths, "cm"), + heights = unit(sizes$heights, "cm") + ) + gt <- gtable_add_grob(gt, decor, t = top, l = left, + name = key_nm, clip = "off") + + axis <- switch( + params$label.position, + "top" = list(x = c(0, 1), y = c(1, 1)), + "bottom" = list(x = c(0, 1), y = c(0, 0)), + "left" = list(x = c(0, 0), y = c(0, 1)), + "right" = list(x = c(1, 1), y = c(0, 1)) + ) + axis <- element_grob(elements$line, x = axis$x, y = axis$y) - # key_size_mat can be an empty matrix (e.g. the data doesn't contain size - # column), so subset it only when it has any rows and columns. - if (nrow(key_size_mat) == 0 || ncol(key_size_mat) == 0) { - key_size_mat <- matrix(0, ncol = 1, nrow = n_keys) - } else { - key_size_mat <- key_size_mat[seq_len(n_keys), , drop = FALSE] - } - key_sizes <- apply(key_size_mat, 1, max) + list(keys = gt, axis_line = axis, ticks = grobs$ticks) + }, - if (guide$direction == "horizontal") { - key.nrow <- 1 - key.ncol <- n_keys - label.nrow <- 1 - label.ncol <- n_keys + 1 - } else { - key.nrow <- n_keys - key.ncol <- 1 - label.nrow <- n_keys + 1 - label.ncol <- 1 + measure_grobs = function(grobs, params, elements) { + params$sizes <- list( + widths = sum( width_cm(grobs$decor$keys)), + heights = sum(height_cm(grobs$decor$keys)) + ) + GuideLegend$measure_grobs(grobs, params, elements) } +) - key_sizes <- matrix(key_sizes, key.nrow, key.ncol) - label_sizes <- matrix(label_widths, label.nrow, label.ncol) - - key_widths <- max(key_width, apply(key_sizes, 2, max)) - key_heights <- max(key_height, apply(key_sizes, 1, max)) - - label_widths <- max(apply(label_sizes, 2, max)) - label_heights <- max(apply(label_sizes, 1, max)) +parse_binned_breaks = function(scale, breaks = scale$get_breaks(), + even.steps = TRUE) { - key_loc <- data_frame0( - R = seq(2, by = 2, length.out = n_keys), - C = if (label.position %in% c("right", "bottom")) 1 else 3 - ) - label_loc <- data_frame0( - R = seq(1, by = 2, length.out = n_keys + 1), - C = if (label.position %in% c("right", "bottom")) 3 else 1 - ) - tick_loc <- label_loc - tick_loc$C <- if (label.position %in% c("right", "bottom")) 1 else 3 - - widths <- c(key_widths, hgap, label_widths) - if (label.position != "right") widths <- rev(widths) - heights <- c(interleave(rep(0, n_keys), key_heights), 0) - if (guide$direction == "horizontal") { - names(key_loc) <- c("C", "R") - names(label_loc) <- c("C", "R") - names(tick_loc) <- c("C", "R") - heights <- c(key_heights, vgap, label_heights) - if (label.position != "bottom") heights <- rev(heights) - widths <- c(interleave(rep(0, n_keys), key_widths), 0) + breaks <- breaks[!is.na(breaks)] + if (length(breaks) == 0) { + return(NULL) } - - # layout the title over key-label - switch(guide$title.position, - "top" = { - widths <- c(widths, max(0, title_width - sum(widths))) - heights <- c(title_height, vgap, heights) - key_loc$R <- key_loc$R + 2 - label_loc$R <- label_loc$R + 2 - tick_loc$R <- tick_loc$R + 2 - title_row = 1 - title_col = seq_along(widths) - }, - "bottom" = { - widths <- c(widths, max(0, title_width - sum(widths))) - heights <- c(heights, vgap, title_height) - title_row = length(heights) - title_col = seq_along(widths) - }, - "left" = { - widths <- c(title_width, hgap, widths) - heights <- c(heights, max(0, title_height - sum(heights))) - key_loc$C <- key_loc$C + 2 - label_loc$C <- label_loc$C + 2 - tick_loc$C <- tick_loc$C + 2 - title_row = seq_along(heights) - title_col = 1 - }, - "right" = { - widths <- c(widths, hgap, title_width) - heights <- c(heights, max(0, title_height - sum(heights))) - title_row = seq_along(heights) - title_col = length(widths) + breaks <- sort(breaks) + if (is.numeric(breaks)) { + limits <- scale$get_limits() + if (!is.numeric(scale$breaks)) { + breaks <- breaks[!breaks %in% limits] } - ) - - # grob for key - key_size <- c(key_width, key_height) * 10 - - draw_key <- function(i) { - bg <- element_render(theme, "legend.key") - keys <- lapply(guide$geoms, function(g) { - g$draw_key(g$data[i, ], g$params, key_size) - }) - c(list(bg), keys) - } - grob.keys <- unlist(lapply(seq_len(n_keys), draw_key), recursive = FALSE) - - # background - grob.background <- element_render(theme, "legend.background") - - ngeom <- length(guide$geoms) + 1 - kcols <- rep(key_loc$C, each = ngeom) - krows <- rep(key_loc$R, each = ngeom) - - # padding - padding <- convertUnit(theme$legend.margin %||% margin(), "cm", valueOnly = TRUE) - widths <- c(padding[4], widths, padding[2]) - heights <- c(padding[1], heights, padding[3]) - - # make the ticks grob (`grob.ticks`) - if (!guide$axis) { - grob.ticks <- zeroGrob() - grob.axis <- zeroGrob() + all_breaks <- unique0(c(limits[1], breaks, limits[2])) + bin_at <- all_breaks[-1] - diff(all_breaks) / 2 } else { - if (guide$direction == "horizontal") { - x0 <- 0.5 - y0 <- 0 - x1 <- 0.5 - y1 <- 1/5 - axis_x <- c(0, 1) - axis_y <- c(0, 0) - if (label.position == "top") { - y0 <- 4/5 - y1 <- 1 - axis_y <- c(1, 1) - } - } else { # guide$direction == "vertical" - y0 <- 0.5 - x0 <- 4/5 - y1 <- 0.5 - x1 <- 1 - axis_x <- c(1, 1) - axis_y <- c(0, 1) - if (label.position == "left") { - x0 <- 0 - x1 <- 1/5 - axis_x <- c(0, 0) - } + if (isFALSE(even.steps)) { + cli::cli_warn(paste0( + "{.code even.steps = FALSE} is not supported when used with a ", + "discrete scale." + )) } - grob.ticks <- segmentsGrob( - x0 = x0, y0 = y0, x1 = x1, y1 = y1, - default.units = "npc", - gp = gpar( - col = guide$axis.colour, - lwd = guide$axis.linewidth, - lineend = "butt" - ) - ) - grob.axis <- segmentsGrob( - x0 = axis_x[1], y0 = axis_y[1], x1 = axis_x[2], y1 = axis_y[2], - default.units = "npc", - arrow = guide$axis.arrow, - gp = gpar( - col = guide$axis.colour, - lwd = guide$axis.linewidth, - lineend = if (is.null(guide$axis.arrow)) "square" else "round" - ) - ) - } - grob.ticks <- rep_len(list(grob.ticks), length(grob.labels)) - grob.ticks[c(1, length(grob.ticks))[!guide$show.limits]] <- list(zeroGrob()) - - # Create the gtable for the legend - gt <- gtable(widths = unit(widths, "cm"), heights = unit(heights, "cm")) - gt <- gtable_add_grob( - gt, - grob.background, - name = "background", - clip = "off", - t = 1, - r = -1, - b = -1, - l = 1 - ) - gt <- gtable_add_grob( - gt, - justify_grobs( - grob.title, - hjust = title.hjust, - vjust = title.vjust, - int_angle = title.theme$angle, - debug = title.theme$debug - ), - name = "title", - clip = "off", - t = 1 + min(title_row), - r = 1 + max(title_col), - b = 1 + max(title_row), - l = 1 + min(title_col) - ) - gt <- gtable_add_grob( - gt, - grob.keys, - name = paste("key", krows, kcols, c("bg", seq(ngeom - 1)), sep = "-"), - clip = "off", - t = 1 + krows, - r = 1 + kcols, - b = 1 + krows, - l = 1 + kcols - ) - gt <- gtable_add_grob( - gt, - grob.ticks, - name = paste("tick", tick_loc$R, tick_loc$C, sep = "-"), - clip = "off", - t = 1 + tick_loc$R, - r = 1 + tick_loc$C, - b = 1 + tick_loc$R, - l = 1 + tick_loc$C - ) - gt <- gtable_add_grob( - gt, - grob.axis, - name = "axis", - clip = "off", - t = min(1 + tick_loc$R), - r = min(1 + tick_loc$C), - b = max(1 + tick_loc$R), - l = max(1 + tick_loc$C) - ) - gt <- gtable_add_grob( - gt, - justify_grobs( - grob.labels, - hjust = hjust, - vjust = vjust, - int_angle = label.theme$angle, - debug = label.theme$debug - ), - name = paste("label", label_loc$R, label_loc$C, sep = "-"), - clip = "off", - t = 1 + label_loc$R, - r = 1 + label_loc$C, - b = 1 + label_loc$R, - l = 1 + label_loc$C - ) - gt -} - -#' Calculate the default hjust and vjust settings depending on legend -#' direction and position. -#' -#' @noRd -label_just_defaults.bins <- function(direction, position) { - if (direction == "horizontal") { - switch( - position, - "top" = list(hjust = 0.5, vjust = 0), - "bottom" = list(hjust = 0.5, vjust = 1), - "left" = list(hjust = 1, vjust = 0.5), - list(hjust = 0.5, vjust = 0.5) - ) - } - else { - switch( - position, - "top" = list(hjust = 0.5, vjust = 0), - "bottom" = list(hjust = 0.5, vjust = 1), - "left" = list(hjust = 1, vjust = 0.5), - list(hjust = 0, vjust = 0.5) - ) + bin_at <- breaks + nums <- as.character(breaks) + nums <- strsplit(gsub("\\(|\\)|\\[|\\]", "", nums), ",\\s?") + nums <- as.numeric(unlist(nums, FALSE, FALSE)) + if (anyNA(nums)) { + cli::cli_abort(c( + "Breaks are not formatted correctly for a bin legend.", + "i" = "Use {.code (, ]} format to indicate bins." + )) + } + all_breaks <- nums[c(1, seq_along(breaks) * 2)] + limits <- all_breaks[ c(1, length(all_breaks))] + breaks <- all_breaks[-c(1, length(all_breaks))] } + list( + breaks = breaks, + limits = limits, + bin_at = bin_at + ) } diff --git a/R/guide-colorbar.R b/R/guide-colorbar.R index 6f11a92727..65291f37cc 100644 --- a/R/guide-colorbar.R +++ b/R/guide-colorbar.R @@ -1,3 +1,6 @@ +#' @include guide-legend.R +NULL + #' Continuous colour bar guide #' #' Colour bar guide shows continuous colour scales mapped onto values. @@ -18,8 +21,12 @@ #' @param barheight A numeric or a [grid::unit()] object specifying #' the height of the colourbar. Default value is `legend.key.height` or #' `legend.key.size` in [theme()] or theme. +#' @param frame A theme object for rendering a frame drawn around the bar. +#' Usually, the object of `element_rect()` is expected. If `element_blank()` +#' (default), no frame is drawn. #' @param frame.colour A string specifying the colour of the frame -#' drawn around the bar. If `NULL` (the default), no frame is drawn. +#' drawn around the bar. For backward compatibility, if this argument is +#' not `NULL`, the `frame` argument will be set to `element_rect()`. #' @param frame.linewidth A numeric specifying the width of the frame #' drawn around the bar in millimetres. #' @param frame.linetype A numeric specifying the linetype of the frame @@ -30,11 +37,16 @@ #' raster object. If `FALSE` then the colourbar is rendered as a set of #' rectangles. Note that not all graphics devices are capable of rendering #' raster image. -#' @param ticks A logical specifying if tick marks on the colourbar should be -#' visible. +#' @param ticks A theme object for rendering tick marks at the colourbar. +#' Usually, the object of `element_line()` is expected (default). If +#' `element_blank()`, no tick marks are drawn. For backward compatibility, +#' can also be a logical which translates `TRUE` to `element_line()` and +#' `FALSE` to `element_blank()`. #' @param ticks.colour A string specifying the colour of the tick marks. #' @param ticks.linewidth A numeric specifying the width of the tick marks in #' millimetres. +#' @param ticks.length A numeric or a [grid::unit()] object specifying the +#' length of tick marks at the colourbar. #' @param draw.ulim A logical specifying if the upper limit tick marks should #' be visible. #' @param draw.llim A logical specifying if the lower limit tick marks should @@ -125,15 +137,17 @@ guide_colourbar <- function( raster = TRUE, # frame + frame = element_blank(), frame.colour = NULL, - frame.linewidth = 0.5 / .pt, - frame.linetype = 1, + frame.linewidth = NULL, + frame.linetype = NULL, # ticks - ticks = TRUE, - ticks.colour = "white", - ticks.linewidth = 0.5 / .pt, - draw.ulim= TRUE, + ticks = element_line(), + ticks.colour = NULL, + ticks.linewidth = NULL, + ticks.length = unit(0.2, "npc"), + draw.ulim = TRUE, draw.llim = TRUE, # general @@ -142,13 +156,61 @@ guide_colourbar <- function( reverse = FALSE, order = 0, available_aes = c("colour", "color", "fill"), + ... +) { + if (!(is.null(barwidth) || is.unit(barwidth))) { + barwidth <- unit(barwidth, default.unit) + } + if (!(is.null(barheight) || is.unit(barheight))) { + barheight <- unit(barheight, default.unit) + } + if (!is.unit(ticks.length)) { + ticks.length <- unit(ticks.length, default.unit) + } + + if (!is.null(title.position)) { + title.position <- arg_match0(title.position, .trbl) + } + if (!is.null(direction)) { + direction <- arg_match0(direction, c("horizontal", "vertical")) + } + if (!is.null(label.position)) { + label.position <- arg_match0(label.position, .trbl) + } + + if (!is.null(frame.colour) && !inherits(frame, "element_rect")) { + # For backward compatibility, frame should not be element_blank when + # colour is not NULL + cli::cli_inform(c(paste0( + "If {.arg frame.colour} is set, {.arg frame} should not be ", + "{.cls {class(frame)[[1]]}}." + ), "i" = "{.arg frame} has been converted to {.cls element_rect}.")) + frame <- element_rect() + } + if (inherits(frame, "element_rect")) { + frame$colour <- frame.colour %||% frame$colour + frame$linewidth <- frame.linewidth %||% frame$linewidth %||% (0.5 / .pt) + frame$linetype <- frame.linetype %||% frame$linetype %||% 1 + } else { + frame <- element_blank() + } - ...) { + if (is.logical(ticks)) { + # Also for backward compatibility. `ticks = FALSE` used to mean: don't draw + # the ticks + ticks <- if (ticks) element_line() else element_blank() + } + if (inherits(ticks, "element_line")) { + ticks$colour <- ticks.colour %||% ticks$colour %||% "white" + ticks$linewidth <- ticks.linewidth %||% ticks$linewidth %||% (0.5 / .pt) + } - if (!is.null(barwidth) && !is.unit(barwidth)) barwidth <- unit(barwidth, default.unit) - if (!is.null(barheight) && !is.unit(barheight)) barheight <- unit(barheight, default.unit) + # Trick to re-use this constructor in `guide_coloursteps()`. + args <- list2(...) + super <- args$super %||% GuideColourbar + args$super <- NULL - structure(list2( + new_guide( # title title = title, title.position = title.position, @@ -164,410 +226,280 @@ guide_colourbar <- function( label.vjust = label.vjust, # bar - barwidth = barwidth, - barheight = barheight, + keywidth = barwidth, + keyheight = barheight, nbin = nbin, raster = raster, # frame - frame.colour = frame.colour, - frame.linewidth = frame.linewidth, - frame.linetype = frame.linetype, + frame = frame, # ticks ticks = ticks, - ticks.colour = ticks.colour, - ticks.linewidth = ticks.linewidth, - draw.ulim = draw.ulim, - draw.llim = draw.llim, + ticks_length = ticks.length, + draw_lim = c(isTRUE(draw.llim), isTRUE(draw.ulim)), # general direction = direction, - default.unit = default.unit, reverse = reverse, order = order, # parameter available_aes = available_aes, - ..., - name = "colorbar"), - class = c("guide", "colorbar") + name = "colourbar", + !!!args, + super = super ) } #' @export -guide_train.colorbar <- function(guide, scale, aesthetic = NULL) { - - # do nothing if scale are inappropriate - if (length(intersect(scale$aesthetics, guide$available_aes)) == 0) { - cli::cli_warn("colourbar guide needs appropriate scales: {.or {.field {guide$available_aes}}}") - return(NULL) - } - if (scale$is_discrete()) { - cli::cli_warn("colourbar guide needs continuous scales.") - return(NULL) - } +#' @rdname guide_colourbar +guide_colorbar <- guide_colourbar +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +GuideColourbar <- ggproto( + "GuideColourbar", GuideLegend, - # create data frame for tick display - breaks <- scale$get_breaks() - if (length(breaks) == 0 || all(is.na(breaks))) - return() + params = list( + # title + title = waiver(), + title.position = NULL, + title.theme = NULL, + title.hjust = NULL, + title.vjust = NULL, - ticks <- data_frame(scale$map(breaks), .name_repair = ~ aesthetic %||% scale$aesthetics[1]) - ticks$.value <- breaks - ticks$.label <- scale$get_labels(breaks) + # label + label = TRUE, + label.position = NULL, + label.theme = NULL, + label.hjust = NULL, + label.vjust = NULL, - guide$key <- ticks + # bar + keywidth = NULL, + keyheight = NULL, + nbin = 300, + raster = TRUE, - # bar specification (number of divs etc) - .limits <- scale$get_limits() - .bar <- seq(.limits[1], .limits[2], length.out = guide$nbin) - if (length(.bar) == 0) { - .bar = unique0(.limits) - } - guide$bar <- data_frame0( - colour = scale$map(.bar), - value = .bar, - .size = length(.bar) - ) - if (guide$reverse) { - guide$key <- guide$key[nrow(guide$key):1, ] - guide$bar <- guide$bar[nrow(guide$bar):1, ] - } - guide$hash <- with(guide, hash(list(title, key$.label, bar, name))) - guide -} + draw_lim = c(TRUE, TRUE), -# simply discards the new guide -#' @export -guide_merge.colorbar <- function(guide, new_guide) { - guide -} + # general + direction = NULL, + reverse = FALSE, + order = 0, -# this guide is not geom-based. -#' @export -guide_geom.colorbar <- function(guide, layers, default_mapping) { - # Layers that use this guide - guide_layers <- lapply(layers, function(layer) { - matched <- matched_aes(layer, guide) + # parameter + name = "colourbar", + hash = character(), + position = NULL + ), - if (length(matched) == 0) { - # This layer does not use this guide - return(NULL) - } + available_aes = c("colour", "color", "fill"), - # check if this layer should be included - if (include_layer_in_guide(layer, matched)) { - layer - } else { - NULL + hashables = exprs(title, key$.label, decor, name), + + elements = list( + frame = "rect", + ticks = "line", + ticks_length = unit(0.2, "npc"), + background = "legend.background", + margin = "legend.margin", + spacing = "legend.spacing", + spacing.x = "legend.spacing.x", + spacing.y = "legend.spacing.y", + key = "legend.key", + key.height = "legend.key.height", + key.width = "legend.key.width", + text = "legend.text", + text.align = "legend.text.align", + theme.title = "legend.title", + title.align = "legend.title.align" + ), + + extract_decor = function(scale, aesthetic, nbin = 300, reverse = FALSE, ...) { + + limits <- scale$get_limits() + bar <- seq(limits[1], limits[2], length.out = nbin) + if (length(bar) == 0) { + bar <- unique0(limits) } - }) - - # Remove this guide if no layer uses it - if (length(compact(guide_layers)) == 0) guide <- NULL - - guide -} - -#' @export -guide_gengrob.colorbar <- function(guide, theme) { - - # settings of location and size - if (guide$direction == "horizontal") { - label.position <- guide$label.position %||% "bottom" - if (!label.position %in% c("top", "bottom")) { - cli::cli_abort(c( - "label position {.val {label.position}} is invalid", - "i" = "use either {.val 'top'} or {.val 'bottom'}" - )) + bar <- data_frame0( + colour = scale$map(bar), + value = bar, + .size = length(bar) + ) + if (reverse) { + bar <- bar[nrow(bar):1, , drop = FALSE] } + return(bar) + }, - barwidth <- width_cm(guide$barwidth %||% (theme$legend.key.width * 5)) - barheight <- height_cm(guide$barheight %||% theme$legend.key.height) - } else { # guide$direction == "vertical" - label.position <- guide$label.position %||% "right" - if (!label.position %in% c("left", "right")) { - cli::cli_abort(c( - "label position {.val {label.position}} is invalid", - "i" = "use either {.val 'left'} or {.val 'right'}" + extract_params = function(scale, params, hashables, + title = waiver(), direction = "vertical", ...) { + params$title <- scale$make_title( + params$title %|W|% scale$name %|W|% title + ) + params$direction <- arg_match0( + params$direction %||% direction, + c("horizontal", "vertical"), arg_nm = "direction" + ) + valid_label_pos <- switch( + params$direction, + "horizontal" = c("bottom", "top"), + "vertical" = c("right", "left") + ) + params$label.position <- params$label.position %||% valid_label_pos[1] + if (!params$label.position %in% valid_label_pos) { + cli::cli_abort(paste0( + "When {.arg direction} is {.val {params$direction}}, ", + "{.arg label.position} must be one of {.or {.val {valid_label_pos}}}, ", + "not {.val {params$label.position}}." )) } - barwidth <- width_cm(guide$barwidth %||% theme$legend.key.width) - barheight <- height_cm(guide$barheight %||% (theme$legend.key.height * 5)) - } + limits <- c(params$decor$value[1], params$decor$value[nrow(params$decor)]) + params$key$.value <- rescale( + params$key$.value, + c(0.5, params$nbin - 0.5) / params$nbin, + limits + ) + Guide$extract_params(scale, params, hashables) + }, - barlength <- switch(guide$direction, "horizontal" = barwidth, "vertical" = barheight) - nbreak <- nrow(guide$key) + merge = function(self, params, new_guide, new_params) { + return(list(guide = self, params = params)) + }, - # make the bar grob (`grob.bar`) - if (guide$raster) { - image <- switch(guide$direction, horizontal = t(guide$bar$colour), vertical = rev(guide$bar$colour)) - grob.bar <-rasterGrob(image = image, width = barwidth, height = barheight, default.units = "cm", gp = gpar(col = NA), interpolate = TRUE) - } else { - if (guide$direction == "horizontal") { - bw <- barwidth / nrow(guide$bar) - bx <- (seq(nrow(guide$bar)) - 1) * bw - grob.bar <-rectGrob(x = bx, y = 0, vjust = 0, hjust = 0, width = bw, height = barheight, default.units = "cm", - gp = gpar(col = NA, fill = guide$bar$colour)) - } else { # guide$direction == "vertical" - bh <- barheight / nrow(guide$bar) - by <- (seq(nrow(guide$bar)) - 1) * bh - grob.bar <-rectGrob(x = 0, y = by, vjust = 0, hjust = 0, width = barwidth, height = bh, default.units = "cm", - gp = gpar(col = NA, fill = guide$bar$colour)) - } - } + get_layer_key = function(params, layers) { - # make frame around color bar if requested (colour is not NULL) - if (!is.null(guide$frame.colour)) { - grob.bar <- grobTree( - grob.bar, - rectGrob( - width = barwidth, - height = barheight, - default.units = "cm", - gp = gpar( - col = guide$frame.colour, - lwd = guide$frame.linewidth * .pt, - lty = guide$frame.linetype, - fill = NA) - ) - ) - } + guide_layers <- lapply(layers, function(layer) { - # tick and label position - tick_pos <- rescale(guide$key$.value, c(0.5, guide$nbin - 0.5), guide$bar$value[c(1, nrow(guide$bar))]) * barlength / guide$nbin - label_pos <- unit(tick_pos, "cm") - if (!guide$draw.ulim) tick_pos <- tick_pos[-1] - if (!guide$draw.llim) tick_pos <- tick_pos[-length(tick_pos)] + matched_aes <- matched_aes(layer, params) - # title + # Check if this layer should be included + if (include_layer_in_guide(layer, matched_aes)) { + layer + } else { + NULL + } + }) - # obtain the theme for the legend title. We need this both for the title grob - # and to obtain the title fontsize. - title.theme <- guide$title.theme %||% calc_element("legend.title", theme) - - title.hjust <- guide$title.hjust %||% theme$legend.title.align %||% title.theme$hjust %||% 0 - title.vjust <- guide$title.vjust %||% title.theme$vjust %||% 0.5 - - grob.title <- ggname("guide.title", - element_grob( - title.theme, - label = guide$title, - hjust = title.hjust, - vjust = title.vjust, - margin_x = TRUE, - margin_y = TRUE + if (length(compact(guide_layers)) == 0) { + return(NULL) + } + return(params) + }, + + setup_params = function(params) { + params$title.position <- arg_match0( + params$title.position %||% + switch(params$direction, vertical = "top", horizontal = "left"), + .trbl, arg_nm = "title.position" ) - ) - - title_width <- width_cm(grob.title) - title_height <- height_cm(grob.title) - title_fontsize <- title.theme$size %||% calc_element("legend.title", theme)$size %||% - calc_element("text", theme)$size %||% 11 - - # gap between keys etc - # the default horizontal and vertical gap need to be the same to avoid strange - # effects for certain guide layouts - hgap <- width_cm(theme$legend.spacing.x %||% (0.5 * unit(title_fontsize, "pt"))) - vgap <- height_cm(theme$legend.spacing.y %||% (0.5 * unit(title_fontsize, "pt"))) - - # Labels - - # get the defaults for label justification. The defaults are complicated and depend - # on the direction of the legend and on label placement - just_defaults <- label_just_defaults.colorbar(guide$direction, label.position) - # don't set expressions left-justified - if (just_defaults$hjust == 0 && any(is.expression(guide$key$.label))) just_defaults$hjust <- 1 - - # get the label theme - label.theme <- guide$label.theme %||% calc_element("legend.text", theme) - - # We break inheritance for hjust and vjust, because that's more intuitive here; it still allows manual - # setting of hjust and vjust if desired. The alternative is to ignore hjust and vjust altogether, which - # seems worse - if (is.null(guide$label.theme$hjust) && is.null(theme$legend.text$hjust)) label.theme$hjust <- NULL - if (is.null(guide$label.theme$vjust) && is.null(theme$legend.text$vjust)) label.theme$vjust <- NULL - - # label.theme in param of guide_legend() > theme$legend.text.align > default - hjust <- guide$label.hjust %||% theme$legend.text.align %||% label.theme$hjust %||% - just_defaults$hjust - vjust <- guide$label.vjust %||% label.theme$vjust %||% - just_defaults$vjust - - # make the label grob (`grob.label`) - if (!guide$label) - grob.label <- zeroGrob() - else { - if (guide$direction == "horizontal") { - x <- label_pos - y <- rep(vjust, length(label_pos)) - margin_x <- FALSE - margin_y <- TRUE - } else { # guide$direction == "vertical" - x <- rep(hjust, length(label_pos)) - y <- label_pos - margin_x <- TRUE - margin_y <- FALSE + params$rejust_labels <- FALSE + params + }, + + override_elements = function(params, elements, theme) { + # These key sizes are the defaults, the GuideLegend method may overrule this + if (params$direction == "horizontal") { + elements$key.width <- elements$key.width * 5 + } else { + elements$key.height <- elements$key.height * 5 } - label <- guide$key$.label - - # If any of the labels are quoted language objects, convert them - # to expressions. Labels from formatter functions can return these - if (any(vapply(label, is.call, logical(1)))) { - label <- as.expression(label) + elements$ticks <- combine_elements(elements$ticks, theme$line) + elements$frame <- combine_elements(elements$frame, theme$rect) + GuideLegend$override_elements(params, elements, theme) + }, + + build_labels = function(key, elements, params) { + just <- if (params$direction == "horizontal") { + elements$text$vjust + } else { + elements$text$hjust } - grob.label <- element_grob( - element = label.theme, - label = label, - x = x, - y = y, - hjust = hjust, - vjust = vjust, - margin_x = margin_x, - margin_y = margin_y - ) - grob.label <- ggname("guide.label", grob.label) - } - label_width <- width_cm(grob.label) - label_height <- height_cm(grob.label) - - # make the ticks grob (`grob.ticks`) - if (!guide$ticks) - grob.ticks <-zeroGrob() - else { - if (guide$direction == "horizontal") { - x0 <- rep(tick_pos, 2) - y0 <- c(rep(0, nbreak), rep(barheight * (4/5), nbreak)) - x1 <- rep(tick_pos, 2) - y1 <- c(rep(barheight * (1/5), nbreak), rep(barheight, nbreak)) - } else { # guide$direction == "vertical" - x0 <- c(rep(0, nbreak), rep(barwidth * (4/5), nbreak)) - y0 <- rep(tick_pos, 2) - x1 <- c(rep(barwidth * (1/5), nbreak), rep(barwidth, nbreak)) - y1 <- rep(tick_pos, 2) - } - grob.ticks <- segmentsGrob( - x0 = x0, y0 = y0, x1 = x1, y1 = y1, - default.units = "cm", - gp = gpar( - col = guide$ticks.colour, - lwd = guide$ticks.linewidth * .pt, - lineend = "butt" - ) + list(labels = flip_element_grob( + elements$text, + label = key$.label, + x = unit(key$.value, "npc"), + y = rep(just, nrow(key)), + margin_x = FALSE, + margin_y = TRUE, + flip = params$direction == "vertical" + )) + }, + + build_ticks = function(key, elements, params, position = params$position) { + pos <- key$.value + if (!params$draw_lim[1]) pos <- pos[-1] + if (!params$draw_lim[2]) pos <- pos[-length(pos)] + position <- switch( + params$direction, + "horizontal" = c("bottom", "top"), + "vertical" = c("right", "left") ) - } - - # layout of bar and label - if (guide$direction == "horizontal") { - if (label.position == "top") { - bl_widths <- barwidth - bl_heights <- c(label_height, vgap, barheight) - vps <- list(bar.row = 3, bar.col = 1, - label.row = 1, label.col = 1) - } else { # label.position == "bottom" or other - bl_widths <- barwidth - bl_heights <- c(barheight, vgap, label_height) - vps <- list(bar.row = 1, bar.col = 1, - label.row = 3, label.col = 1) - } - } else { # guide$direction == "vertical" - if (label.position == "left") { - bl_widths <- c(label_width, hgap, barwidth) - bl_heights <- barheight - vps <- list(bar.row = 1, bar.col = 3, - label.row = 1, label.col = 1) - } else { # label.position == "right" or other - bl_widths <- c(barwidth, hgap, label_width) - bl_heights <- barheight - vps <- list(bar.row = 1, bar.col = 1, - label.row = 1, label.col = 3) - } - } + elements$ticks_length <- rep(elements$ticks_length, length.out = 2) + elem1 <- elem2 <- elements + elem1$ticks_length <- elements$ticks_length[2] + elem2$ticks_length <- elements$ticks_length[1] + + grobTree( + Guide$build_ticks(pos, elem1, params, position[1]), + Guide$build_ticks(pos, elem2, params, position[2]) + ) + }, - # layout of title and bar+label - switch(guide$title.position, - "top" = { - widths <- c(bl_widths, max(0, title_width - sum(bl_widths))) - heights <- c(title_height, vgap, bl_heights) - vps <- with(vps, - list(bar.row = bar.row + 2, bar.col = bar.col, - label.row = label.row + 2, label.col = label.col, - title.row = 1, title.col = 1:length(widths))) - }, - "bottom" = { - widths <- c(bl_widths, max(0, title_width - sum(bl_widths))) - heights <- c(bl_heights, vgap, title_height) - vps <- with(vps, - list(bar.row = bar.row, bar.col = bar.col, - label.row = label.row, label.col = label.col, - title.row = length(heights), title.col = 1:length(widths))) - }, - "left" = { - widths <- c(title_width, hgap, bl_widths) - heights <- c(bl_heights, max(0, title_height - sum(bl_heights))) - vps <- with(vps, - list(bar.row = bar.row, bar.col = bar.col + 2, - label.row = label.row, label.col = label.col + 2, - title.row = 1:length(heights), title.col = 1)) - }, - "right" = { - widths <- c(bl_widths, hgap, title_width) - heights <- c(bl_heights, max(0, title_height - sum(bl_heights))) - vps <- with(vps, - list(bar.row = bar.row, bar.col = bar.col, - label.row = label.row, label.col = label.col, - title.row = 1:length(heights), title.col = length(widths))) - }) + build_decor = function(decor, grobs, elements, params) { - # background - grob.background <- element_render(theme, "legend.background") - - # padding - padding <- convertUnit(theme$legend.margin %||% margin(), "cm", valueOnly = TRUE) - widths <- c(padding[4], widths, padding[2]) - heights <- c(padding[1], heights, padding[3]) - - gt <- gtable(widths = unit(widths, "cm"), heights = unit(heights, "cm")) - gt <- gtable_add_grob(gt, grob.background, name = "background", clip = "off", - t = 1, r = -1, b = -1, l = 1) - gt <- gtable_add_grob(gt, grob.bar, name = "bar", clip = "off", - t = 1 + min(vps$bar.row), r = 1 + max(vps$bar.col), - b = 1 + max(vps$bar.row), l = 1 + min(vps$bar.col)) - gt <- gtable_add_grob( - gt, - grob.label, - name = "label", - clip = "off", - t = 1 + min(vps$label.row), r = 1 + max(vps$label.col), - b = 1 + max(vps$label.row), l = 1 + min(vps$label.col) - ) - gt <- gtable_add_grob( - gt, - justify_grobs( - grob.title, - hjust = title.hjust, - vjust = title.vjust, - int_angle = title.theme$angle, - debug = title.theme$debug - ), - name = "title", - clip = "off", - t = 1 + min(vps$title.row), r = 1 + max(vps$title.col), - b = 1 + max(vps$title.row), l = 1 + min(vps$title.col) - ) + if (params$raster) { + image <- switch( + params$direction, + "horizontal" = t(decor$colour), + "vertical" = rev(decor$colour) + ) + grob <- rasterGrob( + image = image, + width = elements$key.width, + height = elements$key.height, + default.units = "cm", + gp = gpar(col = NA), + interpolate = TRUE + ) + } else{ + if (params$direction == "horizontal") { + width <- elements$key.width / nrow(decor) + height <- elements$key.height + x <- (seq(nrow(decor)) - 1) * width + y <- 0 + } else { + width <- elements$key.width + height <- elements$key.height / nrow(decor) + y <- (seq(nrow(decor)) - 1) * height + x <- 0 + } + grob <- rectGrob( + x = x, y = y, + vjust = 0, hjust = 0, + width = width, height = height, + default.units = "cm", + gp = gpar(col = NA, fill = decor$colour) + ) + } - gt <- gtable_add_grob(gt, grob.ticks, name = "ticks", clip = "off", - t = 1 + min(vps$bar.row), r = 1 + max(vps$bar.col), - b = 1 + max(vps$bar.row), l = 1 + min(vps$bar.col) - ) + frame <- element_grob(elements$frame, fill = NA) - gt -} + list(bar = grob, frame = frame, ticks = grobs$ticks) + }, -#' @export -#' @rdname guide_colourbar -guide_colorbar <- guide_colourbar + measure_grobs = function(grobs, params, elements) { + params$sizes <- list( + widths = elements$key.width, + heights = elements$key.height + ) + GuideLegend$measure_grobs(grobs, params, elements) + } +) diff --git a/R/guide-colorsteps.R b/R/guide-colorsteps.R index e23b6d899b..26aac440bf 100644 --- a/R/guide-colorsteps.R +++ b/R/guide-colorsteps.R @@ -11,8 +11,11 @@ #' scale. This argument is ignored if `labels` is given as a vector of #' values. If one or both of the limits is also given in `breaks` it will be #' shown irrespective of the value of `show.limits`. -#' @param ticks A logical specifying if tick marks on the colourbar should be -#' visible. +#' @param ticks A theme object for rendering tick marks at the colourbar. +#' Usually, the object of `element_line()` is expected. If `element_blank()` +#' (default), no tick marks are drawn. For backward compatability, can also +#' be a logical which translates `TRUE` to `element_line()` and `FALSE` to +#' `element_blank()`. #' @inheritDotParams guide_colourbar -nbin -raster -ticks -available_aes #' #' @inheritSection guide_bins Use with discrete scale @@ -45,127 +48,135 @@ #' #' # (can also be set in the scale) #' p + scale_fill_binned(show.limits = TRUE) -#' -guide_coloursteps <- function(even.steps = TRUE, show.limits = NULL, ticks = FALSE, ...) { - guide <- guide_colourbar(raster = FALSE, ticks = ticks, nbin = 100, ...) - guide$even.steps <- even.steps - guide$show.limits <- show.limits - class(guide) <- c('colorsteps', class(guide)) - guide +guide_coloursteps <- function( + even.steps = TRUE, + show.limits = NULL, + ticks = element_blank(), + ... +) { + guide_colourbar( + even.steps = even.steps, + show.limits = show.limits, + raster = FALSE, + ticks = ticks, + nbin = 100, + ..., + super = GuideColoursteps + ) } + #' @export #' @rdname guide_coloursteps guide_colorsteps <- guide_coloursteps +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL #' @export -guide_train.colorsteps <- function(guide, scale, aesthetic = NULL) { - breaks <- scale$get_breaks() - breaks <- breaks[!is.na(breaks)] - show_limits <- guide$show.limits %||% scale$show.limits %||% FALSE - if (show_limits && (is.character(scale$labels) || is.numeric(scale$labels))) { - cli::cli_warn(c( - "{.arg show.limits} is ignored when {.arg labels} are given as a character vector", - "i" = "Either add the limits to {.arg breaks} or provide a function for {.arg labels}" - )) - show_limits <- FALSE - } - if (guide$even.steps || !is.numeric(breaks)) { - if (length(breaks) == 0 || all(is.na(breaks))) { - return() +GuideColoursteps <- ggproto( + NULL, GuideColourbar, + + params = c( + list(even.steps = TRUE, show.limits = NULL), + GuideColourbar$params + ), + + extract_key = function(scale, aesthetic, even.steps, ...) { + + breaks <- scale$get_breaks() + + if (!(even.steps || !is.numeric(breaks))) { + return(Guide$extract_key(scale, aesthetic)) } - if (is.numeric(breaks)) { - limits <- scale$get_limits() - if (!is.numeric(scale$breaks)) { - breaks <- breaks[!breaks %in% limits] - } - all_breaks <- unique0(c(limits[1], breaks, limits[2])) - bin_at <- all_breaks[-1] - diff(all_breaks) / 2 - } else { - # If the breaks are not numeric it is used with a discrete scale. We check - # if the breaks follow the allowed format "(, ]", and if it - # does we convert it into bin specs - if (!guide$even.steps) { - cli::cli_warn("{.code even.steps = FALSE} is not supported when used with a discrete scale") - } - bin_at <- breaks - breaks_num <- as.character(breaks) - breaks_num <- strsplit(gsub("\\(|\\)|\\[|\\]", "", breaks_num), ",\\s?") - breaks_num <- as.numeric(unlist(breaks_num)) - if (anyNA(breaks_num)) { - cli::cli_abort(c( - "Breaks not formatted correctly for a bin legend.", - "i" = "Use {.code (, ]} format to indicate bins" - )) - } - all_breaks <- breaks_num[c(1, seq_along(breaks) * 2)] - limits <- all_breaks[c(1, length(all_breaks))] - breaks <- all_breaks[-c(1, length(all_breaks))] + + parsed <- parse_binned_breaks(scale, breaks, even.steps) + if (is.null(parsed)) { + return(parsed) } - ticks <- data_frame( - scale$map(breaks), - .name_repair = ~ aesthetic %||% scale$aesthetics[1] - ) - ticks$.value <- seq_along(breaks) - 0.5 - ticks$.label <- scale$get_labels(breaks) - guide$nbin <- length(breaks) + 1L + limits <- parsed$limits + breaks <- parsed$breaks + + key <- data_frame(scale$map(breaks), .name_repair = ~ aesthetic) + key$.value <- seq_along(breaks) - 0.5 + key$.label <- scale$get_labels(breaks) + if (breaks[1] %in% limits) { - ticks$.value <- ticks$.value - 1L - ticks[[1]][1] <- NA - guide$nbin <- guide$nbin - 1L + key$.value <- key$.value - 1L + key[[1]][1] <- NA } if (breaks[length(breaks)] %in% limits) { - ticks[[1]][nrow(ticks)] <- NA - guide$nbin <- guide$nbin - 1L + key[[1]][nrow(key)] <- NA + } + # To avoid having to recalculate these variables in other methods, we + # attach these as attributes. It might not be very elegant, but it works. + attr(key, "limits") <- parsed$limits + attr(key, "bin_at") <- parsed$bin_at + return(key) + }, + + extract_decor = function(scale, aesthetic, key, + reverse = FALSE, even.steps = TRUE, + nbin = 100, ...) { + if (!(even.steps || !is.numeric(scale$get_breaks()))) { + return(GuideColourbar$extract_decor(scale, aesthetic, reverse = reverse, + nbin = nbin)) } - guide$key <- ticks - guide$bar <- data_frame0( + + bin_at <- attr(key, "bin_at", TRUE) + + bar <- data_frame0( colour = scale$map(bin_at), - value = seq_along(bin_at) - 1, - .size = length(bin_at) + value = seq_along(bin_at) - 1, + .size = length(bin_at) ) + if (reverse) { + bar <- bar[nrow(bar):1, , drop = FALSE] + } + return(bar) + }, + + extract_params = function(scale, params, hashables, ...) { - if (guide$reverse) { - guide$key <- guide$key[nrow(guide$key):1, ] - guide$bar <- guide$bar[nrow(guide$bar):1, ] + if (params$even.steps) { + params$nbin <- nbin <- sum(!is.na(params$key[[1]])) + 1 + } else { + nbin <- params$nbin } - guide$hash <- with(guide, hash(list(title, key$.label, bar, name))) - } else { - guide <- NextMethod() - limits <- scale$get_limits() - } - if (show_limits) { - edges <- rescale(c(0, 1), to = guide$bar$value[c(1, nrow(guide$bar))], from = c(0.5, guide$nbin - 0.5) / guide$nbin) - if (guide$reverse) edges <- rev(edges) - guide$key <- guide$key[c(NA, seq_len(nrow(guide$key)), NA), , drop = FALSE] - guide$key$.value[c(1, nrow(guide$key))] <- edges - guide$key$.label[c(1, nrow(guide$key))] <- scale$get_labels(limits) - if (guide$key$.value[1] == guide$key$.value[2]) { - guide$key <- guide$key[-1,] + + show.limits <- params$show.limits %||% scale$show.limits %||% FALSE + + if (show.limits && + (is.character(scale$labels) || is.numeric(scale$labels))) { + cli::cli_warn(c(paste0( + "{.arg show.limits} is ignored when {.arg labels} are given as a ", + "character vector." + ), "i" = paste0( + "Either add the limits to {.arg breaks} or provide a function for ", + "{.arg labels}." + ))) + show.limits <- FALSE } - if (guide$key$.value[nrow(guide$key)-1] == guide$key$.value[nrow(guide$key)]) { - guide$key <- guide$key[-nrow(guide$key),] + + if (show.limits) { + edges <- rescale( + c(0, 1), + to = params$decor$value[c(1, nrow(params$decor))], + from = c(0.5, nbin - 0.5) / nbin + ) + key <- params$key + limits <- attr(key, "limits", TRUE) + key <- key[c(NA, seq_len(nrow(key)), NA), , drop = FALSE] + key$.value[c(1, nrow(key))] <- edges + key$.label[c(1, nrow(key))] <- scale$get_labels(limits) + if (key$.value[1] == key$.value[2]) { + key <- key[-1, , drop = FALSE] + } + if (key$.value[nrow(key) - 1] == key$.value[nrow(key)]) { + key <- key[-nrow(key), , drop = FALSE] + } + params$key <- key } - } - guide -} -#' Calculate the default hjust and vjust settings depending on legend -#' direction and position. -#' -#' @noRd -label_just_defaults.colorbar <- function(direction, position) { - if (direction == "horizontal") { - switch( - position, - "top" = list(hjust = 0.5, vjust = 0), - list(hjust = 0.5, vjust = 1) - ) - } - else { - switch( - position, - "left" = list(hjust = 1, vjust = 0.5), - list(hjust = 0, vjust = 0.5) - ) + GuideColourbar$extract_params(scale, params, hashables, ...) } -} +) diff --git a/R/guide-legend.R b/R/guide-legend.R index f0ef3d6c58..0e6193aa24 100644 --- a/R/guide-legend.R +++ b/R/guide-legend.R @@ -125,624 +125,627 @@ #' # reversed order legend #' p + guides(col = guide_legend(reverse = TRUE)) #' } -guide_legend <- function(# title - title = waiver(), - title.position = NULL, - title.theme = NULL, - title.hjust = NULL, - title.vjust = NULL, - - # label - label = TRUE, - label.position = NULL, - label.theme = NULL, - label.hjust = NULL, - label.vjust = NULL, - - # key - keywidth = NULL, - keyheight = NULL, - - # general - direction = NULL, - default.unit = "line", - override.aes = list(), - nrow = NULL, - ncol = NULL, - byrow = FALSE, - reverse = FALSE, - order = 0, - ...) { - - if (!is.null(keywidth) && !is.unit(keywidth)) { +guide_legend <- function( + # Title + title = waiver(), + title.position = NULL, + title.theme = NULL, + title.hjust = NULL, + title.vjust = NULL, + + # Label + label = TRUE, + label.position = NULL, + label.theme = NULL, + label.hjust = NULL, + label.vjust = NULL, + + # Key size + keywidth = NULL, + keyheight = NULL, + + # General + direction = NULL, + default.unit = "line", + override.aes = list(), + nrow = NULL, + ncol = NULL, + byrow = FALSE, + reverse = FALSE, + order = 0, + ... +) { + # Resolve key sizes + if (!inherits(keywidth, c("NULL", "unit"))) { keywidth <- unit(keywidth, default.unit) } - if (!is.null(keyheight) && !is.unit(keyheight)) { + if (!inherits(keyheight, c("NULL", "unit"))) { keyheight <- unit(keyheight, default.unit) } + if (!is.null(title.position)) { + title.position <- arg_match0(title.position, .trbl) + } + if (!is.null(label.position)) { + label.position <- arg_match0(label.position, .trbl) + } - structure( - list2( - # title - title = title, - title.position = title.position, - title.theme = title.theme, - title.hjust = title.hjust, - title.vjust = title.vjust, - - # label - label = label, - label.position = label.position, - label.theme = label.theme, - label.hjust = label.hjust, - label.vjust = label.vjust, - - # size of key - keywidth = keywidth, - keyheight = keyheight, - - # general - direction = direction, - override.aes = rename_aes(override.aes), - nrow = nrow, - ncol = ncol, - byrow = byrow, - reverse = reverse, - order = order, - - # parameter - available_aes = c("any"), - ..., - name = "legend" - ), - class = c("guide", "legend") + new_guide( + # Title + title = title, + title.position = title.position, + title.theme = title.theme, + title.hjust = title.hjust, + title.vjust = title.vjust, + + # Label + label = label, + label.position = label.position, + label.theme = label.theme, + label.hjust = label.hjust, + label.vjust = label.vjust, + + # Key size + keywidth = keywidth, + keyheight = keyheight, + + # General + direction = direction, + override.aes = rename_aes(override.aes), + nrow = nrow, + ncol = ncol, + byrow = byrow, + reverse = reverse, + order = order, + + # Fixed parameters + available_aes = "any", + name = "legend", + super = GuideLegend ) } +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL #' @export -guide_train.legend <- function(guide, scale, aesthetic = NULL) { - breaks <- scale$get_breaks() - if (length(breaks) == 0 || all(is.na(breaks))) { - return() - } +GuideLegend <- ggproto( + "GuideLegend", Guide, + + params = list( + title = waiver(), + title.position = NULL, + title.theme = NULL, + title.hjust = NULL, + title.vjust = NULL, + + label = TRUE, + label.position = NULL, + label.theme = NULL, + label.hjust = NULL, + label.vjust = NULL, + + keywidth = NULL, + keyheight = NULL, + + # General + direction = NULL, + override.aes = list(), + nrow = NULL, + ncol = NULL, + byrow = FALSE, + reverse = FALSE, + order = 0, + + name = "legend", + hash = character(), + position = NULL, + direction = NULL + ), + + available_aes = "any", + + hashables = exprs(title, key$.label, direction, name), + + elements = list( + background = "legend.background", + margin = "legend.margin", + spacing = "legend.spacing", + spacing.x = "legend.spacing.x", + spacing.y = "legend.spacing.y", + key = "legend.key", + key.height = "legend.key.height", + key.width = "legend.key.width", + text = "legend.text", + text.align = "legend.text.align", + theme.title = "legend.title", + title.align = "legend.title.align" + ), + + extract_params = function(scale, params, hashables, + title = waiver(), direction = NULL, ...) { + params$title <- scale$make_title( + params$title %|W|% scale$name %|W|% title + ) + params$direction <- arg_match0( + params$direction %||% direction, + c("horizontal", "vertical"), arg_nm = "direction" + ) + if (isTRUE(params$reverse %||% FALSE)) { + params$key <- params$key[nrow(params$key):1, , drop = FALSE] + } - # in the key data frame, use either the aesthetic provided as - # argument to this function or, as a fall back, the first in the vector - # of possible aesthetics handled by the scale - aes_column_name <- aesthetic %||% scale$aesthetics[1] - key <- data_frame(scale$map(breaks), .name_repair = ~ aes_column_name) - key$.label <- scale$get_labels(breaks) - - # Drop out-of-range values for continuous scale - # (should use scale$oob?) - if (!scale$is_discrete()) { - limits <- scale$get_limits() - noob <- !is.na(breaks) & limits[1] <= breaks & breaks <= limits[2] - key <- key[noob, , drop = FALSE] - } + Guide$extract_params(scale, params, hashables) + }, + merge = function(self, params, new_guide, new_params) { + # Combine keys + new_params$key$.label <- new_params$key$.value <- NULL + params$key <- vec_cbind(params$key, new_params$key) - if (guide$reverse) key <- key[nrow(key):1, ] + # Combine override.aes + params$override.aes <- c(params$override.aes, new_params$override.aes) + nms <- names(params$override.aes) + if (anyDuplicated(nms)) { + cli::cli_warn("Duplicated {.arg override.aes} is ignored.") + } + params$override.aes <- params$override.aes[!duplicated(nms)] + + list(guide = self, params = params) + }, + + # Arrange common data for vertical and horizontal legends + get_layer_key = function(params, layers) { + + decor <- lapply(layers, function(layer) { + + matched_aes <- matched_aes(layer, params) + + # Check if this layer should be included + if (!include_layer_in_guide(layer, matched_aes)) { + return(NULL) + } + + if (length(matched_aes) > 0) { + # Filter out aesthetics that can't be applied to the legend + n <- lengths(layer$aes_params, use.names = FALSE) + layer_params <- layer$aes_params[n == 1] + + aesthetics <- layer$computed_mapping + is_modified <- is_scaled_aes(aesthetics) | is_staged_aes(aesthetics) + modifiers <- aesthetics[is_modified] + + data <- try_fetch( + layer$geom$use_defaults(params$key[matched_aes], + layer_params, modifiers), + error = function(cnd) { + cli::cli_warn( + "Failed to apply {.fn after_scale} modifications to legend", + parent = cnd + ) + layer$geom$use_defaults(params$key[matched], layer_params, list()) + } + ) + } else { + reps <- rep(1, nrow(params$key)) + data <- layer$geom$use_defaults(NULL, layer$aes_params)[reps, ] + } - guide$key <- key - guide$hash <- with( - guide, - hash(list(title, key$.label, direction, name)) - ) - guide -} + data <- modify_list(data, params$override.aes) -#' @export -guide_merge.legend <- function(guide, new_guide) { - new_guide$key$.label <- NULL - guide$key <- vec_cbind(guide$key, new_guide$key) - guide$override.aes <- c(guide$override.aes, new_guide$override.aes) - if (any(duplicated(names(guide$override.aes)))) { - cli::cli_warn("Duplicated {.arg override.aes} is ignored.") - } - guide$override.aes <- guide$override.aes[!duplicated(names(guide$override.aes))] - guide -} + if (!is.null(data$size)) { + data$size[is.na(data$size)] <- 0 + } -#' @export -guide_geom.legend <- function(guide, layers, default_mapping) { - # arrange common data for vertical and horizontal guide - guide$geoms <- lapply(layers, function(layer) { - matched <- matched_aes(layer, guide) + list( + draw_key = layer$geom$draw_key, + data = data, + params = c(layer$computed_geom_params, layer$computed_stat_params) + ) + }) - # check if this layer should be included - include <- include_layer_in_guide(layer, matched) + # Remove NULL geoms + params$decor <- compact(decor) - if (!include) { + if (length(params$decor) == 0) { return(NULL) } + return(params) + }, + + setup_params = function(params) { + if ("title.position" %in% names(params)) { + params$title.position <- arg_match0( + params$title.position %||% + switch(params$direction, vertical = "top", horizontal = "left"), + .trbl, arg_nm = "title.position" + ) + } + if ("label.position" %in% names(params)) { + params$label.position <- arg_match0( + params$label.position %||% "right", + .trbl, arg_nm = "label.position" + ) + params$rejust_labels <- TRUE + } - if (length(matched) > 0) { - # Filter out set aesthetics that can't be applied to the legend - n <- lengths(layer$aes_params) - params <- layer$aes_params[n == 1] - - aesthetics <- layer$computed_mapping - modifiers <- aesthetics[is_scaled_aes(aesthetics) | is_staged_aes(aesthetics)] + params$n_breaks <- n_breaks <- nrow(params$key) + params$n_key_layers <- length(params$decor) + 1 # +1 is key background - data <- try_fetch( - layer$geom$use_defaults(guide$key[matched], params, modifiers), - error = function(cnd) { - cli::cli_warn("Failed to apply {.fn after_scale} modifications to legend", parent = cnd) - layer$geom$use_defaults(guide$key[matched], params, list()) + # Resolve shape + if (!is.null(params$nrow) && !is.null(params$ncol) && + params$nrow * params$ncol < n_breaks) { + cli::cli_abort(paste0( + "{.arg nrow} * {.arg ncol} needs to be larger than the number of ", + "breaks ({n_breaks})" + )) + } + if (is.null(params$nrow) && is.null(params$ncol)) { + if (params$direction == "horizontal") { + params$nrow <- ceiling(n_breaks / 5) + } else { + params$ncol <- ceiling(n_breaks / 20) + } + } + params$nrow <- params$nrow %||% ceiling(n_breaks / params$ncol) + params$ncol <- params$ncol %||% ceiling(n_breaks / params$nrow) + params + }, + + override_elements = function(params, elements, theme) { + + # Title + title <- combine_elements(params$title.theme, elements$theme.title) + title$hjust <- params$title.hjust %||% elements$title.align %||% + title$hjust %||% 0 + title$vjust <- params$title.vjust %||% title$vjust %||% 0.5 + elements$title <- title + + # Labels + if (!is.null(elements$text)) { + label <- combine_elements(params$label.theme, elements$text) + if (!params$label || is.null(params$key$.label)) { + label <- element_blank() + } else { + hjust <- unname(label_hjust_defaults[params$label.position]) + vjust <- unname(label_vjust_defaults[params$label.position]) + # Expressions default to right-justified + if (hjust == 0 && any(is.expression(params$key$.label))) { + hjust <- 1 } - ) - } else { - data <- layer$geom$use_defaults(NULL, layer$aes_params)[rep(1, nrow(guide$key)), ] + # Breaking justification inheritance for intuition purposes. + if (is.null(params$label.theme$hjust) && + is.null(theme$legend.text$hjust)) { + label$hjust <- NULL + } + if (is.null(params$label.theme$vjust) && + is.null(theme$legend.text$vjust)) { + label$vjust <- NULL + } + label$hjust <- params$label.hjust %||% elements$text.align %||% + label$hjust %||% hjust + label$vjust <- params$label.vjust %||% label$vjust %||% vjust + } + elements$text <- label } - # override.aes in guide_legend manually changes the geom - data <- modify_list(data, guide$override.aes) - - if (!is.null(data$size)) { - data$size[is.na(data$size)] <- 0 + # Keys + if (any(c("key.width", "key.height") %in% names(elements))) { + elements$key.width <- width_cm( params$keywidth %||% elements$key.width) + elements$key.height <- height_cm(params$keyheight %||% elements$key.height) } - list( - draw_key = layer$geom$draw_key, - data = data, - params = c(layer$computed_geom_params, layer$computed_stat_params) + # Spacing + gap <- title$size %||% elements$theme.title$size %||% + elements$text$size %||% 11 + gap <- unit(gap * 0.5, "pt") + # Should maybe be elements$spacing.{x/y} instead of the theme's spacing? + elements$hgap <- width_cm( theme$legend.spacing.x %||% gap) + elements$vgap <- height_cm(theme$legend.spacing.y %||% gap) + elements$padding <- convertUnit( + elements$margin %||% margin(), + "cm", valueOnly = TRUE ) - }) - - # remove null geom - guide$geoms <- compact(guide$geoms) - - # Finally, remove this guide if no layer is drawn - if (length(guide$geoms) == 0) guide <- NULL - guide -} -#' @export -guide_gengrob.legend <- function(guide, theme) { - - # default setting - label.position <- guide$label.position %||% "right" - if (!label.position %in% c("top", "bottom", "left", "right")) - cli::cli_abort("label position {.var {label.position}} is invalid") - - nbreak <- nrow(guide$key) - - # obtain the theme for the legend title. We need this both for the title grob - # and to obtain the title fontsize. - title.theme <- guide$title.theme %||% calc_element("legend.title", theme) - - title.hjust <- guide$title.hjust %||% theme$legend.title.align %||% title.theme$hjust %||% 0 - title.vjust <- guide$title.vjust %||% title.theme$vjust %||% 0.5 - - grob.title <- ggname("guide.title", - element_grob( - title.theme, - label = guide$title, - hjust = title.hjust, - vjust = title.vjust, - margin_x = TRUE, - margin_y = TRUE - ) - ) + # Evaluate backgrounds early + if (!is.null(elements$background)) { + elements$background <- ggname( + "legend.background", element_grob(elements$background) + ) + } + if (!is.null(elements$key)) { + elements$key <- ggname( + "legend.key", element_grob(elements$key) + ) + } - title_width <- width_cm(grob.title) - title_height <- height_cm(grob.title) - title_fontsize <- title.theme$size %||% calc_element("legend.title", theme)$size %||% - calc_element("text", theme)$size %||% 11 + elements + }, - # gap between keys etc - # the default horizontal and vertical gap need to be the same to avoid strange - # effects for certain guide layouts - hgap <- width_cm(theme$legend.spacing.x %||% (0.5 * unit(title_fontsize, "pt"))) - vgap <- height_cm(theme$legend.spacing.y %||% (0.5 * unit(title_fontsize, "pt"))) + build_ticks = function(...) { + zeroGrob() + }, - # Labels + build_decor = function(decor, grobs, elements, params) { - # first get the label theme, we need it below even when there are no labels - label.theme <- guide$label.theme %||% calc_element("legend.text", theme) + key_size <- c(elements$key.width, elements$key.height) * 10 - if (!guide$label || is.null(guide$key$.label)) { - grob.labels <- rep(list(zeroGrob()), nrow(guide$key)) - } else { - # get the defaults for label justification. The defaults are complicated and depend - # on the direction of the legend and on label placement - just_defaults <- label_just_defaults.legend(guide$direction, label.position) - # don't set expressions left-justified - if (just_defaults$hjust == 0 && any(is.expression(guide$key$.label))) just_defaults$hjust <- 1 - - # We break inheritance for hjust and vjust, because that's more intuitive here; it still allows manual - # setting of hjust and vjust if desired. The alternative is to ignore hjust and vjust altogether, which - # seems worse - if (is.null(guide$label.theme$hjust) && is.null(theme$legend.text$hjust)) label.theme$hjust <- NULL - if (is.null(guide$label.theme$vjust) && is.null(theme$legend.text$vjust)) label.theme$vjust <- NULL - - # label.theme in param of guide_legend() > theme$legend.text.align > default - hjust <- guide$label.hjust %||% theme$legend.text.align %||% label.theme$hjust %||% - just_defaults$hjust - vjust <- guide$label.vjust %||% label.theme$vjust %||% - just_defaults$vjust - - grob.labels <- lapply(guide$key$.label, function(label, ...) { - g <- element_grob( - element = label.theme, - label = label, - hjust = hjust, - vjust = vjust, - margin_x = TRUE, - margin_y = TRUE + draw <- function(i) { + bg <- elements$key + keys <- lapply(decor, function(g) { + g$draw_key(vec_slice(g$data, i), g$params, key_size) + }) + c(list(bg), keys) + } + unlist(lapply(seq_len(params$n_breaks), draw), FALSE) + }, + + build_labels = function(key, elements, params) { + lapply(key$.label, function(lab) { + ggname( + "guide.label", + element_grob( + elements$text, + label = lab, + margin_x = TRUE, + margin_y = TRUE + ) ) - ggname("guide.label", g) }) - } - - label_widths <- width_cm(grob.labels) - label_heights <- height_cm(grob.labels) - - # Keys - key_width <- width_cm( - guide$keywidth %||% theme$legend.key.width %||% theme$legend.key.size - ) - key_height <- height_cm( - guide$keyheight %||% theme$legend.key.height %||% theme$legend.key.size - ) + }, + + measure_grobs = function(grobs, params, elements) { + byrow <- params$byrow %||% FALSE + n_breaks <- params$n_breaks %||% 1L + dim <- c(params$nrow %||% 1L, params$ncol %||% 1L) + + # A guide may have already specified the size of the decoration, only + # measure when it hasn't already. + sizes <- params$sizes %||% measure_legend_keys( + params$decor, n = n_breaks, dim = dim, byrow = byrow, + default_width = elements$key.width, + default_height = elements$key.height + ) + widths <- sizes$widths + heights <- sizes$heights + + # Measure label sizes + zeroes <- rep(0, prod(dim) - n_breaks) # size vector padding + label_widths <- apply(matrix( + c(width_cm(grobs$labels), zeroes), + nrow = dim[1], ncol = dim[2], byrow = byrow + ), 2, max) + label_heights <- apply(matrix( + c(height_cm(grobs$labels), zeroes), + nrow = dim[1], ncol = dim[2], byrow = byrow + ), 1, max) + + # Interleave gaps between keys and labels, which depends on the label + # position. For unclear reasons, we need to adjust some gaps based on the + # `byrow` parameter (see also #4352). + hgap <- elements$hgap %||% 0 + widths <- switch( + params$label.position, + "left" = list(label_widths, hgap, widths, hgap), + "right" = list(widths, hgap, label_widths, hgap), + list(pmax(label_widths, widths), hgap * (!byrow)) + ) + widths <- head(vec_interleave(!!!widths), -1) + + vgap <- elements$vgap %||% 0 + heights <- switch( + params$label.position, + "top" = list(label_heights, vgap, heights, vgap), + "bottom" = list(heights, vgap, label_heights, vgap), + list(pmax(label_heights, heights), vgap * (byrow)) + ) + heights <- head(vec_interleave(!!!heights), -1) + + # Measure title + title_width <- width_cm(grobs$title) + title_height <- height_cm(grobs$title) + + # Combine title with rest of the sizes based on its position + widths <- switch( + params$title.position, + "left" = c(title_width, hgap, widths), + "right" = c(widths, hgap, title_width), + c(widths, max(0, title_width - sum(widths))) + ) + heights <- switch( + params$title.position, + "top" = c(title_height, vgap, heights), + "bottom" = c(heights, vgap, title_height), + c(heights, max(0, title_height - sum(heights))) + ) - key_size <- lapply(guide$geoms, function(g) g$data$size / 10) - key_size_mat <- inject(cbind(!!!key_size)) + list( + widths = widths, + heights = heights, + padding = elements$padding + ) + }, - if (nrow(key_size_mat) == 0 || ncol(key_size_mat) == 0) { - key_size_mat <- matrix(0, ncol = 1, nrow = nbreak) - } - key_sizes <- apply(key_size_mat, 1, max) + arrange_layout = function(key, sizes, params) { - if (!is.null(guide$nrow) && !is.null(guide$ncol) && - guide$nrow * guide$ncol < nbreak) { - cli::cli_abort("{.arg nrow} * {.arg ncol} needs to be larger than the number of breaks ({nbreak})") - } + break_seq <- seq_len(params$n_breaks %||% 1L) + dim <- c(params$nrow %||% 1L, params$ncol %||% 1L) - # If neither nrow/ncol specified, guess with "reasonable" values - if (is.null(guide$nrow) && is.null(guide$ncol)) { - if (guide$direction == "horizontal") { - guide$nrow <- ceiling(nbreak / 5) + # Find rows / columns of legend items + if (params$byrow %||% FALSE) { + df <- data_frame0( + R = ceiling(break_seq / dim[2]), + C = (break_seq - 1) %% dim[2] + 1 + ) } else { - guide$ncol <- ceiling(nbreak / 20) + df <- mat_2_df(arrayInd(break_seq, dim), c("R", "C")) } - } - legend.nrow <- guide$nrow %||% ceiling(nbreak / guide$ncol) - legend.ncol <- guide$ncol %||% ceiling(nbreak / guide$nrow) - - key_sizes <- matrix( - c(key_sizes, rep(0, legend.nrow * legend.ncol - nbreak)), - legend.nrow, - legend.ncol, - byrow = guide$byrow - ) - - key_widths <- pmax(key_width, apply(key_sizes, 2, max)) - key_heights <- pmax(key_height, apply(key_sizes, 1, max)) - - label_widths <- apply( - matrix( - c(label_widths, rep(0, legend.nrow * legend.ncol - nbreak)), - legend.nrow, - legend.ncol, - byrow = guide$byrow - ), - 2, - max - ) - label_heights <- apply( - matrix( - c(label_heights, rep(0, legend.nrow * legend.ncol - nbreak)), - legend.nrow, - legend.ncol, - byrow = guide$byrow - ), - 1, - max - ) + # Make spacing for padding / gaps. For example: because first gtable cell + # will be padding, first item will be at [2, 2] position. Then the + # second item-row will be [4, 2] because [3, 2] will be a gap cell. + key_row <- label_row <- df$R * 2 + key_col <- label_col <- df$C * 2 - if (guide$byrow) { - vps <- data_frame0( - R = ceiling(seq(nbreak) / legend.ncol), - C = (seq(nbreak) - 1) %% legend.ncol + 1 - ) - } else { - vps <- mat_2_df(arrayInd(seq(nbreak), dim(key_sizes)), c("R", "C")) - } - - # layout of key-label depends on the direction of the guide - if (guide$byrow == TRUE) { + # Make gaps for key-label spacing depending on label position switch( - label.position, + params$label.position, "top" = { - kl_widths <- pmax(label_widths, key_widths) - kl_heights <- utils::head( - interleave(label_heights, vgap, key_heights, vgap), - -1 - ) - vps <- transform( - vps, - key.row = R * 4 - 1, - key.col = C, - label.row = R * 4 - 3, - label.col = C - ) + key_row <- key_row * 2 + label_row <- label_row * 2 - 2 }, "bottom" = { - kl_widths <- pmax(label_widths, key_widths) - kl_heights <- utils::head( - interleave(key_heights, vgap, label_heights, vgap), - -1 - ) - vps <- transform( - vps, - key.row = R * 4 - 3, - key.col = C, - label.row = R * 4 - 1, - label.col = C - ) + key_row <- key_row * 2 - 2 + label_row <- label_row * 2 }, "left" = { - kl_widths <- utils::head( - interleave(label_widths, hgap, key_widths, hgap), - -1 - ) - kl_heights <- utils::head( - interleave(pmax(label_heights, key_heights), vgap), - -1 - ) - vps <- transform( - vps, - key.row = R * 2 - 1, - key.col = C * 4 - 1, - label.row = R * 2 - 1, - label.col = C * 4 - 3 - ) + key_col <- key_col * 2 + label_col <- label_col * 2 - 2 }, "right" = { - kl_widths <- utils::head( - interleave(key_widths, hgap, label_widths, hgap), - -1 - ) - kl_heights <- utils::head( - interleave(pmax(label_heights, key_heights), vgap), - -1 - ) - vps <- transform( - vps, - key.row = R * 2 - 1, - key.col = C * 4 - 3, - label.row = R * 2 - 1, - label.col = C * 4 - 1 - ) - }) - } else { + key_col <- key_col * 2 - 2 + label_col <- label_col * 2 + } + ) + + # Offset layout based on title position switch( - label.position, + params$title.position, "top" = { - kl_widths <- utils::head( - interleave(pmax(label_widths, key_widths), hgap), - -1 - ) - kl_heights <- utils::head( - interleave(label_heights, vgap, key_heights, vgap), - -1 - ) - vps <- transform( - vps, - key.row = R * 4 - 1, - key.col = C * 2 - 1, - label.row = R * 4 - 3, - label.col = C * 2 - 1 - ) + key_row <- key_row + 2 + label_row <- label_row + 2 + title_row <- 2 + title_col <- seq_along(sizes$widths) + 1 }, "bottom" = { - kl_widths <- utils::head( - interleave(pmax(label_widths, key_widths), hgap), - -1 - ) - kl_heights <- utils::head( - interleave(key_heights, vgap, label_heights, vgap), - -1 - ) - vps <- transform( - vps, - key.row = R * 4 - 3, - key.col = C * 2 - 1, - label.row = R * 4 - 1, - label.col = C * 2 - 1 - ) + title_row <- length(sizes$heights) + 1 + title_col <- seq_along(sizes$widths) + 1 }, "left" = { - kl_widths <- utils::head( - interleave(label_widths, hgap, key_widths, hgap), - -1 - ) - kl_heights <- pmax(key_heights, label_heights) - vps <- transform( - vps, - key.row = R, - key.col = C * 4 - 1, - label.row = R, - label.col = C * 4 - 3 - ) + key_col <- key_col + 2 + label_col <- label_col + 2 + title_row <- seq_along(sizes$heights) + 1 + title_col <- 2 }, "right" = { - kl_widths <- utils::head( - interleave(key_widths, hgap, label_widths, hgap), - -1 - ) - kl_heights <- pmax(key_heights, label_heights) - vps <- transform( - vps, - key.row = R, - key.col = C * 4 - 3, - label.row = R, - label.col = C * 4 - 1 + title_row <- seq_along(sizes$heights) + 1 + title_col <- length(sizes$widths) + 1 + } + ) + + df <- cbind(df, key_row, key_col, label_row, label_col) + + list(layout = df, title_row = title_row, title_col = title_col) + }, + + assemble_drawing = function(grobs, layout, sizes, params, elements) { + + gt <- gtable( + widths = unit(c(sizes$padding[4], sizes$widths, sizes$padding[2]), "cm"), + heights = unit(c(sizes$padding[1], sizes$heights, sizes$padding[3]), "cm") + ) + + # Add background + if (!is.zero(elements$background)) { + gt <- gtable_add_grob( + gt, elements$background, + name = "background", clip = "off", + t = 1, r = -1, b = -1, l =1 + ) + } + + # Add title + if (!is.zero(grobs$title)) { + gt <- gtable_add_grob( + gt, + justify_grobs( + grobs$title, + hjust = elements$title$hjust, + vjust = elements$title$vjust, + int_angle = elements$title$angle, + debug = elements$title$debug + ), + name = "title", clip = "off", + t = min(layout$title_row), r = max(layout$title_col), + b = max(layout$title_row), l = min(layout$title_col) + ) + } + + # Extract appropriate part of layout + layout <- layout$layout + + # Add keys + if (!is.zero(grobs$decor)) { + n_key_layers <- params$n_key_layers %||% 1L + key_cols <- rep(layout$key_col, each = n_key_layers) + key_rows <- rep(layout$key_row, each = n_key_layers) + + # Add keys + gt <- gtable_add_grob( + gt, grobs$decor, + name = names(grobs$decor) %||% + paste("key", key_rows, key_cols, c("bg", seq_len(n_key_layers - 1)), + sep = "-"), + clip = "off", + t = key_rows, r = key_cols, b = key_rows, l = key_cols + ) + } + + if (!is.zero(grobs$labels)) { + labels <- if (params$rejust_labels %||% TRUE) { + justify_grobs( + grobs$labels, + hjust = elements$text$hjust, vjust = elements$text$vjust, + int_angle = elements$text$angle, debug = elements$text$debug ) - }) - } + } else { + grobs$labels + } + + gt <- gtable_add_grob( + gt, labels, + name = names(labels) %||% + paste("label", layout$label_row, layout$label_col, sep = "-"), + clip = "off", + t = layout$label_row, r = layout$label_col, + b = layout$label_row, l = layout$label_col + ) + } - # layout the title over key-label - switch(guide$title.position, - "top" = { - widths <- c(kl_widths, max(0, title_width - sum(kl_widths))) - heights <- c(title_height, vgap, kl_heights) - vps <- transform( - vps, - key.row = key.row + 2, - key.col = key.col, - label.row = label.row + 2, - label.col = label.col - ) - vps.title.row = 1; vps.title.col = 1:length(widths) - }, - "bottom" = { - widths <- c(kl_widths, max(0, title_width - sum(kl_widths))) - heights <- c(kl_heights, vgap, title_height) - vps <- transform( - vps, - key.row = key.row, - key.col = key.col, - label.row = label.row, - label.col = label.col - ) - vps.title.row = length(heights); vps.title.col = 1:length(widths) - }, - "left" = { - widths <- c(title_width, hgap, kl_widths) - heights <- c(kl_heights, max(0, title_height - sum(kl_heights))) - vps <- transform( - vps, - key.row = key.row, - key.col = key.col + 2, - label.row = label.row, - label.col = label.col + 2 - ) - vps.title.row = 1:length(heights); vps.title.col = 1 - }, - "right" = { - widths <- c(kl_widths, hgap, title_width) - heights <- c(kl_heights, max(0, title_height - sum(kl_heights))) - vps <- transform( - vps, - key.row = key.row, - key.col = key.col, - label.row = label.row, - label.col = label.col - ) - vps.title.row = 1:length(heights); vps.title.col = length(widths) - }) - - # grob for key - key_size <- c(key_width, key_height) * 10 - - draw_key <- function(i) { - bg <- element_render(theme, "legend.key") - keys <- lapply(guide$geoms, function(g) { - g$draw_key(g$data[i, , drop = FALSE], g$params, key_size) - }) - c(list(bg), keys) + gt } - grob.keys <- unlist(lapply(seq_len(nbreak), draw_key), recursive = FALSE) - - # background - grob.background <- element_render(theme, "legend.background") - - ngeom <- length(guide$geoms) + 1 - kcols <- rep(vps$key.col, each = ngeom) - krows <- rep(vps$key.row, each = ngeom) - - # padding - padding <- convertUnit(theme$legend.margin %||% margin(), "cm", valueOnly = TRUE) - widths <- c(padding[4], widths, padding[2]) - heights <- c(padding[1], heights, padding[3]) - - # Create the gtable for the legend - gt <- gtable(widths = unit(widths, "cm"), heights = unit(heights, "cm")) - gt <- gtable_add_grob( - gt, - grob.background, - name = "background", - clip = "off", - t = 1, - r = -1, - b = -1, - l = 1 - ) - gt <- gtable_add_grob( - gt, - justify_grobs( - grob.title, - hjust = title.hjust, - vjust = title.vjust, - int_angle = title.theme$angle, - debug = title.theme$debug - ), - name = "title", - clip = "off", - t = 1 + min(vps.title.row), - r = 1 + max(vps.title.col), - b = 1 + max(vps.title.row), - l = 1 + min(vps.title.col) - ) - gt <- gtable_add_grob( - gt, - grob.keys, - name = paste("key", krows, kcols, c("bg", seq(ngeom - 1)), sep = "-"), - clip = "off", - t = 1 + krows, - r = 1 + kcols, - b = 1 + krows, - l = 1 + kcols - ) - gt <- gtable_add_grob( - gt, - justify_grobs( - grob.labels, - hjust = hjust, - vjust = vjust, - int_angle = label.theme$angle, - debug = label.theme$debug - ), - name = paste("label", vps$label.row, vps$label.col, sep = "-"), - clip = "off", - t = 1 + vps$label.row, - r = 1 + vps$label.col, - b = 1 + vps$label.row, - l = 1 + vps$label.col - ) - gt -} +) +label_hjust_defaults <- c(top = 0.5, bottom = 0.5, left = 1, right = 0) +label_vjust_defaults <- c(top = 0, bottom = 1, left = 0.5, right = 0.5) -#' Calculate the default hjust and vjust settings depending on legend -#' direction and position. -#' -#' @noRd -label_just_defaults.legend <- function(direction, position) { - if (direction == "horizontal") { - switch( - position, - "top" = list(hjust = 0.5, vjust = 0), - "bottom" = list(hjust = 0.5, vjust = 1), - "left" = list(hjust = 1, vjust = 0.5), - list(hjust = 0, vjust = 0.5) - ) +measure_legend_keys <- function(decor, n, dim, byrow = FALSE, + default_width = 1, default_height = 1) { + if (is.null(decor)) { + ans <- list(widths = NULL, heights = NULL) + return(ans) } - else { - switch( - position, - "top" = list(hjust = 0.5, vjust = 0), - "bottom" = list(hjust = 0.5, vjust = 1), - "left" = list(hjust = 1, vjust = 0.5), - list(hjust = 0, vjust = 0.5) - ) + # Vector padding in case rows * cols > keys + zeroes <- rep(0, prod(dim) - n) + + # For every layer, extract the size in cm + size <- lapply(decor, function(g) g$data$size / 10) # mm to cm + size <- inject(cbind(!!!size)) + + # Guard against layers with no size aesthetic + if (any(dim(size) == 0)) { + size <- matrix(0, ncol = 1, nrow = n) + } else { + size <- size[seq_len(n), , drop = FALSE] } -} + # For every key, find maximum across all layers + size <- apply(size, 1, max) + # Apply legend layout + size <- matrix(c(size, zeroes), nrow = dim[1], ncol = dim[2], byrow = byrow) -utils::globalVariables(c("C", "R", "key.row", "key.col", "label.row", "label.col")) + list( + widths = pmax(default_width, apply(size, 2, max)), + heights = pmax(default_height, apply(size, 1, max)) + ) +} diff --git a/R/guide-none.R b/R/guide-none.R new file mode 100644 index 0000000000..ae26a8a1e9 --- /dev/null +++ b/R/guide-none.R @@ -0,0 +1,41 @@ +#' @include layer.R +NULL + +#' Empty guide +#' +#' This guide draws nothing. +#' +#' @inheritParams guide_axis +#' +#' @export +#' +guide_none <- function(title = waiver(), position = waiver()) { + new_guide( + title = title, + position = position, + available_aes = "any", + super = GuideNone + ) +} + +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +GuideNone <- ggproto( + "GuideNone", Guide, + + # Perform no training + train = function(self, params = self$params, scale, aesthetic = NULL, ...) { + params + }, + + transform = function(self, params, coord, ...) { + params + }, + + # Draw nothing + draw = function(self, params, theme) { + zeroGrob() + } +) diff --git a/R/guides-.R b/R/guides-.R index 739944e0cc..66883b0e58 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -1,3 +1,6 @@ +#' @include guide-none.R +NULL + #' Set guides for each scale #' #' Guides for each scale can be set scale-by-scale with the `guide` @@ -76,303 +79,487 @@ guides <- function(...) { args[idx_false] <- "none" } - structure(args, class = "guides") + # The good path + if (is_named(args)) { + return(guides_list(guides = args)) + } + + # Raise error about unnamed guides + nms <- names(args) + if (is.null(nms)) { + msg <- "All guides are unnamed." + } else { + unnamed <- which(is.na(nms) | nms == "") + if (length(unnamed) == length(args)) { + msg <- "All guides are unnamed." + } else { + unnamed <- label_ordinal()(unnamed) + msg <- "The {.and {unnamed}} guide{?s} {?is/are} unnamed." + } + } + cli::cli_abort(c( + "Guides provided to {.fun guides} must be named.", + i = msg + )) } update_guides <- function(p, guides) { p <- plot_clone(p) - p$guides <- defaults(guides, p$guides) + if (inherits(p$guides, "Guides")) { + old <- p$guides + new <- ggproto(NULL, old) + new$add(guides) + p$guides <- new + } else { + p$guides <- guides + } p } +# Class ------------------------------------------------------------------- -# building non-position guides - called in ggplotGrob (plot-build.r) -# -# the procedure is as follows: -# -# 1. guides_train() -# train each scale and generate guide definition for all guides -# here, one gdef for one scale -# -# 2. guides_merge() -# merge gdefs if they are overlayed -# number of gdefs may be less than number of scales -# -# 3. guides_geom() -# process layer information and generate geom info. -# -# 4. guides_gengrob() -# generate ggrob from each gdef -# one ggrob for one gdef -# -# 5. guides_build() -# arrange all ggrobs - -build_guides <- function(scales, layers, default_mapping, position, theme, guides, labels) { - theme$legend.key.width <- theme$legend.key.width %||% theme$legend.key.size - theme$legend.key.height <- theme$legend.key.height %||% theme$legend.key.size - - # Layout of legends depends on their overall location - position <- legend_position(position) - if (position == "inside") { - theme$legend.box <- theme$legend.box %||% "vertical" - theme$legend.direction <- theme$legend.direction %||% "vertical" - theme$legend.box.just <- theme$legend.box.just %||% c("center", "center") - } else if (position == "vertical") { - theme$legend.box <- theme$legend.box %||% "vertical" - theme$legend.direction <- theme$legend.direction %||% "vertical" - theme$legend.box.just <- theme$legend.box.just %||% c("left", "top") - } else if (position == "horizontal") { - theme$legend.box <- theme$legend.box %||% "horizontal" - theme$legend.direction <- theme$legend.direction %||% "horizontal" - theme$legend.box.just <- theme$legend.box.just %||% c("center", "top") - } - - # scales -> data for guides - gdefs <- guides_train( - scales = scales$non_position_scales(), - theme = theme, - guides = guides, - labels = labels - ) +# Guides object encapsulates multiple guides and their state. +guides_list <- function(guides = NULL) { + ggproto(NULL, Guides, guides = guides) +} - if (length(gdefs) == 0) return(zeroGrob()) +Guides <- ggproto( + "Guides", NULL, - # merge overlay guides - gdefs <- guides_merge(gdefs) + ## Fields -------------------------------------------------------------------- - # process layer information - gdefs <- guides_geom(gdefs, layers, default_mapping) - if (length(gdefs) == 0) return(zeroGrob()) + # `guides` is the only initially mutable field. + # It gets populated as a user adds `+ guides(...)` to a plot by the + # `Guides$add()` method. + guides = list(), - # generate grob of each guides - ggrobs <- guides_gengrob(gdefs, theme) + # To avoid repeatedly calling `guide_none()` to substitute missing guides, + # we include its result as a field in the `Guides` class. This field is + # never updated. + missing = guide_none(), - # build up guides - grobs <- guides_build(ggrobs, theme) + ## Setters ------------------------------------------------------------------- - grobs -} + # Function for adding new guides provided by user + add = function(self, guides) { + if (is.null(guides)) { + return(invisible()) + } + if (inherits(guides, "Guides")) { + guides <- guides$guides + } + self$guides <- defaults(guides, self$guides) + invisible() + }, + + # Updates the parameters of the guides. NULL parameters indicate switch to + # `guide_none()` from `Guide$missing` field. + update_params = function(self, params) { + if (length(params) != length(self$params)) { + cli::cli_abort(paste0( + "Cannot update {length(self$params)} guide{?s} with a list of ", + "parameter{?s} of length {length(params)}." + )) + } + # Find empty parameters + is_empty <- vapply(params, is.null, logical(1)) + # Do parameter update + self$params[!is_empty] <- params[!is_empty] + + # Set empty parameter guides to `guide_none`. Don't overwrite parameters, + # because things like 'position' are relevant. + self$guides[is_empty] <- list(self$missing) + invisible() + }, + + # Function for dropping GuideNone objects from the Guides object. Typically + # called after training the guides on scales. + subset_guides = function(self, i) { + self$guides <- self$guides[i] + self$aesthetics <- self$aesthetics[i] + self$params <- self$params[i] + invisible() + }, + + ## Getters ------------------------------------------------------------------- + + # Function for retrieving guides by index or aesthetic + get_guide = function(self, index) { + if (is.character(index)) { + index <- match(index, self$aesthetics) + } + if (any(is.na(index)) || length(index) == 0) { + return(NULL) + } + if (length(index) == 1) { + self$guides[[index]] + } else { + self$guides[index] + } + }, -# Simplify legend position to one of horizontal/vertical/inside -legend_position <- function(position) { - if (length(position) == 1) { - if (position %in% c("top", "bottom")) { - "horizontal" + # Function for retrieving parameters by guide or aesthetic + get_params = function(self, index) { + if (is.character(index)) { + index <- match(index, self$aesthetics) + } + if (any(is.na(index)) || length(index) == 0) { + return(NULL) + } + if (length(index) == 1) { + self$params[[index]] } else { - "vertical" + self$params[index] + } + }, + + ## Building ------------------------------------------------------------------ + + # The `Guides$build()` method is called in ggplotGrob (plot-build.R) and makes + # the guide box for *non-position* scales. + # Note that position scales are handled in `Coord`s, which have their own + # procedures to do equivalent steps. + # + # The procedure is as follows: + # + # 1. Guides$setup() + # generates a guide object for every scale-aesthetic pair + # + # 2. Guides$train() + # train each scale and generate guide definition for all guides + # here, one guide object for one scale + # + # 2. Guides$merge() + # merge guide objects if they are overlayed + # number of guide objects may be less than number of scales + # + # 3. Guides$process_layers() + # process layer information and generate geom info. + # + # 4. Guides$draw() + # generate guide grob from each guide object + # one guide grob for one guide object + # + # 5. Guides$assemble() + # arrange all guide grobs + + build = function(self, scales, layers, default_mapping, + position, theme, labels) { + + position <- legend_position(position) + no_guides <- zeroGrob() + if (position == "none") { + return(no_guides) } - } else { - "inside" - } -} -# resolve the guide from the scale and guides -resolve_guide <- function(aesthetic, scale, guides, default = "none", null = "none") { - guides[[aesthetic]] %||% scale$guide %|W|% default %||% null -} + theme$legend.key.width <- theme$legend.key.width %||% theme$legend.key.size + theme$legend.key.height <- theme$legend.key.height %||% theme$legend.key.size -# validate guide object -validate_guide <- function(guide) { - # if guide is specified by character, then find the corresponding guide - # when guides are officially extensible, this should use find_global() - if (is.character(guide)) - match.fun(paste("guide_", guide, sep = ""))() - else if (inherits(guide, "guide")) - guide - else - cli::cli_abort("Unknown guide: {guide}") -} -# train each scale in scales and generate the definition of guide -guides_train <- function(scales, theme, guides, labels) { + default_direction <- if (position == "inside") "vertical" else position + theme$legend.box <- theme$legend.box %||% default_direction + theme$legend.direction <- theme$legend.direction %||% default_direction + theme$legend.box.just <- theme$legend.box.just %||% switch( + position, + inside = c("center", "center"), + vertical = c("left", "top"), + horizontal = c("center", "top") + ) + + # Setup and train on scales + scales <- scales$non_position_scales()$scales + if (length(scales) == 0) { + return(no_guides) + } + guides <- self$setup(scales) + guides$train(scales, theme$legend.direction, labels) + if (length(guides$guides) == 0) { + return(no_guides) + } + + # Merge and process layers + guides$merge() + guides$process_layers(layers) + if (length(guides$guides) == 0) { + return(no_guides) + } + + # Draw and assemble + grobs <- guides$draw(theme) + guides$assemble(grobs, theme) + }, + + # Setup routine for resolving and validating guides based on paired scales. + # + # The output of the setup is a child `Guides` class with two additional + # mutable fields, both of which are parallel to the child's `Guides$guides` + # field. + # + # 1. The child's `Guides$params` manages all parameters of a guide that may + # need to be updated during subsequent steps. This ensures that we never need + # to update the `Guide` itself and risk reference class shenanigans. + # + # 2. The child's `Guides$aesthetics` holds the aesthetic name of the scale + # that spawned the guide. The `Coord`'s own build methods need this to + # correctly pick the primary and secondary guides. + + setup = function( + self, scales, aesthetics = NULL, + default = self$missing, + missing = self$missing + ) { + + if (is.null(aesthetics)) { + # Aesthetics from scale, as in non-position guides + aesthetics <- lapply(scales, `[[`, "aesthetics") + scale_idx <- rep(seq_along(scales), lengths(aesthetics)) + aesthetics <- unlist(aesthetics, FALSE, FALSE) + } else { + # Scale based on aesthetics, as in position guides + scale_idx <- seq_along(scales)[match(aesthetics, names(scales))] + } - gdefs <- list() - for (scale in scales$scales) { - for (output in scale$aesthetics) { + guides <- self$guides - # guides(XXX) is stored in guides[[XXX]], - # which is prior to scale_ZZZ(guide=XXX) - # guide is determined in order of: - # + guides(XXX) > + scale_ZZZ(guide=XXX) > default(i.e., legend) - guide <- resolve_guide(output, scale, guides) + # For every aesthetic-scale combination, find and validate guide + new_guides <- lapply(seq_along(scale_idx), function(i) { + idx <- scale_idx[i] - if (identical(guide, "none") || inherits(guide, "guide_none")) next + # Find guide for aesthetic-scale combination + # Hierarchy is in the order: + # plot + guides(XXX) + scale_ZZZ(guide = XXX) > default(i.e., legend) + guide <- resolve_guide( + aesthetic = aesthetics[i], + scale = scales[[idx]], + guides = guides, + default = default, + null = missing + ) if (isFALSE(guide)) { deprecate_warn0("3.3.4", I("The `guide` argument in `scale_*()` cannot be `FALSE`. This "), I('"none"')) - next + guide <- "none" } - # check the validity of guide. - # if guide is character, then find the guide object + # Instantiate all guides, e.g. go from "legend" character to + # GuideLegend class object guide <- validate_guide(guide) - # check the consistency of the guide and scale. - if (!identical(guide$available_aes, "any") && !any(scale$aesthetics %in% guide$available_aes)) { - cli::cli_abort("Guide {.var {guide$name}} cannot be used for {.field {scale$aesthetics}}.") + if (inherits(guide, "GuideNone")) { + return(guide) } - guide$title <- scale$make_title(guide$title %|W|% scale$name %|W|% labels[[output]]) - - # direction of this grob - guide$direction <- guide$direction %||% theme$legend.direction - - # each guide object trains scale within the object, - # so Guides (i.e., the container of guides) need not to know about them - guide <- guide_train(guide, scale, output) - - if (!is.null(guide)) gdefs[[length(gdefs) + 1]] <- guide - } - } - gdefs -} - -# merge overlapped guides -guides_merge <- function(gdefs) { - # split gdefs based on hash, and apply Reduce (guide_merge) to each gdef group. - gdefs <- lapply(gdefs, function(g) { - if (g$order == 0) { - order <- "99" - } else { - order <- sprintf("%02d", g$order) - } - g$hash <- paste(order, g$hash, sep = "_") - g - }) - tapply(gdefs, sapply(gdefs, function(g)g$hash), function(gs)Reduce(guide_merge, gs)) -} - -# process layer information -# TODO: `default_mapping` is unused internally but kept for backwards compitability until guide rewrite -guides_geom <- function(gdefs, layers, default_mapping) { - compact(lapply(gdefs, guide_geom, layers, default_mapping)) -} - -# generate grob from each gdef (needs to write this function?) -guides_gengrob <- function(gdefs, theme) { - # common drawing process for all guides - gdefs <- lapply(gdefs, - function(g) { - g$title.position <- g$title.position %||% switch(g$direction, vertical = "top", horizontal = "left") - if (!g$title.position %in% c("top", "bottom", "left", "right")) { - cli::cli_abort(c( - "Title position {.val {g$title.position}} is invalid", - "i" = "Use one of {.val top}, {.val bottom}, {.val left}, or {.val right}" + # Check compatibility of scale and guide, e.g. you cannot use GuideAxis + # to display the "colour" aesthetic. + scale_aes <- scales[[idx]]$aesthetics + if (!any(c("x", "y") %in% scale_aes)) scale_aes <- c(scale_aes, "any") + if (!any(scale_aes %in% guide$available_aes)) { + warn_aes <- guide$available_aes + warn_aes[warn_aes == "any"] <- "any non position aesthetic" + cli::cli_warn(c( + paste0("{.fn {snake_class(guide)}} cannot be used for ", + "{.or {.field {head(scales[[idx]]$aesthetics, 4)}}}."), + i = "Use {?one of} {.or {.field {warn_aes}}} instead." )) + guide <- missing } - g - }) - - lapply(gdefs, guide_gengrob, theme) -} - -# build up all guide boxes into one guide-boxes. -guides_build <- function(ggrobs, theme) { - theme$legend.spacing <- theme$legend.spacing %||% unit(0.5, "lines") - theme$legend.spacing.y <- theme$legend.spacing.y %||% theme$legend.spacing - theme$legend.spacing.x <- theme$legend.spacing.x %||% theme$legend.spacing - - widths <- lapply(ggrobs, function(g) sum(g$widths)) - widths <- inject(unit.c(!!!widths)) - heights <- lapply(ggrobs, function(g) sum(g$heights)) - heights <- inject(unit.c(!!!heights)) - - # Set the justification of each legend within the legend box - # First value is xjust, second value is yjust - just <- valid.just(theme$legend.box.just) - xjust <- just[1] - yjust <- just[2] - - # setting that is different for vertical and horizontal guide-boxes. - if (identical(theme$legend.box, "horizontal")) { - # Set justification for each legend - for (i in seq_along(ggrobs)) { - ggrobs[[i]] <- editGrob(ggrobs[[i]], - vp = viewport(x = xjust, y = yjust, just = c(xjust, yjust), - height = heightDetails(ggrobs[[i]]))) - } - guides <- gtable_row(name = "guides", - grobs = ggrobs, - widths = widths, height = max(heights)) - - # add space between the guide-boxes - guides <- gtable_add_col_space(guides, theme$legend.spacing.x) + guide + }) - } else { # theme$legend.box == "vertical" - # Set justification for each legend - for (i in seq_along(ggrobs)) { - ggrobs[[i]] <- editGrob(ggrobs[[i]], - vp = viewport(x = xjust, y = yjust, just = c(xjust, yjust), - width = widthDetails(ggrobs[[i]]))) + # Create updated child + ggproto( + NULL, self, + guides = new_guides, + # Extract the guide's params to manage separately + params = lapply(new_guides, `[[`, "params"), + aesthetics = aesthetics + ) + }, + + # Loop over every guide-scale combination to perform training + # A strong assumption here is that `scales` is parallel to the guides + train = function(self, scales, direction, labels) { + + params <- Map( + function(guide, param, scale, aes) { + guide$train( + param, scale, aes, + title = labels[[aes]], + direction = direction + ) + }, + guide = self$guides, + param = self$params, + aes = self$aesthetics, + scale = scales + ) + self$update_params(params) + is_none <- vapply(self$guides, inherits, logical(1), what = "GuideNone") + self$subset_guides(!is_none) + }, + + # Function to merge guides that encode the same information + merge = function(self) { + # Bundle together guides and their parameters + pairs <- Map(list, guide = self$guides, params = self$params) + + # If there is only one guide, we can exit early, because nothing to merge + if (length(pairs) == 1) { + return() } - guides <- gtable_col(name = "guides", - grobs = ggrobs, - width = max(widths), heights = heights) - - # add space between the guide-boxes - guides <- gtable_add_row_space(guides, theme$legend.spacing.y) - } - - # Add margins around the guide-boxes. - theme$legend.box.margin <- theme$legend.box.margin %||% margin() - guides <- gtable_add_cols(guides, theme$legend.box.margin[4], pos = 0) - guides <- gtable_add_cols(guides, theme$legend.box.margin[2], pos = ncol(guides)) - guides <- gtable_add_rows(guides, theme$legend.box.margin[1], pos = 0) - guides <- gtable_add_rows(guides, theme$legend.box.margin[3], pos = nrow(guides)) - - # Add legend box background - background <- element_grob(theme$legend.box.background %||% element_blank()) + # The `{order}_{hash}` combination determines groups of guides + orders <- vapply(self$params, `[[`, 0, "order") + orders[orders == 0] <- 99 + orders <- sprintf("%02d", orders) + hashes <- vapply(self$params, `[[`, "", "hash") + hashes <- paste(orders, hashes, sep = "_") + + # Split by hashes + indices <- split(seq_along(pairs), hashes) + indices <- vapply(indices, `[[`, 0L, 1L, USE.NAMES = FALSE) # First index + groups <- unname(split(pairs, hashes)) + lens <- lengths(groups) + + # Merge groups with >1 member + groups[lens > 1] <- lapply(groups[lens > 1], function(group) { + Reduce(function(old, new) { + old$guide$merge(old$params, new$guide, new$params) + }, group) + }) + groups[lens == 1] <- unlist(groups[lens == 1], FALSE) + + # Update the Guides object + self$guides <- lapply(groups, `[[`, "guide") + self$params <- lapply(groups, `[[`, "params") + self$aesthetics <- self$aesthetics[indices] + invisible() + }, + + # Loop over guides to let them extract information from layers + process_layers = function(self, layers) { + self$params <- Map( + function(guide, param) guide$get_layer_key(param, layers), + guide = self$guides, + param = self$params + ) + keep <- !vapply(self$params, is.null, logical(1)) + self$subset_guides(keep) + invisible() + }, + + # Loop over every guide, let them draw their grobs + draw = function(self, theme) { + Map( + function(guide, params) guide$draw(theme, params), + guide = self$guides, + params = self$params + ) + }, + + # Combining multiple guides in a guide box + assemble = function(grobs, theme) { + # Set spacing + theme$legend.spacing <- theme$legend.spacing %||% unit(0.5, "lines") + theme$legend.spacing.y <- theme$legend.spacing.y %||% theme$legend.spacing + theme$legend.spacing.x <- theme$legend.spacing.x %||% theme$legend.spacing + + # Measure guides + widths <- lapply(grobs, function(g) sum(g$widths)) + widths <- inject(unit.c(!!!widths)) + heights <- lapply(grobs, function(g) sum(g$heights)) + heights <- inject(unit.c(!!!heights)) + + # Set the justification of each legend within the legend box + # First value is xjust, second value is yjust + just <- valid.just(theme$legend.box.just) + xjust <- just[1] + yjust <- just[2] + + # setting that is different for vertical and horizontal guide-boxes. + if (identical(theme$legend.box, "horizontal")) { + # Set justification for each legend + for (i in seq_along(grobs)) { + grobs[[i]] <- editGrob( + grobs[[i]], + vp = viewport(x = xjust, y = yjust, just = c(xjust, yjust), + height = heightDetails(grobs[[i]])) + ) + } - guides <- gtable_add_grob(guides, background, t = 1, l = 1, - b = -1, r = -1, z = -Inf, clip = "off", name = "legend.box.background") - guides$name <- "guide-box" - guides -} + guides <- gtable_row(name = "guides", + grobs = grobs, + widths = widths, height = max(heights)) + + # add space between the guide-boxes + guides <- gtable_add_col_space(guides, theme$legend.spacing.x) + + } else { # theme$legend.box == "vertical" + # Set justification for each legend + for (i in seq_along(grobs)) { + grobs[[i]] <- editGrob( + grobs[[i]], + vp = viewport(x = xjust, y = yjust, just = c(xjust, yjust), + width = widthDetails(grobs[[i]])) + ) + } -# Generics ---------------------------------------------------------------- + guides <- gtable_col(name = "guides", + grobs = grobs, + width = max(widths), heights = heights) -#' S3 generics for guides. -#' -#' You will need to provide methods for these S3 generics if you want to -#' create your own guide object. They are currently undocumented; use at -#' your own risk! -#' -#' @param guide The guide object -#' @keywords internal -#' @name guide-exts -NULL + # add space between the guide-boxes + guides <- gtable_add_row_space(guides, theme$legend.spacing.y) + } -#' @export -#' @rdname guide-exts -guide_train <- function(guide, scale, aesthetic = NULL) UseMethod("guide_train") + # Add margins around the guide-boxes. + margin <- theme$legend.box.margin %||% margin() + guides <- gtable_add_cols(guides, margin[4], pos = 0) + guides <- gtable_add_cols(guides, margin[2], pos = ncol(guides)) + guides <- gtable_add_rows(guides, margin[1], pos = 0) + guides <- gtable_add_rows(guides, margin[3], pos = nrow(guides)) -#' @export -#' @rdname guide-exts -guide_merge <- function(guide, new_guide) UseMethod("guide_merge") + # Add legend box background + background <- element_grob(theme$legend.box.background %||% element_blank()) -#' @export -#' @rdname guide-exts -guide_geom <- function(guide, layers, default_mapping) UseMethod("guide_geom") + guides <- gtable_add_grob( + guides, background, + t = 1, l = 1, b = -1, r = -1, + z = -Inf, clip = "off", + name = "legend.box.background" + ) + guides$name <- "guide-box" + guides + }, -#' @export -#' @rdname guide-exts -guide_transform <- function(guide, coord, panel_params) UseMethod("guide_transform") + ## Utilities ----------------------------------------------------------------- -#' @export -guide_transform.default <- function(guide, coord, panel_params) { - cli::cli_abort(c( - "Guide with class {.cls {class(guide)}} does not implement {.fn guide_transform}", - "i" = "Did you mean to use {.fn guide_axis}?" - )) -} + print = function(self) { -#' @export -#' @rdname guide-exts -guide_gengrob <- function(guide, theme) UseMethod("guide_gengrob") + guides <- self$guides + header <- paste0("\n") + if (length(guides) == 0) { + content <- "" + } else { + content <- lapply(guides, function(g) { + if (is.character(g)) { + paste0('"', g, '"') + } else { + paste0("<", class(g)[[1]], ">") + } + }) + nms <- names(content) + nms <- format(nms, justify = "right") + content <- unlist(content, FALSE, FALSE) + content <- format(content, justify = "left") + content <- paste0(nms, " : ", content) + } + cat(c(header, content), sep = "\n") + invisible(self) + } +) # Helpers ----------------------------------------------------------------- @@ -418,3 +605,38 @@ include_layer_in_guide <- function(layer, matched) { # Default is to exclude it, except if it is explicitly turned on isTRUE(layer$show.legend) } + +# Simplify legend position to one of horizontal/vertical/inside +legend_position <- function(position) { + if (length(position) == 1) { + if (position %in% c("top", "bottom")) { + "horizontal" + } else { + "vertical" + } + } else { + "inside" + } +} + +# resolve the guide from the scale and guides +resolve_guide <- function(aesthetic, scale, guides, default = "none", null = "none") { + guides[[aesthetic]] %||% scale$guide %|W|% default %||% null +} + +# validate guide object +validate_guide <- function(guide) { + # if guide is specified by character, then find the corresponding guide + if (is.character(guide)) { + fun <- find_global(paste0("guide_", guide), env = global_env(), + mode = "function") + if (is.function(fun)) { + guide <- fun() + } + } + if (inherits(guide, "Guide")) { + guide + } else { + cli::cli_abort("Unknown guide: {guide}") + } +} diff --git a/R/guides-axis.R b/R/guides-axis.R deleted file mode 100644 index dbd4b11a3b..0000000000 --- a/R/guides-axis.R +++ /dev/null @@ -1,447 +0,0 @@ - -#' Axis guide -#' -#' Axis guides are the visual representation of position scales like those -#' created with [scale_(x|y)_continuous()][scale_x_continuous()] and -#' [scale_(x|y)_discrete()][scale_x_discrete()]. -#' -#' @inheritParams guide_legend -#' @param check.overlap silently remove overlapping labels, -#' (recursively) prioritizing the first, last, and middle labels. -#' @param angle Compared to setting the angle in [theme()] / [element_text()], -#' this also uses some heuristics to automatically pick the `hjust` and `vjust` that -#' you probably want. -#' @param n.dodge The number of rows (for vertical axes) or columns (for -#' horizontal axes) that should be used to render the labels. This is -#' useful for displaying labels that would otherwise overlap. -#' @param order Used to determine the order of the guides (left-to-right, -#' top-to-bottom), if more than one guide must be drawn at the same location. -#' @param position Where this guide should be drawn: one of top, bottom, -#' left, or right. -#' -#' @export -#' -#' @examples -#' # plot with overlapping text -#' p <- ggplot(mpg, aes(cty * 100, hwy * 100)) + -#' geom_point() + -#' facet_wrap(vars(class)) -#' -#' # axis guides can be customized in the scale_* functions or -#' # using guides() -#' p + scale_x_continuous(guide = guide_axis(n.dodge = 2)) -#' p + guides(x = guide_axis(angle = 90)) -#' -#' # can also be used to add a duplicate guide -#' p + guides(x = guide_axis(n.dodge = 2), y.sec = guide_axis()) -#' -#' -guide_axis <- function(title = waiver(), check.overlap = FALSE, angle = NULL, n.dodge = 1, - order = 0, position = waiver()) { - structure( - list( - title = title, - - # customizations - check.overlap = check.overlap, - angle = angle, - n.dodge = n.dodge, - - # general - order = order, - position = position, - - # parameter - available_aes = c("x", "y"), - - name = "axis" - ), - class = c("guide", "axis") - ) -} - -#' @export -guide_train.axis <- function(guide, scale, aesthetic = NULL) { - - aesthetic <- aesthetic %||% scale$aesthetics[1] - breaks <- scale$get_breaks() - - empty_ticks <- data_frame0( - aesthetic = numeric(0), - .value = numeric(0), - .label = character(0) - ) - names(empty_ticks) <- c(aesthetic, ".value", ".label") - - if (length(intersect(scale$aesthetics, guide$available_aes)) == 0) { - cli::cli_warn(c( - "Axis guide lacks appropriate scales", - i = "Use one of {.or {.field {guide$available_aes}}}" - )) - guide$key <- empty_ticks - } else if (length(breaks) == 0) { - guide$key <- empty_ticks - } else { - mapped_breaks <- if (scale$is_discrete()) scale$map(breaks) else breaks - ticks <- data_frame(mapped_breaks, .name_repair = ~ aesthetic) - ticks$.value <- breaks - ticks$.label <- scale$get_labels(breaks) - - guide$key <- ticks[is.finite(ticks[[aesthetic]]), ] - } - - guide$name <- paste0(guide$name, "_", aesthetic) - guide$hash <- hash(list(guide$title, guide$key$.value, guide$key$.label, guide$name)) - guide -} - -#' @export -guide_transform.axis <- function(guide, coord, panel_params) { - if (is.null(guide$position) || nrow(guide$key) == 0) { - return(guide) - } - - aesthetics <- names(guide$key)[!grepl("^\\.", names(guide$key))] - - if (all(c("x", "y") %in% aesthetics)) { - guide$key <- coord$transform(guide$key, panel_params) - } else { - other_aesthetic <- setdiff(c("x", "y"), aesthetics) - override_value <- if (guide$position %in% c("bottom", "left")) -Inf else Inf - guide$key[[other_aesthetic]] <- override_value - - guide$key <- coord$transform(guide$key, panel_params) - - warn_for_guide_position(guide) - } - - guide -} - -# discards the new guide with a warning -#' @export -guide_merge.axis <- function(guide, new_guide) { - if (!inherits(new_guide, "guide_none")) { - cli::cli_warn(c( - "{.fn guide_axis}: Discarding guide on merge", - "i" = "Do you have more than one guide with the same position?" - )) - } - - guide -} - -# axis guides don't care which geometry uses these aesthetics -#' @export -guide_geom.axis <- function(guide, layers, default_mapping) { - guide -} - -#' @export -guide_gengrob.axis <- function(guide, theme) { - aesthetic <- names(guide$key)[!grepl("^\\.", names(guide$key))][1] - - draw_axis( - break_positions = guide$key[[aesthetic]], - break_labels = guide$key$.label, - axis_position = guide$position, - theme = theme, - check.overlap = guide$check.overlap, - angle = guide$angle, - n.dodge = guide$n.dodge - ) -} - - -#' Grob for axes -#' -#' @param break_position position of ticks -#' @param break_labels labels at ticks -#' @param axis_position position of axis (top, bottom, left or right) -#' @param theme A complete [theme()] object -#' @param check.overlap silently remove overlapping labels, -#' (recursively) prioritizing the first, last, and middle labels. -#' @param angle Compared to setting the angle in [theme()] / [element_text()], -#' this also uses some heuristics to automatically pick the `hjust` and `vjust` that -#' you probably want. -#' @param n.dodge The number of rows (for vertical axes) or columns (for -#' horizontal axes) that should be used to render the labels. This is -#' useful for displaying labels that would otherwise overlap. -#' -#' @noRd -#' -draw_axis <- function(break_positions, break_labels, axis_position, theme, - check.overlap = FALSE, angle = NULL, n.dodge = 1) { - axis_position <- arg_match0(axis_position, c("top", "bottom", "right", "left")) - aesthetic <- if (axis_position %in% c("top", "bottom")) "x" else "y" - - # resolve elements - line_element_name <- paste0("axis.line.", aesthetic, ".", axis_position) - tick_element_name <- paste0("axis.ticks.", aesthetic, ".", axis_position) - tick_length_element_name <- paste0("axis.ticks.length.", aesthetic, ".", axis_position) - label_element_name <- paste0("axis.text.", aesthetic, ".", axis_position) - - line_element <- calc_element(line_element_name, theme) - tick_element <- calc_element(tick_element_name, theme) - tick_length <- calc_element(tick_length_element_name, theme) - label_element <- calc_element(label_element_name, theme) - - # override label element parameters for rotation - if (inherits(label_element, "element_text")) { - label_overrides <- axis_label_element_overrides(axis_position, angle) - # label_overrides is an element_text, but label_element may not be; - # to merge the two elements, we just copy angle, hjust, and vjust - # unless their values are NULL - if (!is.null(label_overrides$angle)) { - label_element$angle <- label_overrides$angle - } - if (!is.null(label_overrides$hjust)) { - label_element$hjust <- label_overrides$hjust - } - if (!is.null(label_overrides$vjust)) { - label_element$vjust <- label_overrides$vjust - } - } - - # conditionally set parameters that depend on axis orientation - is_vertical <- axis_position %in% c("left", "right") - - position_dim <- if (is_vertical) "y" else "x" - non_position_dim <- if (is_vertical) "x" else "y" - position_size <- if (is_vertical) "height" else "width" - non_position_size <- if (is_vertical) "width" else "height" - gtable_element <- if (is_vertical) gtable_row else gtable_col - measure_gtable <- if (is_vertical) gtable_width else gtable_height - measure_labels_non_pos <- if (is_vertical) grobWidth else grobHeight - - # conditionally set parameters that depend on which side of the panel - # the axis is on - is_second <- axis_position %in% c("right", "top") - - tick_direction <- if (is_second) 1 else -1 - non_position_panel <- if (is_second) unit(0, "npc") else unit(1, "npc") - tick_coordinate_order <- if (is_second) c(2, 1) else c(1, 2) - - # conditionally set the gtable ordering - labels_first_gtable <- axis_position %in% c("left", "top") # refers to position in gtable - - # set common parameters - n_breaks <- length(break_positions) - opposite_positions <- c("top" = "bottom", "bottom" = "top", "right" = "left", "left" = "right") - axis_position_opposite <- unname(opposite_positions[axis_position]) - - # draw elements - line_grob <- exec( - element_grob, line_element, - !!position_dim := unit(c(0, 1), "npc"), - !!non_position_dim := unit.c(non_position_panel, non_position_panel) - ) - - if (n_breaks == 0) { - return( - absoluteGrob( - gList(line_grob), - width = grobWidth(line_grob), - height = grobHeight(line_grob) - ) - ) - } - - # break_labels can be a list() of language objects - if (is.list(break_labels)) { - if (any(vapply(break_labels, is.language, logical(1)))) { - break_labels <- inject(expression(!!!break_labels)) - } else { - break_labels <- unlist(break_labels) - } - } - - # calculate multiple rows/columns of labels (which is usually 1) - dodge_pos <- rep(seq_len(n.dodge), length.out = n_breaks) - dodge_indices <- split(seq_len(n_breaks), dodge_pos) - - label_grobs <- lapply(dodge_indices, function(indices) { - draw_axis_labels( - break_positions = break_positions[indices], - break_labels = break_labels[indices], - label_element = label_element, - is_vertical = is_vertical, - check.overlap = check.overlap - ) - }) - - ticks_grob <- exec( - element_grob, tick_element, - !!position_dim := rep(unit(break_positions, "native"), each = 2), - !!non_position_dim := rep( - unit.c(non_position_panel + (tick_direction * tick_length), non_position_panel)[tick_coordinate_order], - times = n_breaks - ), - id.lengths = rep(2, times = n_breaks) - ) - - # create gtable - non_position_sizes <- paste0(non_position_size, "s") - label_dims <- lapply(label_grobs, measure_labels_non_pos) - label_dims <- inject(unit.c(!!!label_dims)) - grobs <- c(list(ticks_grob), label_grobs) - grob_dims <- unit.c(max(tick_length, unit(0, "pt")), label_dims) - - if (labels_first_gtable) { - grobs <- rev(grobs) - grob_dims <- rev(grob_dims) - } - - gt <- exec( - gtable_element, - name = "axis", - grobs = grobs, - !!non_position_sizes := grob_dims, - !!position_size := unit(1, "npc") - ) - - # create viewport - justvp <- exec( - viewport, - !!non_position_dim := non_position_panel, - !!non_position_size := measure_gtable(gt), - just = axis_position_opposite - ) - - absoluteGrob( - gList(line_grob, gt), - width = gtable_width(gt), - height = gtable_height(gt), - vp = justvp - ) -} - -draw_axis_labels <- function(break_positions, break_labels, label_element, is_vertical, - check.overlap = FALSE) { - - position_dim <- if (is_vertical) "y" else "x" - label_margin_name <- if (is_vertical) "margin_x" else "margin_y" - - n_breaks <- length(break_positions) - break_positions <- unit(break_positions, "native") - - if (check.overlap) { - priority <- axis_label_priority(n_breaks) - break_labels <- break_labels[priority] - break_positions <- break_positions[priority] - } - - labels_grob <- exec( - element_grob, label_element, - !!position_dim := break_positions, - !!label_margin_name := TRUE, - label = break_labels, - check.overlap = check.overlap - ) -} - -#' Determine the label priority for a given number of labels -#' -#' @param n The number of labels -#' -#' @return The vector `seq_len(n)` arranged such that the -#' first, last, and middle elements are recursively -#' placed at the beginning of the vector. -#' @noRd -#' -axis_label_priority <- function(n) { - if (n <= 0) { - return(numeric(0)) - } - - c(1, n, axis_label_priority_between(1, n)) -} - -axis_label_priority_between <- function(x, y) { - n <- y - x + 1 - if (n <= 2) { - return(numeric(0)) - } - - mid <- x - 1 + (n + 1) %/% 2 - c( - mid, - axis_label_priority_between(x, mid), - axis_label_priority_between(mid, y) - ) -} - -#' Override axis text angle and alignment -#' -#' @param axis_position One of bottom, left, top, or right -#' @param angle The text angle, or NULL to override nothing -#' -#' @return An [element_text()] that contains parameters that should be -#' overridden from the user- or theme-supplied element. -#' @noRd -#' -axis_label_element_overrides <- function(axis_position, angle = NULL) { - if (is.null(angle)) { - return(element_text(angle = NULL, hjust = NULL, vjust = NULL)) - } - - # it is not worth the effort to align upside-down labels properly - check_number_decimal(angle, min = -90, max = 90) - - if (axis_position == "bottom") { - element_text( - angle = angle, - hjust = if (angle > 0) 1 else if (angle < 0) 0 else 0.5, - vjust = if (abs(angle) == 90) 0.5 else 1 - ) - } else if (axis_position == "left") { - element_text( - angle = angle, - hjust = if (abs(angle) == 90) 0.5 else 1, - vjust = if (angle > 0) 0 else if (angle < 0) 1 else 0.5, - ) - } else if (axis_position == "top") { - element_text( - angle = angle, - hjust = if (angle > 0) 0 else if (angle < 0) 1 else 0.5, - vjust = if (abs(angle) == 90) 0.5 else 0 - ) - } else if (axis_position == "right") { - element_text( - angle = angle, - hjust = if (abs(angle) == 90) 0.5 else 0, - vjust = if (angle > 0) 1 else if (angle < 0) 0 else 0.5, - ) - } else { - cli::cli_abort(c( - "Unrecognized {.arg axis_position}: {.val {axis_position}}", - "i" = "Use one of {.val top}, {.val bottom}, {.val left} or {.val right}" - )) - } -} - -warn_for_guide_position <- function(guide) { - # This is trying to catch when a user specifies a position perpendicular - # to the direction of the axis (e.g., a "y" axis on "top"). - # The strategy is to check that two or more unique breaks are mapped - # to the same value along the axis. - breaks_are_unique <- !duplicated(guide$key$.value) - if (empty(guide$key) || sum(breaks_are_unique) == 1) { - return() - } - - if (guide$position %in% c("top", "bottom")) { - position_aes <- "x" - } else if(guide$position %in% c("left", "right")) { - position_aes <- "y" - } else { - return() - } - - if (is_unique(guide$key[[position_aes]][breaks_are_unique])) { - cli::cli_warn(c( - "Position guide is perpendicular to the intended axis", - "i" = "Did you mean to specify a different guide {.arg position}?" - )) - } -} diff --git a/R/guides-none.R b/R/guides-none.R deleted file mode 100644 index e27b6e9892..0000000000 --- a/R/guides-none.R +++ /dev/null @@ -1,44 +0,0 @@ - -#' Empty guide -#' -#' This guide draws nothing. -#' -#' @inheritParams guide_axis -#' -#' @export -#' -guide_none <- function(title = waiver(), position = waiver()) { - structure( - list( - title = title, - position = position, - available_aes = "any" - ), - class = c("guide", "guide_none") - ) -} - -#' @export -guide_train.guide_none <- function(guide, scale, aesthetic = NULL) { - guide -} - -#' @export -guide_merge.guide_none <- function(guide, new_guide) { - new_guide -} - -#' @export -guide_geom.guide_none <- function(guide, layers, default_mapping) { - guide -} - -#' @export -guide_transform.guide_none <- function(guide, coord, panel_params) { - guide -} - -#' @export -guide_gengrob.guide_none <- function(guide, theme, ...) { - zeroGrob() -} diff --git a/R/layout.R b/R/layout.R index 78fa9c19cd..56841b647b 100644 --- a/R/layout.R +++ b/R/layout.R @@ -106,8 +106,8 @@ Layout <- ggproto("Layout", NULL, # Draw individual labels, then add to gtable labels <- self$coord$labels( list( - x = self$xlabel(labels), - y = self$ylabel(labels) + x = self$resolve_label(self$panel_scales_x[[1]], labels), + y = self$resolve_label(self$panel_scales_y[[1]], labels) ), self$panel_params[[1]] ) @@ -212,7 +212,7 @@ Layout <- ggproto("Layout", NULL, invisible() }, - setup_panel_guides = function(self, guides, layers, default_mapping) { + setup_panel_guides = function(self, guides, layers) { self$panel_params <- lapply( self$panel_params, self$coord$setup_panel_guides, @@ -224,37 +224,41 @@ Layout <- ggproto("Layout", NULL, self$panel_params, self$coord$train_panel_guides, layers, - default_mapping, self$coord_params ) invisible() }, - xlabel = function(self, labels) { - primary <- self$panel_scales_x[[1]]$name %|W|% labels$x - primary <- self$panel_scales_x[[1]]$make_title(primary) - secondary <- if (is.null(self$panel_scales_x[[1]]$secondary.axis)) { + resolve_label = function(self, scale, labels) { + # General order is: guide title > scale name > labels + aes <- scale$aesthetics[[1]] + primary <- scale$name %|W|% labels[[aes]] + secondary <- if (is.null(scale$secondary.axis)) { waiver() } else { - self$panel_scales_x[[1]]$sec_name() - } %|W|% labels$sec.x + scale$sec_name() + } %|W|% labels[[paste0("sec.", aes)]] if (is.derived(secondary)) secondary <- primary - secondary <- self$panel_scales_x[[1]]$make_sec_title(secondary) - list(primary = primary, secondary = secondary)[self$panel_scales_x[[1]]$axis_order()] - }, + order <- scale$axis_order() - ylabel = function(self, labels) { - primary <- self$panel_scales_y[[1]]$name %|W|% labels$y - primary <- self$panel_scales_y[[1]]$make_title(primary) - secondary <- if (is.null(self$panel_scales_y[[1]]$secondary.axis)) { - waiver() - } else { - self$panel_scales_y[[1]]$sec_name() - } %|W|% labels$sec.y - if (is.derived(secondary)) secondary <- primary - secondary <- self$panel_scales_y[[1]]$make_sec_title(secondary) - list(primary = primary, secondary = secondary)[self$panel_scales_y[[1]]$axis_order()] + if (!is.null(self$panel_params[[1]]$guides)) { + if ((scale$position) %in% c("left", "right")) { + guides <- c("y", "y.sec") + } else { + guides <- c("x", "x.sec") + } + params <- self$panel_params[[1]]$guides$get_params(guides) + primary <- params[[1]]$title %|W|% primary + secondary <- params[[2]]$title %|W|% secondary + position <- params[[1]]$position %||% scale$position + if (position != scale$position) { + order <- rev(order) + } + } + primary <- scale$make_title(primary) + secondary <- scale$make_sec_title(secondary) + list(primary = primary, secondary = secondary)[order] }, render_labels = function(self, labels, theme) { diff --git a/R/plot-build.R b/R/plot-build.R index 5aca9e4a82..08f3d385fe 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -167,7 +167,8 @@ ggplot_gtable.ggplot_built <- function(data) { theme <- plot_theme(plot) geom_grobs <- by_layer(function(l, d) l$draw_geom(d, layout), plot$layers, data, "converting geom to grob") - layout$setup_panel_guides(plot$guides, plot$layers, plot$mapping) + + layout$setup_panel_guides(plot$guides, plot$layers) plot_table <- layout$render(geom_grobs, data, theme, plot$labels) # Legends @@ -176,11 +177,9 @@ ggplot_gtable.ggplot_built <- function(data) { position <- "manual" } - legend_box <- if (position != "none") { - build_guides(plot$scales, plot$layers, plot$mapping, position, theme, plot$guides, plot$labels) - } else { - zeroGrob() - } + legend_box <- plot$guides$build( + plot$scales, plot$layers, plot$mapping, position, theme, plot$labels + ) if (is.zero(legend_box)) { position <- "none" diff --git a/R/plot-construction.R b/R/plot-construction.R index 34eddd3a1d..c4cafd2dc8 100644 --- a/R/plot-construction.R +++ b/R/plot-construction.R @@ -125,7 +125,7 @@ ggplot_add.labels <- function(object, plot, object_name) { update_labels(plot, object) } #' @export -ggplot_add.guides <- function(object, plot, object_name) { +ggplot_add.Guides <- function(object, plot, object_name) { update_guides(plot, object) } #' @export diff --git a/R/plot.R b/R/plot.R index aef8b8f30f..4494b774bc 100644 --- a/R/plot.R +++ b/R/plot.R @@ -122,6 +122,7 @@ ggplot.default <- function(data = NULL, mapping = aes(), ..., data = data, layers = list(), scales = scales_list(), + guides = guides_list(), mapping = mapping, theme = list(), coordinates = coord_cartesian(default = TRUE), diff --git a/R/scale-view.R b/R/scale-view.R index 0530df5c3a..7f96700416 100644 --- a/R/scale-view.R +++ b/R/scale-view.R @@ -136,7 +136,7 @@ ViewScale <- ggproto("ViewScale", NULL, if (self$is_discrete()) { self$scale$map(x, self$limits) } else { - self$scale$map(x, self$continuous_range) + x } }, make_title = function(self, title) { diff --git a/man/ggplot2-ggproto.Rd b/man/ggplot2-ggproto.Rd index 0c14e8983d..0e320e5c46 100644 --- a/man/ggplot2-ggproto.Rd +++ b/man/ggplot2-ggproto.Rd @@ -4,15 +4,17 @@ % R/geom-raster.R, R/annotation-raster.R, R/axis-secondary.R, R/coord-.R, % R/coord-cartesian-.R, R/coord-fixed.R, R/coord-flip.R, R/coord-map.R, % R/coord-polar.R, R/coord-quickmap.R, R/coord-transform.R, R/facet-.R, -% R/facet-grid-.R, R/facet-null.R, R/facet-wrap.R, R/stat-.R, R/geom-abline.R, -% R/geom-rect.R, R/geom-bar.R, R/geom-blank.R, R/geom-boxplot.R, R/geom-col.R, -% R/geom-path.R, R/geom-contour.R, R/geom-crossbar.R, R/geom-segment.R, -% R/geom-curve.R, R/geom-ribbon.R, R/geom-density.R, R/geom-density2d.R, -% R/geom-dotplot.R, R/geom-errorbar.R, R/geom-errorbarh.R, R/geom-function.R, -% R/geom-hex.R, R/geom-hline.R, R/geom-label.R, R/geom-linerange.R, -% R/geom-point.R, R/geom-pointrange.R, R/geom-quantile.R, R/geom-rug.R, -% R/geom-smooth.R, R/geom-spoke.R, R/geom-text.R, R/geom-tile.R, -% R/geom-violin.R, R/geom-vline.R, R/layout.R, R/position-.R, +% R/facet-grid-.R, R/facet-null.R, R/facet-wrap.R, R/stat-.R, +% R/geom-abline.R, R/geom-rect.R, R/geom-bar.R, R/geom-blank.R, +% R/geom-boxplot.R, R/geom-col.R, R/geom-path.R, R/geom-contour.R, +% R/geom-crossbar.R, R/geom-segment.R, R/geom-curve.R, R/geom-ribbon.R, +% R/geom-density.R, R/geom-density2d.R, R/geom-dotplot.R, R/geom-errorbar.R, +% R/geom-errorbarh.R, R/geom-function.R, R/geom-hex.R, R/geom-hline.R, +% R/geom-label.R, R/geom-linerange.R, R/geom-point.R, R/geom-pointrange.R, +% R/geom-quantile.R, R/geom-rug.R, R/geom-smooth.R, R/geom-spoke.R, +% R/geom-text.R, R/geom-tile.R, R/geom-violin.R, R/geom-vline.R, R/guide-.R, +% R/guide-axis.R, R/guide-legend.R, R/guide-bins.R, R/guide-colorbar.R, +% R/guide-colorsteps.R, R/guide-none.R, R/layout.R, R/position-.R, % R/position-dodge.R, R/position-dodge2.R, R/position-identity.R, % R/position-jitter.R, R/position-jitterdodge.R, R/position-nudge.R, % R/position-stack.R, R/scale-.R, R/scale-binned.R, R/scale-continuous.R, @@ -85,6 +87,13 @@ \alias{GeomTile} \alias{GeomViolin} \alias{GeomVline} +\alias{Guide} +\alias{GuideAxis} +\alias{GuideLegend} +\alias{GuideBins} +\alias{GuideColourbar} +\alias{GuideColoursteps} +\alias{GuideNone} \alias{Layout} \alias{Position} \alias{PositionDodge} @@ -361,6 +370,22 @@ default values for aesthetics. } } +\section{Guides}{ + + +The \verb{guide_*()} functions, such as \code{guide_legend()} return an object that +is responsible for displaying how objects in the plotting panel are related +to actual values. + +Each of the \verb{Guide*} object is a \code{\link[=ggproto]{ggproto()}} object, descended from the +top-level \code{Guide}, and each implements their own methods for drawing. + +To create a new type of Guide object, you typically will want to override +one or more of the following: + +TODO: Fill this in properly +} + \section{Positions}{ diff --git a/man/guide-exts.Rd b/man/guide-exts.Rd deleted file mode 100644 index d819f96bed..0000000000 --- a/man/guide-exts.Rd +++ /dev/null @@ -1,30 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/guides-.R -\name{guide-exts} -\alias{guide-exts} -\alias{guide_train} -\alias{guide_merge} -\alias{guide_geom} -\alias{guide_transform} -\alias{guide_gengrob} -\title{S3 generics for guides.} -\usage{ -guide_train(guide, scale, aesthetic = NULL) - -guide_merge(guide, new_guide) - -guide_geom(guide, layers, default_mapping) - -guide_transform(guide, coord, panel_params) - -guide_gengrob(guide, theme) -} -\arguments{ -\item{guide}{The guide object} -} -\description{ -You will need to provide methods for these S3 generics if you want to -create your own guide object. They are currently undocumented; use at -your own risk! -} -\keyword{internal} diff --git a/man/guide_axis.Rd b/man/guide_axis.Rd index 84d3df1274..34c358c671 100644 --- a/man/guide_axis.Rd +++ b/man/guide_axis.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/guides-axis.R +% Please edit documentation in R/guide-axis.R \name{guide_axis} \alias{guide_axis} \title{Axis guide} @@ -30,8 +30,10 @@ you probably want.} horizontal axes) that should be used to render the labels. This is useful for displaying labels that would otherwise overlap.} -\item{order}{Used to determine the order of the guides (left-to-right, -top-to-bottom), if more than one guide must be drawn at the same location.} +\item{order}{A positive \code{integer} of length 1 that specifies the order of +this guide among multiple guides. This controls in which order guides are +merged if there are multiple guides for the same position. If 0 (default), +the order is determined by a secret algorithm.} \item{position}{Where this guide should be drawn: one of top, bottom, left, or right.} @@ -54,6 +56,4 @@ p + guides(x = guide_axis(angle = 90)) # can also be used to add a duplicate guide p + guides(x = guide_axis(n.dodge = 2), y.sec = guide_axis()) - - } diff --git a/man/guide_bins.Rd b/man/guide_bins.Rd index 80746cad25..6eeada9598 100644 --- a/man/guide_bins.Rd +++ b/man/guide_bins.Rd @@ -19,8 +19,10 @@ guide_bins( keyheight = NULL, axis = TRUE, axis.colour = "black", - axis.linewidth = 0.5, + axis.linewidth = NULL, axis.arrow = NULL, + ticks = NULL, + ticks.length = unit(0.2, "npc"), direction = NULL, default.unit = "line", override.aes = list(), @@ -76,7 +78,11 @@ the width of the legend key. Default value is \code{legend.key.width} or the height of the legend key. Default value is \code{legend.key.height} or \code{legend.key.size} in \code{\link[=theme]{theme()}}.} -\item{axis}{Logical. Should a small axis be drawn along the guide} +\item{axis}{A theme object for rendering a small axis along the guide. +Usually, the object of \code{element_line()} is expected (default). If +\code{element_blank()}, no axis is drawn. For backward compatibility, can also +be a logical which translates \code{TRUE} to \code{element_line()} and \code{FALSE} to +\code{element_blank()}.} \item{axis.colour, axis.linewidth}{Graphic specifications for the look of the axis.} @@ -84,6 +90,14 @@ axis.} \item{axis.arrow}{A call to \code{arrow()} to specify arrows at the end of the axis line, thus showing an open interval.} +\item{ticks}{A theme object for rendering tick marks at the colourbar. +Usually, the object of \code{element_line()} is expected. If \code{element_blank()}, +no tick marks are drawn. If \code{NULL} (default), the \code{axis} argument is +re-used as \code{ticks} argument (without arrow).} + +\item{ticks.length}{A numeric or a \code{\link[grid:unit]{grid::unit()}} object specifying the +length of tick marks between the keys.} + \item{direction}{A character string indicating the direction of the guide. One of "horizontal" or "vertical."} diff --git a/man/guide_colourbar.Rd b/man/guide_colourbar.Rd index d887446b26..7813c12b1c 100644 --- a/man/guide_colourbar.Rd +++ b/man/guide_colourbar.Rd @@ -20,12 +20,14 @@ guide_colourbar( barheight = NULL, nbin = 300, raster = TRUE, + frame = element_blank(), frame.colour = NULL, - frame.linewidth = 0.5/.pt, - frame.linetype = 1, - ticks = TRUE, - ticks.colour = "white", - ticks.linewidth = 0.5/.pt, + frame.linewidth = NULL, + frame.linetype = NULL, + ticks = element_line(), + ticks.colour = NULL, + ticks.linewidth = NULL, + ticks.length = unit(0.2, "npc"), draw.ulim = TRUE, draw.llim = TRUE, direction = NULL, @@ -51,12 +53,14 @@ guide_colorbar( barheight = NULL, nbin = 300, raster = TRUE, + frame = element_blank(), frame.colour = NULL, - frame.linewidth = 0.5/.pt, - frame.linetype = 1, - ticks = TRUE, - ticks.colour = "white", - ticks.linewidth = 0.5/.pt, + frame.linewidth = NULL, + frame.linetype = NULL, + ticks = element_line(), + ticks.colour = NULL, + ticks.linewidth = NULL, + ticks.length = unit(0.2, "npc"), draw.ulim = TRUE, draw.llim = TRUE, direction = NULL, @@ -121,8 +125,13 @@ raster object. If \code{FALSE} then the colourbar is rendered as a set of rectangles. Note that not all graphics devices are capable of rendering raster image.} +\item{frame}{A theme object for rendering a frame drawn around the bar. +Usually, the object of \code{element_rect()} is expected. If \code{element_blank()} +(default), no frame is drawn.} + \item{frame.colour}{A string specifying the colour of the frame -drawn around the bar. If \code{NULL} (the default), no frame is drawn.} +drawn around the bar. For backward compatibility, if this argument is +not \code{NULL}, the \code{frame} argument will be set to \code{element_rect()}.} \item{frame.linewidth}{A numeric specifying the width of the frame drawn around the bar in millimetres.} @@ -130,14 +139,20 @@ drawn around the bar in millimetres.} \item{frame.linetype}{A numeric specifying the linetype of the frame drawn around the bar.} -\item{ticks}{A logical specifying if tick marks on the colourbar should be -visible.} +\item{ticks}{A theme object for rendering tick marks at the colourbar. +Usually, the object of \code{element_line()} is expected (default). If +\code{element_blank()}, no tick marks are drawn. For backward compatibility, +can also be a logical which translates \code{TRUE} to \code{element_line()} and +\code{FALSE} to \code{element_blank()}.} \item{ticks.colour}{A string specifying the colour of the tick marks.} \item{ticks.linewidth}{A numeric specifying the width of the tick marks in millimetres.} +\item{ticks.length}{A numeric or a \code{\link[grid:unit]{grid::unit()}} object specifying the +length of tick marks at the colourbar.} + \item{draw.ulim}{A logical specifying if the upper limit tick marks should be visible.} diff --git a/man/guide_coloursteps.Rd b/man/guide_coloursteps.Rd index 55f9c895ae..38771cb472 100644 --- a/man/guide_coloursteps.Rd +++ b/man/guide_coloursteps.Rd @@ -5,9 +5,19 @@ \alias{guide_colorsteps} \title{Discretized colourbar guide} \usage{ -guide_coloursteps(even.steps = TRUE, show.limits = NULL, ticks = FALSE, ...) +guide_coloursteps( + even.steps = TRUE, + show.limits = NULL, + ticks = element_blank(), + ... +) -guide_colorsteps(even.steps = TRUE, show.limits = NULL, ticks = FALSE, ...) +guide_colorsteps( + even.steps = TRUE, + show.limits = NULL, + ticks = element_blank(), + ... +) } \arguments{ \item{even.steps}{Should the rendered size of the bins be equal, or should @@ -19,8 +29,11 @@ scale. This argument is ignored if \code{labels} is given as a vector of values. If one or both of the limits is also given in \code{breaks} it will be shown irrespective of the value of \code{show.limits}.} -\item{ticks}{A logical specifying if tick marks on the colourbar should be -visible.} +\item{ticks}{A theme object for rendering tick marks at the colourbar. +Usually, the object of \code{element_line()} is expected. If \code{element_blank()} +(default), no tick marks are drawn. For backward compatability, can also +be a logical which translates \code{TRUE} to \code{element_line()} and \code{FALSE} to +\code{element_blank()}.} \item{...}{ Arguments passed on to \code{\link[=guide_colourbar]{guide_colourbar}} @@ -31,8 +44,12 @@ the width of the colourbar. Default value is \code{legend.key.width} or \item{\code{barheight}}{A numeric or a \code{\link[grid:unit]{grid::unit()}} object specifying the height of the colourbar. Default value is \code{legend.key.height} or \code{legend.key.size} in \code{\link[=theme]{theme()}} or theme.} + \item{\code{frame}}{A theme object for rendering a frame drawn around the bar. +Usually, the object of \code{element_rect()} is expected. If \code{element_blank()} +(default), no frame is drawn.} \item{\code{frame.colour}}{A string specifying the colour of the frame -drawn around the bar. If \code{NULL} (the default), no frame is drawn.} +drawn around the bar. For backward compatibility, if this argument is +not \code{NULL}, the \code{frame} argument will be set to \code{element_rect()}.} \item{\code{frame.linewidth}}{A numeric specifying the width of the frame drawn around the bar in millimetres.} \item{\code{frame.linetype}}{A numeric specifying the linetype of the frame @@ -40,6 +57,8 @@ drawn around the bar.} \item{\code{ticks.colour}}{A string specifying the colour of the tick marks.} \item{\code{ticks.linewidth}}{A numeric specifying the width of the tick marks in millimetres.} + \item{\code{ticks.length}}{A numeric or a \code{\link[grid:unit]{grid::unit()}} object specifying the +length of tick marks at the colourbar.} \item{\code{draw.ulim}}{A logical specifying if the upper limit tick marks should be visible.} \item{\code{draw.llim}}{A logical specifying if the lower limit tick marks should @@ -129,7 +148,6 @@ p + scale_fill_binned(guide = guide_coloursteps(show.limits = TRUE)) # (can also be set in the scale) p + scale_fill_binned(show.limits = TRUE) - } \seealso{ Other guides: diff --git a/man/guide_none.Rd b/man/guide_none.Rd index a9007a867b..f77d9e8bf2 100644 --- a/man/guide_none.Rd +++ b/man/guide_none.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/guides-none.R +% Please edit documentation in R/guide-none.R \name{guide_none} \alias{guide_none} \title{Empty guide} diff --git a/man/new_guide.Rd b/man/new_guide.Rd new file mode 100644 index 0000000000..a533908f62 --- /dev/null +++ b/man/new_guide.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/guide-.R +\name{new_guide} +\alias{new_guide} +\title{Guide constructor} +\usage{ +new_guide(..., available_aes = "any", super) +} +\arguments{ +\item{...}{Named arguments that match the parameters of \code{super$params} or +the theme elements in \code{super$elements}.} + +\item{available_aes}{A vector of character strings listing the aesthetics +for which the guide can be drawn.} + +\item{super}{The super class to use for the constructed guide. Should be a +Guide class object.} +} +\value{ +A \code{Guide} ggproto object. +} +\description{ +A constructor function for guides, which performs some standard compatability +checks between the guide and provided arguments. +} +\keyword{internal} diff --git a/tests/testthat/_snaps/coord-flip/turning-off-secondary-title-with-coord-flip.svg b/tests/testthat/_snaps/coord-flip/turning-off-secondary-title-with-coord-flip.svg index a67dbd8469..ffb66ff639 100644 --- a/tests/testthat/_snaps/coord-flip/turning-off-secondary-title-with-coord-flip.svg +++ b/tests/testthat/_snaps/coord-flip/turning-off-secondary-title-with-coord-flip.svg @@ -74,12 +74,12 @@ - - - - - - + + + + + + 10 15 20 diff --git a/tests/testthat/_snaps/coord-map/coord-map-switched-scale-position.svg b/tests/testthat/_snaps/coord-map/coord-map-switched-scale-position.svg index 3d5fa0b240..7a7cf9889c 100644 --- a/tests/testthat/_snaps/coord-map/coord-map-switched-scale-position.svg +++ b/tests/testthat/_snaps/coord-map/coord-map-switched-scale-position.svg @@ -49,18 +49,18 @@ + + + -120 -100 -80 - - - - - - - - - + + + + + + 25 30 35 diff --git a/tests/testthat/_snaps/coord-polar/secondary-axis-ticks-and-labels.svg b/tests/testthat/_snaps/coord-polar/secondary-axis-ticks-and-labels.svg index abfad410e5..3e0228e8dc 100644 --- a/tests/testthat/_snaps/coord-polar/secondary-axis-ticks-and-labels.svg +++ b/tests/testthat/_snaps/coord-polar/secondary-axis-ticks-and-labels.svg @@ -49,11 +49,11 @@ - - - - - + + + + + 0.10 0.15 0.20 diff --git a/tests/testthat/_snaps/coord-transform/sec-axis-with-coord-trans.svg b/tests/testthat/_snaps/coord-transform/sec-axis-with-coord-trans.svg index 01f5766194..ec428f81e0 100644 --- a/tests/testthat/_snaps/coord-transform/sec-axis-with-coord-trans.svg +++ b/tests/testthat/_snaps/coord-transform/sec-axis-with-coord-trans.svg @@ -264,18 +264,18 @@ + + + + + + 10 15 20 25 30 35 - - - - - - 11.31371 16.00000 22.62742 @@ -286,11 +286,11 @@ - - - - - + + + + + 3.5 4.0 4.5 diff --git a/tests/testthat/_snaps/geom-hex/hex-bin-plot-in-polar-coordinates.svg b/tests/testthat/_snaps/geom-hex/hex-bin-plot-in-polar-coordinates.svg index 3ce3eb7f00..a1d64e9da4 100644 --- a/tests/testthat/_snaps/geom-hex/hex-bin-plot-in-polar-coordinates.svg +++ b/tests/testthat/_snaps/geom-hex/hex-bin-plot-in-polar-coordinates.svg @@ -164,20 +164,20 @@ displ hwy +count + + + + + + + + 2.5 5.0 7.5 10.0 -count - - - - - - - - hex bin plot in polar coordinates diff --git a/tests/testthat/_snaps/geom-hex/hex-bin-plot-with-sqrt-transformed-y.svg b/tests/testthat/_snaps/geom-hex/hex-bin-plot-with-sqrt-transformed-y.svg index 193b3500c3..bb7623336a 100644 --- a/tests/testthat/_snaps/geom-hex/hex-bin-plot-with-sqrt-transformed-y.svg +++ b/tests/testthat/_snaps/geom-hex/hex-bin-plot-with-sqrt-transformed-y.svg @@ -162,20 +162,20 @@ displ hwy +count + + + + + + + + 2.5 5.0 7.5 10.0 -count - - - - - - - - hex bin plot with sqrt-transformed y diff --git a/tests/testthat/_snaps/geom-hex/single-hex-bin-with-width-and-height-of-0-1.svg b/tests/testthat/_snaps/geom-hex/single-hex-bin-with-width-and-height-of-0-1.svg index 6c27c29626..0e624b23b8 100644 --- a/tests/testthat/_snaps/geom-hex/single-hex-bin-with-width-and-height-of-0-1.svg +++ b/tests/testthat/_snaps/geom-hex/single-hex-bin-with-width-and-height-of-0-1.svg @@ -54,11 +54,11 @@ x y +count + + 1 -count - - single hex bin with width and height of 0.1 diff --git a/tests/testthat/_snaps/geom-raster/1-x-3-just-0-0.svg b/tests/testthat/_snaps/geom-raster/1-x-3-just-0-0.svg index ce0763cff1..d6925d5277 100644 --- a/tests/testthat/_snaps/geom-raster/1-x-3-just-0-0.svg +++ b/tests/testthat/_snaps/geom-raster/1-x-3-just-0-0.svg @@ -55,23 +55,23 @@ x y +z + + + + + + + + + + 1.0 1.5 2.0 2.5 3.0 -z - - - - - - - - - - 1 x 3, just = (0, 0) diff --git a/tests/testthat/_snaps/geom-raster/1-x-3-set-limits.svg b/tests/testthat/_snaps/geom-raster/1-x-3-set-limits.svg index 8d30468d6d..0d7aa1e7e9 100644 --- a/tests/testthat/_snaps/geom-raster/1-x-3-set-limits.svg +++ b/tests/testthat/_snaps/geom-raster/1-x-3-set-limits.svg @@ -57,23 +57,23 @@ x y +z + + + + + + + + + + 1.0 1.5 2.0 2.5 3.0 -z - - - - - - - - - - 1 x 3, set limits diff --git a/tests/testthat/_snaps/geom-raster/1-x-3.svg b/tests/testthat/_snaps/geom-raster/1-x-3.svg index cb1b36f7a1..f5cf7f593a 100644 --- a/tests/testthat/_snaps/geom-raster/1-x-3.svg +++ b/tests/testthat/_snaps/geom-raster/1-x-3.svg @@ -53,23 +53,23 @@ x y +z + + + + + + + + + + 1.0 1.5 2.0 2.5 3.0 -z - - - - - - - - - - 1 x 3 diff --git a/tests/testthat/_snaps/geom-raster/3-x-1-just-0-0.svg b/tests/testthat/_snaps/geom-raster/3-x-1-just-0-0.svg index 28f62d9499..090bf3e379 100644 --- a/tests/testthat/_snaps/geom-raster/3-x-1-just-0-0.svg +++ b/tests/testthat/_snaps/geom-raster/3-x-1-just-0-0.svg @@ -55,23 +55,23 @@ x y +z + + + + + + + + + + 1.0 1.5 2.0 2.5 3.0 -z - - - - - - - - - - 3 x 1, just = (0, 0) diff --git a/tests/testthat/_snaps/geom-raster/3-x-1-set-limits.svg b/tests/testthat/_snaps/geom-raster/3-x-1-set-limits.svg index 8f0ea47377..f1493847f4 100644 --- a/tests/testthat/_snaps/geom-raster/3-x-1-set-limits.svg +++ b/tests/testthat/_snaps/geom-raster/3-x-1-set-limits.svg @@ -57,23 +57,23 @@ x y +z + + + + + + + + + + 1.0 1.5 2.0 2.5 3.0 -z - - - - - - - - - - 3 x 1, set limits diff --git a/tests/testthat/_snaps/geom-raster/3-x-1.svg b/tests/testthat/_snaps/geom-raster/3-x-1.svg index bc44868920..81c8824ccb 100644 --- a/tests/testthat/_snaps/geom-raster/3-x-1.svg +++ b/tests/testthat/_snaps/geom-raster/3-x-1.svg @@ -53,23 +53,23 @@ x y +z + + + + + + + + + + 1.0 1.5 2.0 2.5 3.0 -z - - - - - - - - - - 3 x 1 diff --git a/tests/testthat/_snaps/geom-raster/3-x-2-just-0-0.svg b/tests/testthat/_snaps/geom-raster/3-x-2-just-0-0.svg index 10dc0076d0..9c47db029b 100644 --- a/tests/testthat/_snaps/geom-raster/3-x-2-just-0-0.svg +++ b/tests/testthat/_snaps/geom-raster/3-x-2-just-0-0.svg @@ -58,26 +58,26 @@ x y +z + + + + + + + + + + + + 1 2 3 4 5 6 -z - - - - - - - - - - - - 3 x 2, just = (0, 0) diff --git a/tests/testthat/_snaps/geom-raster/3-x-2-set-limits.svg b/tests/testthat/_snaps/geom-raster/3-x-2-set-limits.svg index 049016291e..87dbec7788 100644 --- a/tests/testthat/_snaps/geom-raster/3-x-2-set-limits.svg +++ b/tests/testthat/_snaps/geom-raster/3-x-2-set-limits.svg @@ -60,26 +60,26 @@ x y +z + + + + + + + + + + + + 1 2 3 4 5 6 -z - - - - - - - - - - - - 3 x 2, set limits diff --git a/tests/testthat/_snaps/geom-raster/3-x-2.svg b/tests/testthat/_snaps/geom-raster/3-x-2.svg index a2a9405c1f..3662119bd7 100644 --- a/tests/testthat/_snaps/geom-raster/3-x-2.svg +++ b/tests/testthat/_snaps/geom-raster/3-x-2.svg @@ -56,26 +56,26 @@ x y +z + + + + + + + + + + + + 1 2 3 4 5 6 -z - - - - - - - - - - - - 3 x 2 diff --git a/tests/testthat/_snaps/guides.md b/tests/testthat/_snaps/guides.md index d822f537fc..f088f31f7d 100644 --- a/tests/testthat/_snaps/guides.md +++ b/tests/testthat/_snaps/guides.md @@ -13,12 +13,12 @@ # Using non-position guides for position scales results in an informative error - Guide with class does not implement `guide_transform()` - i Did you mean to use `guide_axis()`? + `guide_legend()` cannot be used for x, xmin, xmax, or xend. + i Use any non position aesthetic instead. # guide specifications are properly checked - object 'guide_test' of mode 'function' was not found + Unknown guide: test --- @@ -26,31 +26,30 @@ --- - Guide `colorbar` cannot be used for shape. + `guide_colourbar()` cannot be used for shape. + i Use one of colour, color, or fill instead. --- - Title position "leftish" is invalid - i Use one of "top", "bottom", "left", or "right" + `title.position` must be one of "top", "right", "bottom", or "left", not "leftish". --- - Guide with class does not implement `guide_transform()` + `guide_colourbar()` does not implement a `transform()` method. i Did you mean to use `guide_axis()`? --- - label position "top" is invalid - i use either "'left'" or "'right'" + When `direction` is "vertical", `label.position` must be one of "right" or "left", not "top". --- - label position "left" is invalid - i use either "'top'" or "'bottom'" + When `direction` is "horizontal", `label.position` must be one of "bottom" or "top", not "left". --- - label position `test` is invalid + `label.position` must be one of "top", "right", "bottom", or "left", not "test". + i Did you mean "left"? --- @@ -58,23 +57,23 @@ # colorsteps and bins checks the breaks format - Breaks not formatted correctly for a bin legend. - i Use `(, ]` format to indicate bins + Breaks are not formatted correctly for a bin legend. + i Use `(, ]` format to indicate bins. --- - Breaks not formatted correctly for a bin legend. - i Use `(, ]` format to indicate bins + Breaks are not formatted correctly for a bin legend. + i Use `(, ]` format to indicate bins. # binning scales understand the different combinations of limits, breaks, labels, and show.limits - `show.limits` is ignored when `labels` are given as a character vector - i Either add the limits to `breaks` or provide a function for `labels` + `show.limits` is ignored when `labels` are given as a character vector. + i Either add the limits to `breaks` or provide a function for `labels`. --- - `show.limits` is ignored when `labels` are given as a character vector - i Either add the limits to `breaks` or provide a function for `labels` + `show.limits` is ignored when `labels` are given as a character vector. + i Either add the limits to `breaks` or provide a function for `labels`. # a warning is generated when guides( = FALSE) is specified diff --git a/tests/testthat/_snaps/guides/axis-guides-basic.svg b/tests/testthat/_snaps/guides/axis-guides-basic.svg index fd0aa28b32..ae2a74c24d 100644 --- a/tests/testthat/_snaps/guides/axis-guides-basic.svg +++ b/tests/testthat/_snaps/guides/axis-guides-basic.svg @@ -60,16 +60,16 @@ + + + 1 2 3 - - - - - - + + + 1 2 3 diff --git a/tests/testthat/_snaps/guides/axis-guides-check-overlap.svg b/tests/testthat/_snaps/guides/axis-guides-check-overlap.svg index ca5e199e8e..cf2312f98c 100644 --- a/tests/testthat/_snaps/guides/axis-guides-check-overlap.svg +++ b/tests/testthat/_snaps/guides/axis-guides-check-overlap.svg @@ -60,6 +60,26 @@ + + + + + + + + + + + + + + + + + + + + 1,000,000,000 20,000,000,000 10,000,000,000 @@ -69,47 +89,27 @@ 15,000,000,000 12,000,000,000 17,000,000,000 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + 1,000,000,000 20,000,000,000 10,000,000,000 diff --git a/tests/testthat/_snaps/guides/axis-guides-negative-rotation.svg b/tests/testthat/_snaps/guides/axis-guides-negative-rotation.svg index f4999ff374..8902fa04cd 100644 --- a/tests/testthat/_snaps/guides/axis-guides-negative-rotation.svg +++ b/tests/testthat/_snaps/guides/axis-guides-negative-rotation.svg @@ -60,6 +60,16 @@ + + + + + + + + + + 1,000 2,000 3,000 @@ -70,27 +80,17 @@ 8,000 9,000 10,000 - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + 1,000 2,000 3,000 diff --git a/tests/testthat/_snaps/guides/axis-guides-positive-rotation.svg b/tests/testthat/_snaps/guides/axis-guides-positive-rotation.svg index cd88e34aeb..e1cd91eb77 100644 --- a/tests/testthat/_snaps/guides/axis-guides-positive-rotation.svg +++ b/tests/testthat/_snaps/guides/axis-guides-positive-rotation.svg @@ -60,6 +60,16 @@ + + + + + + + + + + 1,000 2,000 3,000 @@ -70,27 +80,17 @@ 8,000 9,000 10,000 - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + 1,000 2,000 3,000 diff --git a/tests/testthat/_snaps/guides/axis-guides-text-dodged-into-rows-cols.svg b/tests/testthat/_snaps/guides/axis-guides-text-dodged-into-rows-cols.svg index 404aaa6f45..79e94af549 100644 --- a/tests/testthat/_snaps/guides/axis-guides-text-dodged-into-rows-cols.svg +++ b/tests/testthat/_snaps/guides/axis-guides-text-dodged-into-rows-cols.svg @@ -60,37 +60,37 @@ -2,000,000,000 -4,000,000,000 -6,000,000,000 -8,000,000,000 -10,000,000,000 + + + + + + + + + + 1,000,000,000 3,000,000,000 5,000,000,000 7,000,000,000 9,000,000,000 - - - - - - - - - - +2,000,000,000 +4,000,000,000 +6,000,000,000 +8,000,000,000 +10,000,000,000 - - - - - - - - - - + + + + + + + + + + 1,000,000,000 3,000,000,000 5,000,000,000 @@ -123,16 +123,16 @@ 8,000,000,000 10,000,000,000 -2,000,000,000 -4,000,000,000 -6,000,000,000 -8,000,000,000 -10,000,000,000 1,000,000,000 3,000,000,000 5,000,000,000 7,000,000,000 9,000,000,000 +2,000,000,000 +4,000,000,000 +6,000,000,000 +8,000,000,000 +10,000,000,000 diff --git a/tests/testthat/_snaps/guides/axis-guides-vertical-negative-rotation.svg b/tests/testthat/_snaps/guides/axis-guides-vertical-negative-rotation.svg index 7a90c21e3c..1d83ebc1e2 100644 --- a/tests/testthat/_snaps/guides/axis-guides-vertical-negative-rotation.svg +++ b/tests/testthat/_snaps/guides/axis-guides-vertical-negative-rotation.svg @@ -60,6 +60,16 @@ + + + + + + + + + + 1,000 2,000 3,000 @@ -70,27 +80,17 @@ 8,000 9,000 10,000 - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + 1,000 2,000 3,000 diff --git a/tests/testthat/_snaps/guides/axis-guides-vertical-rotation.svg b/tests/testthat/_snaps/guides/axis-guides-vertical-rotation.svg index 0f4dbb29fa..f379bb7797 100644 --- a/tests/testthat/_snaps/guides/axis-guides-vertical-rotation.svg +++ b/tests/testthat/_snaps/guides/axis-guides-vertical-rotation.svg @@ -60,6 +60,16 @@ + + + + + + + + + + 1,000 2,000 3,000 @@ -70,27 +80,17 @@ 8,000 9,000 10,000 - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + 1,000 2,000 3,000 diff --git a/tests/testthat/_snaps/guides/axis-guides-zero-rotation.svg b/tests/testthat/_snaps/guides/axis-guides-zero-rotation.svg index ba629bd0f5..bb81af4971 100644 --- a/tests/testthat/_snaps/guides/axis-guides-zero-rotation.svg +++ b/tests/testthat/_snaps/guides/axis-guides-zero-rotation.svg @@ -60,6 +60,16 @@ + + + + + + + + + + 1,000 2,000 3,000 @@ -70,27 +80,17 @@ 8,000 9,000 10,000 - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + 1,000 2,000 3,000 diff --git a/tests/testthat/_snaps/guides/guide-axis-customization.svg b/tests/testthat/_snaps/guides/guide-axis-customization.svg index 3466dbe6d5..0b082ad619 100644 --- a/tests/testthat/_snaps/guides/guide-axis-customization.svg +++ b/tests/testthat/_snaps/guides/guide-axis-customization.svg @@ -264,15 +264,15 @@ -30 20 40 +30 - - - + + + 20 40 30 diff --git a/tests/testthat/_snaps/guides/guide-bins-can-show-arrows.svg b/tests/testthat/_snaps/guides/guide-bins-can-show-arrows.svg index 1d3dca0376..3a553b96cc 100644 --- a/tests/testthat/_snaps/guides/guide-bins-can-show-arrows.svg +++ b/tests/testthat/_snaps/guides/guide-bins-can-show-arrows.svg @@ -65,12 +65,12 @@ - - - - - - + + + + + + 1.5 2.0 2.5 diff --git a/tests/testthat/_snaps/guides/guide-bins-can-show-limits.svg b/tests/testthat/_snaps/guides/guide-bins-can-show-limits.svg index dee77908af..c398df926b 100644 --- a/tests/testthat/_snaps/guides/guide-bins-can-show-limits.svg +++ b/tests/testthat/_snaps/guides/guide-bins-can-show-limits.svg @@ -65,12 +65,12 @@ - - - - - - + + + + + + 1 1.5 2.0 diff --git a/tests/testthat/_snaps/guides/guide-bins-can-show-ticks.svg b/tests/testthat/_snaps/guides/guide-bins-can-show-ticks.svg index af4c9e0caa..18d41ecf3e 100644 --- a/tests/testthat/_snaps/guides/guide-bins-can-show-ticks.svg +++ b/tests/testthat/_snaps/guides/guide-bins-can-show-ticks.svg @@ -54,20 +54,20 @@ x y +x + + + + + + 1.5 2.0 3.0 -x - - - - - - guide_bins can show ticks diff --git a/tests/testthat/_snaps/guides/guide-bins-looks-as-it-should.svg b/tests/testthat/_snaps/guides/guide-bins-looks-as-it-should.svg index 042535c950..39c44206df 100644 --- a/tests/testthat/_snaps/guides/guide-bins-looks-as-it-should.svg +++ b/tests/testthat/_snaps/guides/guide-bins-looks-as-it-should.svg @@ -65,10 +65,10 @@ - - - - + + + + 1.5 2.0 2.5 diff --git a/tests/testthat/_snaps/guides/guide-bins-sets-labels-when-limits-is-in-breaks.svg b/tests/testthat/_snaps/guides/guide-bins-sets-labels-when-limits-is-in-breaks.svg index e2d0a86b9c..b558c84e13 100644 --- a/tests/testthat/_snaps/guides/guide-bins-sets-labels-when-limits-is-in-breaks.svg +++ b/tests/testthat/_snaps/guides/guide-bins-sets-labels-when-limits-is-in-breaks.svg @@ -296,12 +296,12 @@ - - - - - - + + + + + + 1 2 3 diff --git a/tests/testthat/_snaps/guides/guide-bins-understands-coinciding-limits-and-bins-2.svg b/tests/testthat/_snaps/guides/guide-bins-understands-coinciding-limits-and-bins-2.svg index 4630e3449e..644678f65a 100644 --- a/tests/testthat/_snaps/guides/guide-bins-understands-coinciding-limits-and-bins-2.svg +++ b/tests/testthat/_snaps/guides/guide-bins-understands-coinciding-limits-and-bins-2.svg @@ -296,12 +296,12 @@ - - - - - - + + + + + + 2000 2002 2004 diff --git a/tests/testthat/_snaps/guides/guide-bins-understands-coinciding-limits-and-bins-3.svg b/tests/testthat/_snaps/guides/guide-bins-understands-coinciding-limits-and-bins-3.svg index 7b0b6a956f..c0a8fc0cff 100644 --- a/tests/testthat/_snaps/guides/guide-bins-understands-coinciding-limits-and-bins-3.svg +++ b/tests/testthat/_snaps/guides/guide-bins-understands-coinciding-limits-and-bins-3.svg @@ -296,13 +296,13 @@ - - - - - - - + + + + + + + 1999 2000 2002 diff --git a/tests/testthat/_snaps/guides/guide-bins-understands-coinciding-limits-and-bins.svg b/tests/testthat/_snaps/guides/guide-bins-understands-coinciding-limits-and-bins.svg index 82f71991a0..837acb103a 100644 --- a/tests/testthat/_snaps/guides/guide-bins-understands-coinciding-limits-and-bins.svg +++ b/tests/testthat/_snaps/guides/guide-bins-understands-coinciding-limits-and-bins.svg @@ -296,12 +296,12 @@ - - - - - - + + + + + + 1999 2000 2002 diff --git a/tests/testthat/_snaps/guides/guide-bins-work-horizontally.svg b/tests/testthat/_snaps/guides/guide-bins-work-horizontally.svg index 92e45677ae..3bddc3b3cb 100644 --- a/tests/testthat/_snaps/guides/guide-bins-work-horizontally.svg +++ b/tests/testthat/_snaps/guides/guide-bins-work-horizontally.svg @@ -55,23 +55,23 @@ 3.0 x y - + x - - - - - - - - - - - - -1.5 -2.0 -2.5 + + + + + + + + + + + + +1.5 +2.0 +2.5 guide_bins work horizontally diff --git a/tests/testthat/_snaps/guides/guide-colorsteps-sets-labels-when-limits-is-in-breaks.svg b/tests/testthat/_snaps/guides/guide-colorsteps-sets-labels-when-limits-is-in-breaks.svg index b38018f911..9575c4f9f9 100644 --- a/tests/testthat/_snaps/guides/guide-colorsteps-sets-labels-when-limits-is-in-breaks.svg +++ b/tests/testthat/_snaps/guides/guide-colorsteps-sets-labels-when-limits-is-in-breaks.svg @@ -285,6 +285,7 @@ cty hwy +year @@ -295,7 +296,6 @@ 3 4 5 -year guide_colorsteps sets labels when limits is in breaks diff --git a/tests/testthat/_snaps/guides/guide-colorsteps-understands-coinciding-limits-and-bins-2.svg b/tests/testthat/_snaps/guides/guide-colorsteps-understands-coinciding-limits-and-bins-2.svg index 9427333e92..f1855cedf9 100644 --- a/tests/testthat/_snaps/guides/guide-colorsteps-understands-coinciding-limits-and-bins-2.svg +++ b/tests/testthat/_snaps/guides/guide-colorsteps-understands-coinciding-limits-and-bins-2.svg @@ -285,6 +285,7 @@ cty hwy +year @@ -295,7 +296,6 @@ 2004 2006 2008 -year guide_colorsteps understands coinciding limits and bins 2 diff --git a/tests/testthat/_snaps/guides/guide-colorsteps-understands-coinciding-limits-and-bins-3.svg b/tests/testthat/_snaps/guides/guide-colorsteps-understands-coinciding-limits-and-bins-3.svg index 922b4aac29..3682f1b2e0 100644 --- a/tests/testthat/_snaps/guides/guide-colorsteps-understands-coinciding-limits-and-bins-3.svg +++ b/tests/testthat/_snaps/guides/guide-colorsteps-understands-coinciding-limits-and-bins-3.svg @@ -285,6 +285,7 @@ cty hwy +year @@ -296,7 +297,6 @@ 2004 2006 2008 -year guide_colorsteps understands coinciding limits and bins 3 diff --git a/tests/testthat/_snaps/guides/guide-colorsteps-understands-coinciding-limits-and-bins.svg b/tests/testthat/_snaps/guides/guide-colorsteps-understands-coinciding-limits-and-bins.svg index e4e230d71a..61350097bc 100644 --- a/tests/testthat/_snaps/guides/guide-colorsteps-understands-coinciding-limits-and-bins.svg +++ b/tests/testthat/_snaps/guides/guide-colorsteps-understands-coinciding-limits-and-bins.svg @@ -285,6 +285,7 @@ cty hwy +year @@ -295,7 +296,6 @@ 2002 2004 2006 -year guide_colorsteps understands coinciding limits and bins diff --git a/tests/testthat/_snaps/guides/guide-coloursteps-can-have-bins-relative-to-binsize.svg b/tests/testthat/_snaps/guides/guide-coloursteps-can-have-bins-relative-to-binsize.svg index f6ba570bce..ace585daf1 100644 --- a/tests/testthat/_snaps/guides/guide-coloursteps-can-have-bins-relative-to-binsize.svg +++ b/tests/testthat/_snaps/guides/guide-coloursteps-can-have-bins-relative-to-binsize.svg @@ -54,6 +54,7 @@ x y +x @@ -157,7 +158,6 @@ 1.5 2.0 3.0 -x guide_coloursteps can have bins relative to binsize diff --git a/tests/testthat/_snaps/guides/guide-coloursteps-can-show-limits.svg b/tests/testthat/_snaps/guides/guide-coloursteps-can-show-limits.svg index 78c5da475f..3601641e36 100644 --- a/tests/testthat/_snaps/guides/guide-coloursteps-can-show-limits.svg +++ b/tests/testthat/_snaps/guides/guide-coloursteps-can-show-limits.svg @@ -54,6 +54,7 @@ x y +x @@ -63,7 +64,6 @@ 2.0 3.0 4 -x guide_coloursteps can show limits diff --git a/tests/testthat/_snaps/guides/guide-coloursteps-looks-as-it-should.svg b/tests/testthat/_snaps/guides/guide-coloursteps-looks-as-it-should.svg index 06c2992fca..9a28d6ba0f 100644 --- a/tests/testthat/_snaps/guides/guide-coloursteps-looks-as-it-should.svg +++ b/tests/testthat/_snaps/guides/guide-coloursteps-looks-as-it-should.svg @@ -54,6 +54,7 @@ x y +x @@ -61,7 +62,6 @@ 1.5 2.0 3.0 -x guide_coloursteps looks as it should diff --git a/tests/testthat/_snaps/guides/guide-title-and-text-positioning-and-alignment-via-themes.svg b/tests/testthat/_snaps/guides/guide-title-and-text-positioning-and-alignment-via-themes.svg index 40e6580d27..09233a4cf7 100644 --- a/tests/testthat/_snaps/guides/guide-title-and-text-positioning-and-alignment-via-themes.svg +++ b/tests/testthat/_snaps/guides/guide-title-and-text-positioning-and-alignment-via-themes.svg @@ -56,20 +56,20 @@ x x +x + + + + + + + + 25 50 75 100 -x - - - - - - - - x diff --git a/tests/testthat/_snaps/guides/guide-titles-with-coord-trans.svg b/tests/testthat/_snaps/guides/guide-titles-with-coord-trans.svg index 78de62f91c..bfe8ec8a98 100644 --- a/tests/testthat/_snaps/guides/guide-titles-with-coord-trans.svg +++ b/tests/testthat/_snaps/guides/guide-titles-with-coord-trans.svg @@ -31,16 +31,16 @@ + + + + + 0.950 0.975 1.000 1.025 1.050 - - - - - 0.950 0.975 1.000 @@ -51,11 +51,11 @@ - - - - - + + + + + 0.950 0.975 1.000 diff --git a/tests/testthat/_snaps/guides/guides-specified-in-guides.svg b/tests/testthat/_snaps/guides/guides-specified-in-guides.svg index 81d6765c86..abdec7137c 100644 --- a/tests/testthat/_snaps/guides/guides-specified-in-guides.svg +++ b/tests/testthat/_snaps/guides/guides-specified-in-guides.svg @@ -264,29 +264,29 @@ -compact -minivan -subcompact + + + + + + + 2seater midsize pickup suv - - - - - - - -30 +compact +minivan +subcompact 20 40 +30 - - - + + + 20 40 30 diff --git a/tests/testthat/_snaps/guides/horizontal-gap-of-1cm-between-guide-and-guide-text.svg b/tests/testthat/_snaps/guides/horizontal-gap-of-1cm-between-guide-and-guide-text.svg index bde5f6ee07..11b0044813 100644 --- a/tests/testthat/_snaps/guides/horizontal-gap-of-1cm-between-guide-and-guide-text.svg +++ b/tests/testthat/_snaps/guides/horizontal-gap-of-1cm-between-guide-and-guide-text.svg @@ -56,23 +56,23 @@ x y +y + + + + + + + + + + 1.0 1.5 2.0 2.5 3.0 -y - - - - - - - - - - factor(x) diff --git a/tests/testthat/_snaps/guides/legend-inside-plot-bottom-left-of-legend-at-center.svg b/tests/testthat/_snaps/guides/legend-inside-plot-bottom-left-of-legend-at-center.svg index 3c614e1a9b..2bf9fc2fa0 100644 --- a/tests/testthat/_snaps/guides/legend-inside-plot-bottom-left-of-legend-at-center.svg +++ b/tests/testthat/_snaps/guides/legend-inside-plot-bottom-left-of-legend-at-center.svg @@ -52,23 +52,23 @@ x y +1:3 + + + + + + + + + + 1.0 1.5 2.0 2.5 3.0 -1:3 - - - - - - - - - - x diff --git a/tests/testthat/_snaps/guides/legend-inside-plot-bottom-left.svg b/tests/testthat/_snaps/guides/legend-inside-plot-bottom-left.svg index 21685b8367..2ccc33b55a 100644 --- a/tests/testthat/_snaps/guides/legend-inside-plot-bottom-left.svg +++ b/tests/testthat/_snaps/guides/legend-inside-plot-bottom-left.svg @@ -52,23 +52,23 @@ x y +1:3 + + + + + + + + + + 1.0 1.5 2.0 2.5 3.0 -1:3 - - - - - - - - - - x diff --git a/tests/testthat/_snaps/guides/legend-inside-plot-centered.svg b/tests/testthat/_snaps/guides/legend-inside-plot-centered.svg index b5b3de752f..7b5535e219 100644 --- a/tests/testthat/_snaps/guides/legend-inside-plot-centered.svg +++ b/tests/testthat/_snaps/guides/legend-inside-plot-centered.svg @@ -52,23 +52,23 @@ x y +1:3 + + + + + + + + + + 1.0 1.5 2.0 2.5 3.0 -1:3 - - - - - - - - - - x diff --git a/tests/testthat/_snaps/guides/legend-inside-plot-top-right.svg b/tests/testthat/_snaps/guides/legend-inside-plot-top-right.svg index 886e33deaf..9e40f28f1d 100644 --- a/tests/testthat/_snaps/guides/legend-inside-plot-top-right.svg +++ b/tests/testthat/_snaps/guides/legend-inside-plot-top-right.svg @@ -52,23 +52,23 @@ x y +1:3 + + + + + + + + + + 1.0 1.5 2.0 2.5 3.0 -1:3 - - - - - - - - - - x diff --git a/tests/testthat/_snaps/guides/multi-line-guide-title-works.svg b/tests/testthat/_snaps/guides/multi-line-guide-title-works.svg index 4ae49eb03b..ff7dc3c3bf 100644 --- a/tests/testthat/_snaps/guides/multi-line-guide-title-works.svg +++ b/tests/testthat/_snaps/guides/multi-line-guide-title-works.svg @@ -56,25 +56,25 @@ x y +the +continuous +colorscale + + + + + + + + + + 1.0 1.5 2.0 2.5 3.0 -the -continuous -colorscale - - - - - - - - - - the discrete diff --git a/tests/testthat/_snaps/guides/one-combined-colorbar-for-colour-and-fill-aesthetics.svg b/tests/testthat/_snaps/guides/one-combined-colorbar-for-colour-and-fill-aesthetics.svg index f49185354d..b8ca13811b 100644 --- a/tests/testthat/_snaps/guides/one-combined-colorbar-for-colour-and-fill-aesthetics.svg +++ b/tests/testthat/_snaps/guides/one-combined-colorbar-for-colour-and-fill-aesthetics.svg @@ -56,7 +56,22 @@ x y +value + + + + + + + + + + + + + + 1 2 3 @@ -64,21 +79,6 @@ 5 6 7 -value - - - - - - - - - - - - - - one combined colorbar for colour and fill aesthetics diff --git a/tests/testthat/_snaps/guides/padding-in-legend-box.svg b/tests/testthat/_snaps/guides/padding-in-legend-box.svg index 171270dba8..d55d3978fb 100644 --- a/tests/testthat/_snaps/guides/padding-in-legend-box.svg +++ b/tests/testthat/_snaps/guides/padding-in-legend-box.svg @@ -52,23 +52,23 @@ x y +1:3 + + + + + + + + + + 1.0 1.5 2.0 2.5 3.0 -1:3 - - - - - - - - - - x diff --git a/tests/testthat/_snaps/guides/rotated-guide-titles-and-labels.svg b/tests/testthat/_snaps/guides/rotated-guide-titles-and-labels.svg index c24ce9cfe3..1a4de9074b 100644 --- a/tests/testthat/_snaps/guides/rotated-guide-titles-and-labels.svg +++ b/tests/testthat/_snaps/guides/rotated-guide-titles-and-labels.svg @@ -67,23 +67,23 @@ long 10 long 15 +value + + + + + + + + + + 5.0 7.5 10.0 12.5 15.0 -value - - - - - - - - - - rotated guide titles and labels diff --git a/tests/testthat/_snaps/guides/vertical-gap-of-1cm-between-guide-title-and-guide.svg b/tests/testthat/_snaps/guides/vertical-gap-of-1cm-between-guide-title-and-guide.svg index c3a9aeeb4e..9abc788f7d 100644 --- a/tests/testthat/_snaps/guides/vertical-gap-of-1cm-between-guide-title-and-guide.svg +++ b/tests/testthat/_snaps/guides/vertical-gap-of-1cm-between-guide-title-and-guide.svg @@ -56,23 +56,23 @@ x y +y + + + + + + + + + + 1.0 1.5 2.0 2.5 3.0 -y - - - - - - - - - - factor(x) diff --git a/tests/testthat/_snaps/guides/white-to-red-colorbar-thick-black-ticks-green-frame.svg b/tests/testthat/_snaps/guides/white-to-red-colorbar-thick-black-ticks-green-frame.svg index 601ce5379f..8c10cc5ff0 100644 --- a/tests/testthat/_snaps/guides/white-to-red-colorbar-thick-black-ticks-green-frame.svg +++ b/tests/testthat/_snaps/guides/white-to-red-colorbar-thick-black-ticks-green-frame.svg @@ -56,24 +56,24 @@ x x +x + + + + + + + + + + 0.0 0.5 1.0 1.5 2.0 -x - - - - - - - - - - white-to-red colorbar, thick black ticks, green frame diff --git a/tests/testthat/_snaps/guides/white-to-red-colorbar-white-ticks-no-frame.svg b/tests/testthat/_snaps/guides/white-to-red-colorbar-white-ticks-no-frame.svg index 94d8822b7e..16b1604f52 100644 --- a/tests/testthat/_snaps/guides/white-to-red-colorbar-white-ticks-no-frame.svg +++ b/tests/testthat/_snaps/guides/white-to-red-colorbar-white-ticks-no-frame.svg @@ -56,23 +56,23 @@ x x +x + + + + + + + + + + 0.0 0.5 1.0 1.5 2.0 -x - - - - - - - - - - white-to-red colorbar, white ticks, no frame diff --git a/tests/testthat/_snaps/sec-axis/sec-axis-custom-transform.svg b/tests/testthat/_snaps/sec-axis/sec-axis-custom-transform.svg index 7198e3f244..e94f6ea95e 100644 --- a/tests/testthat/_snaps/sec-axis/sec-axis-custom-transform.svg +++ b/tests/testthat/_snaps/sec-axis/sec-axis-custom-transform.svg @@ -75,15 +75,15 @@ - - - - - - - - - + + + + + + + + + 0.001 0.010 0.100 diff --git a/tests/testthat/_snaps/sec-axis/sec-axis-datetime-scale.svg b/tests/testthat/_snaps/sec-axis/sec-axis-datetime-scale.svg index 481dde58fc..fb76b1ef79 100644 --- a/tests/testthat/_snaps/sec-axis/sec-axis-datetime-scale.svg +++ b/tests/testthat/_snaps/sec-axis/sec-axis-datetime-scale.svg @@ -67,6 +67,19 @@ + + + + + + + + + + + + + 04PM 06PM 08PM @@ -80,19 +93,6 @@ 12PM 02PM 04PM - - - - - - - - - - - - - -1.0 -0.5 0.0 diff --git a/tests/testthat/_snaps/sec-axis/sec-axis-independent-transformations.svg b/tests/testthat/_snaps/sec-axis/sec-axis-independent-transformations.svg index 6cbf536afe..cbfaa55e5b 100644 --- a/tests/testthat/_snaps/sec-axis/sec-axis-independent-transformations.svg +++ b/tests/testthat/_snaps/sec-axis/sec-axis-independent-transformations.svg @@ -51,16 +51,16 @@ + + + + + 5 10 15 20 25 - - - - - 0.2 0.3 0.4 diff --git a/tests/testthat/_snaps/sec-axis/sec-axis-monotonicity-test.svg b/tests/testthat/_snaps/sec-axis/sec-axis-monotonicity-test.svg index 931b3cb820..98c4304d47 100644 --- a/tests/testthat/_snaps/sec-axis/sec-axis-monotonicity-test.svg +++ b/tests/testthat/_snaps/sec-axis/sec-axis-monotonicity-test.svg @@ -59,10 +59,10 @@ - - - - + + + + 1 2 3 diff --git a/tests/testthat/_snaps/sec-axis/sec-axis-sec-power-transform.svg b/tests/testthat/_snaps/sec-axis/sec-axis-sec-power-transform.svg index 5d751307cb..0a5ed00224 100644 --- a/tests/testthat/_snaps/sec-axis/sec-axis-sec-power-transform.svg +++ b/tests/testthat/_snaps/sec-axis/sec-axis-sec-power-transform.svg @@ -57,18 +57,18 @@ + + + + + + -0.25 0.00 0.25 0.50 0.75 1.00 - - - - - - 4.950 4.975 5.000 diff --git a/tests/testthat/_snaps/sec-axis/sec-axis-skewed-transform.svg b/tests/testthat/_snaps/sec-axis/sec-axis-skewed-transform.svg index f22e062f17..57ca1033e4 100644 --- a/tests/testthat/_snaps/sec-axis/sec-axis-skewed-transform.svg +++ b/tests/testthat/_snaps/sec-axis/sec-axis-skewed-transform.svg @@ -152,16 +152,16 @@ + + + + + 1e-01 1e+00 1e+01 1e+02 1e+03 - - - - - 0.00 0.25 0.50 diff --git a/tests/testthat/_snaps/sec-axis/sec-axis-with-division.svg b/tests/testthat/_snaps/sec-axis/sec-axis-with-division.svg index 3fc8711769..e3105aa3cd 100644 --- a/tests/testthat/_snaps/sec-axis/sec-axis-with-division.svg +++ b/tests/testthat/_snaps/sec-axis/sec-axis-with-division.svg @@ -289,9 +289,9 @@ - - - + + + 10 15 20 diff --git a/tests/testthat/_snaps/theme/axes-styling.svg b/tests/testthat/_snaps/theme/axes-styling.svg index 12c4dfa9c8..35e016656f 100644 --- a/tests/testthat/_snaps/theme/axes-styling.svg +++ b/tests/testthat/_snaps/theme/axes-styling.svg @@ -56,14 +56,14 @@ + + + + 2.5 5.0 7.5 10.0 - - - - 2.5 5.0 @@ -74,10 +74,10 @@ - - - - + + + + 2.5 5.0 7.5 diff --git a/tests/testthat/_snaps/theme/ticks-length.svg b/tests/testthat/_snaps/theme/ticks-length.svg index b11bd1f602..898b83062b 100644 --- a/tests/testthat/_snaps/theme/ticks-length.svg +++ b/tests/testthat/_snaps/theme/ticks-length.svg @@ -40,14 +40,14 @@ + + + + 2.5 5.0 7.5 10.0 - - - - 2.5 5.0 7.5 @@ -56,10 +56,10 @@ - - - - + + + + 2.5 5.0 7.5 diff --git a/tests/testthat/test-coord-.R b/tests/testthat/test-coord-.R index eccac03852..c69eab0b51 100644 --- a/tests/testthat/test-coord-.R +++ b/tests/testthat/test-coord-.R @@ -34,9 +34,9 @@ test_that("guide names are not removed by `train_panel_guides()`", { layout <- data$layout data <- data$data - layout$setup_panel_guides(plot$guides, plot$layers, plot$mapping) + layout$setup_panel_guides(guides_list(NULL), plot$layers) # Line showing change in outcome - expect_equal(names(layout$panel_params[[1]]$guides), + expect_equal(names(layout$panel_params[[1]]$guides$aesthetics), c("x", "y", "x.sec", "y.sec")) }) diff --git a/tests/testthat/test-guides.R b/tests/testthat/test-guides.R index baa09394f4..71314e8cfb 100644 --- a/tests/testthat/test-guides.R +++ b/tests/testthat/test-guides.R @@ -1,10 +1,49 @@ skip_on_cran() # This test suite is long-running (on cran) and is skipped +test_that("plotting does not induce state changes in guides", { + + guides <- guides( + x = guide_axis(title = "X-axis"), + colour = guide_colourbar(title = "Colourbar"), + shape = guide_legend(title = "Legend"), + size = guide_bins(title = "Bins") + ) + + p <- ggplot(mpg, aes(displ, hwy, colour = cty, shape = factor(cyl), + size = cyl)) + + geom_point() + + guides + + snapshot <- serialize(as.list(p$guides), NULL) + + grob <- ggplotGrob(p) + + expect_identical(as.list(p$guides), unserialize(snapshot)) +}) + +test_that("adding guides doesn't change plot state", { + + p1 <- ggplot(mtcars, aes(disp, mpg)) + + expect_length(p1$guides$guides, 0) + + p2 <- p1 + guides(y = guide_axis(angle = 45)) + + expect_length(p1$guides$guides, 0) + expect_length(p2$guides$guides, 1) + + p3 <- p2 + guides(y = guide_axis(angle = 90)) + + expect_length(p3$guides$guides, 1) + expect_equal(p3$guides$guides[[1]]$params$angle, 90) + expect_equal(p2$guides$guides[[1]]$params$angle, 45) +}) + test_that("colourbar trains without labels", { g <- guide_colorbar() sc <- scale_colour_continuous(limits = c(0, 4), labels = NULL) - out <- guide_train(g, sc) + out <- g$train(scale = sc) expect_equal(names(out$key), c("colour", ".value")) }) @@ -113,13 +152,13 @@ test_that("guide_none() can be used in non-position scales", { built <- ggplot_build(p) plot <- built$plot - guides <- build_guides( + guides <- guides_list(plot$guides) + guides <- guides$build( plot$scales, plot$layers, plot$mapping, "right", theme_gray(), - plot$guides, plot$labels ) @@ -132,7 +171,7 @@ test_that("Using non-position guides for position scales results in an informati scale_x_continuous(guide = guide_legend()) built <- ggplot_build(p) - expect_snapshot_error(ggplot_gtable(built)) + expect_snapshot_warning(ggplot_gtable(built)) }) test_that("guide merging for guide_legend() works as expected", { @@ -144,8 +183,11 @@ test_that("guide merging for guide_legend() works as expected", { scales$add(scale1) scales$add(scale2) - guide_list <- guides_train(scales, theme = theme_gray(), labels = labs(), guides = guides()) - guides_merge(guide_list) + guides <- guides_list(NULL) + guides <- guides$setup(scales$scales) + guides$train(scales$scales, "vertical", labs()) + guides$merge() + guides$params } different_limits <- merge_test_guides( @@ -202,27 +244,22 @@ test_that("guide specifications are properly checked", { geom_point(aes(mpg, disp, shape = factor(gear))) + guides(shape = "colourbar") - expect_snapshot_error(ggplotGrob(p)) + expect_snapshot_warning(ggplotGrob(p)) - p <- p + guides(shape = guide_legend(title.position = "leftish")) + expect_snapshot_error(guide_legend(title.position = "leftish")) - expect_snapshot_error(ggplotGrob(p)) - - expect_snapshot_error(guide_transform(guide_colorbar())) + expect_snapshot_error(guide_colourbar()$transform()) p <- ggplot(mtcars) + geom_point(aes(mpg, disp, colour = gear)) + - guides(colour = guide_colorbar(label.position = "top")) + guides(colour = guide_colourbar(label.position = "top")) expect_snapshot_error(ggplotGrob(p)) p <- ggplot(mtcars) + geom_point(aes(mpg, disp, colour = gear)) + - guides(colour = guide_colorbar(direction = "horizontal", label.position = "left")) + guides(colour = guide_colourbar(direction = "horizontal", label.position = "left")) expect_snapshot_error(ggplotGrob(p)) - p <- ggplot(mtcars) + - geom_point(aes(mpg, disp, colour = gear)) + - guides(colour = guide_legend(label.position = "test")) - expect_snapshot_error(ggplotGrob(p)) + expect_snapshot_error(guide_legend(label.position = "test")) p <- ggplot(mtcars) + geom_point(aes(mpg, disp, colour = gear)) + guides(colour = guide_legend(nrow = 2, ncol = 2)) @@ -240,6 +277,40 @@ test_that("colorsteps and bins checks the breaks format", { expect_snapshot_error(suppressWarnings(ggplotGrob(p))) }) +test_that("legend reverse argument reverses the key", { + + scale <- scale_colour_discrete() + scale$train(LETTERS[1:4]) + + guides <- guides_list(NULL) + guides <- guides$setup(list(scale)) + + guides$params[[1]]$reverse <- FALSE + guides$train(list(scale), "horizontal", labels = labs()) + fwd <- guides$get_params(1)$key + + guides$params[[1]]$reverse <- TRUE + guides$train(list(scale), "horizontal", labels = labs()) + rev <- guides$get_params(1)$key + + expect_equal(fwd$colour, rev(rev$colour)) +}) + +test_that("guide_coloursteps and guide_bins return ordered breaks", { + scale <- scale_colour_viridis_c(breaks = c(2, 3, 1)) + scale$train(c(0, 4)) + + # Coloursteps guide is increasing order + g <- guide_colorsteps() + key <- g$train(scale = scale, aesthetic = "colour")$key + expect_true(all(diff(key$.value) > 0)) + + # Bins guide is decreasing order + g <- guide_bins() + key <- g$train(scale = scale, aesthetics = "colour", direction = "vertical")$key + expect_true(all(diff(key$.value) < 0)) +}) + # Visual tests ------------------------------------------------------------ test_that("axis guides are drawn correctly", { @@ -549,7 +620,7 @@ test_that("colorbar can be styled", { p + scale_color_gradient( low = 'white', high = 'red', guide = guide_colorbar( - frame.colour = "green", + frame = element_rect(colour = "green"), frame.linewidth = 1.5 / .pt, ticks.colour = "black", ticks.linewidth = 2.5 / .pt @@ -668,10 +739,21 @@ test_that("a warning is generated when guides( = FALSE) is specified", { # warn on guide( = FALSE) expect_warning(g <- guides(colour = FALSE), "The `` argument of `guides()` cannot be `FALSE`. Use \"none\" instead as of ggplot2 3.3.4.", fixed = TRUE) - expect_equal(g[["colour"]], "none") + expect_equal(g$guides[["colour"]], "none") # warn on scale_*(guide = FALSE) p <- ggplot(df, aes(x, y, colour = x)) + scale_colour_continuous(guide = FALSE) built <- expect_silent(ggplot_build(p)) expect_snapshot_warning(ggplot_gtable(built)) }) + +test_that("guides() errors if unnamed guides are provided", { + expect_error( + guides("axis"), + "All guides are unnamed." + ) + expect_error( + guides(x = "axis", "axis"), + "The 2nd guide is unnamed" + ) +}) diff --git a/tests/testthat/test-labels.R b/tests/testthat/test-labels.R index 0e866fa2a4..2517b8fac2 100644 --- a/tests/testthat/test-labels.R +++ b/tests/testthat/test-labels.R @@ -69,6 +69,139 @@ test_that("alt text is returned", { expect_equal(get_alt_text(p), "An alt text") }) +test_that("position axis label hierarchy works as intended", { + df <- data_frame(foo = c(1e1, 1e5), bar = c(0, 100)) + + p <- ggplot(df, aes(foo, bar)) + + geom_point(size = 5) + + p <- ggplot_build(p) + + # In absence of explicit title, get title from mapping + expect_identical( + p$layout$resolve_label(p$layout$panel_scales_x[[1]], p$plot$labels), + list(secondary = NULL, primary = "foo") + ) + expect_identical( + p$layout$resolve_label(p$layout$panel_scales_y[[1]], p$plot$labels), + list(primary = "bar", secondary = NULL) + ) + + # Scale name overrules mapping label + expect_identical( + p$layout$resolve_label(scale_x_continuous("Baz"), p$plot$labels), + list(secondary = NULL, primary = "Baz") + ) + expect_identical( + p$layout$resolve_label(scale_y_continuous("Qux"), p$plot$labels), + list(primary = "Qux", secondary = NULL) + ) + + # Guide titles overrule scale names + p$layout$setup_panel_guides( + guides_list(list(x = guide_axis("quuX"), y = guide_axis("corgE"))), + p$plot$layers + ) + expect_identical( + p$layout$resolve_label(scale_x_continuous("Baz"), p$plot$labels), + list(secondary = NULL, primary = "quuX") + ) + expect_identical( + p$layout$resolve_label(scale_y_continuous("Qux"), p$plot$labels), + list(primary = "corgE", secondary = NULL) + ) + + # Secondary axis names work + xsec <- scale_x_continuous("Baz", sec.axis = dup_axis(name = "grault")) + expect_identical( + p$layout$resolve_label(xsec, p$plot$labels), + list(secondary = "grault", primary = "quuX") + ) + ysec <- scale_y_continuous("Qux", sec.axis = dup_axis(name = "garply")) + expect_identical( + p$layout$resolve_label(ysec, p$plot$labels), + list(primary = "corgE", secondary = "garply") + ) + + # Secondary guide titles override secondary axis names + p$layout$setup_panel_guides( + guides_list(list(x = guide_axis("quuX"), y = guide_axis("corgE"), + x.sec = guide_axis("waldo"), y.sec = guide_axis("fred"))), + p$plot$layers + ) + expect_identical( + p$layout$resolve_label(xsec, p$plot$labels), + list(secondary = "waldo", primary = "quuX") + ) + ysec <- scale_y_continuous("Qux", sec.axis = dup_axis(name = "garply")) + expect_identical( + p$layout$resolve_label(ysec, p$plot$labels), + list(primary = "corgE", secondary = "fred") + ) +}) + +test_that("moving guide positions lets titles follow", { + df <- data_frame(foo = c(1e1, 1e5), bar = c(0, 100)) + + p <- ggplot(df, aes(foo, bar)) + + geom_point(size = 5) + + p <- ggplot_build(p) + + # Default guide positions + p$layout$setup_panel_guides( + guides_list( + list(x = guide_axis("baz", position = "bottom"), + y = guide_axis("qux", position = "left")) + ), + p$plot$layers + ) + expect_identical( + p$layout$resolve_label(p$layout$panel_scales_x[[1]], p$plot$labels), + list(secondary = NULL, primary = "baz") + ) + expect_identical( + p$layout$resolve_label(p$layout$panel_scales_y[[1]], p$plot$labels), + list(primary = "qux", secondary = NULL) + ) + + # Guides at secondary positions (changes order of primary/secondary) + p$layout$setup_panel_guides( + guides_list( + list(x = guide_axis("baz", position = "top"), + y = guide_axis("qux", position = "right")) + ), + p$plot$layers + ) + expect_identical( + p$layout$resolve_label(p$layout$panel_scales_x[[1]], p$plot$labels), + list(primary = "baz", secondary = NULL) + ) + expect_identical( + p$layout$resolve_label(p$layout$panel_scales_y[[1]], p$plot$labels), + list(secondary = NULL, primary = "qux") + ) + + # Primary guides at secondary positions with + # secondary guides at primary positions + p$layout$setup_panel_guides( + guides_list( + list(x = guide_axis("baz", position = "top"), + y = guide_axis("qux", position = "right"), + x.sec = guide_axis("quux"), + y.sec = guide_axis("corge")) + ), + p$plot$layers + ) + expect_identical( + p$layout$resolve_label(p$layout$panel_scales_x[[1]], p$plot$labels), + list(primary = "baz", secondary = "quux") + ) + expect_identical( + p$layout$resolve_label(p$layout$panel_scales_y[[1]], p$plot$labels), + list(secondary = "corge", primary = "qux") + ) +}) # Visual tests ------------------------------------------------------------ diff --git a/tests/testthat/test-scales.R b/tests/testthat/test-scales.R index 045d49b4e2..639f65674b 100644 --- a/tests/testthat/test-scales.R +++ b/tests/testthat/test-scales.R @@ -200,17 +200,6 @@ test_that("scales warn when transforms introduces non-finite values", { expect_warning(ggplot_build(p), "Transformation introduced infinite values") }) -test_that("scales get their correct titles through layout", { - df <- data_frame(x = c(1e1, 1e5), y = c(0, 100)) - - p <- ggplot(df, aes(x, y)) + - geom_point(size = 5) - - p <- ggplot_build(p) - expect_identical(p$layout$xlabel(p$plot$labels)$primary, "x") - expect_identical(p$layout$ylabel(p$plot$labels)$primary, "y") -}) - test_that("size and alpha scales throw appropriate warnings for factors", { df <- data_frame( x = 1:3,