Custom guide

DESCRIPTION

@@ -181,6 +181,7 @@ Collate:
     'guide-bins.R'
     'guide-colorbar.R'
     'guide-colorsteps.R'
+    'guide-custom.R'
     'layer.R'
     'guide-none.R'
     'guide-old.R'

NAMESPACE

@@ -217,6 +217,7 @@ export(GuideAxisLogticks)
 export(GuideBins)
 export(GuideColourbar)
 export(GuideColoursteps)
+export(GuideCustom)
 export(GuideLegend)
 export(GuideNone)
 export(GuideOld)
@@ -429,6 +430,7 @@ export(guide_colorbar)
 export(guide_colorsteps)
 export(guide_colourbar)
 export(guide_coloursteps)
+export(guide_custom)
 export(guide_gengrob)
 export(guide_geom)
 export(guide_legend)

NEWS.md

@@ -1,5 +1,8 @@
 # ggplot2 (development version)
 
+* New `guide_custom()` function for drawing custom graphical objects (grobs)
+  unrelated to scales in legend positions (#5416).
+
 * `theme()` now supports splicing a list of arguments (#5542).
 
 * Contour functions will not fail when `options("OutDec")` is not `.` (@eliocamp, #5555).

R/guide-custom.R

@@ -0,0 +1,159 @@
+#' Custom guides
+#'
+#' This is a special guide that can be used to display any graphical object
+#' (grob) along with the regular guides. This guide has no associated scale.
+#'
+#' @param grob A grob to display.
+#' @param width,height The allocated width and height to display the grob, given
+#'  in [grid::unit()]s.
+#' @param title A character string or expression indicating the title of guide.
+#'   If `NULL` (default), no title is shown.
+#' @param title.position A character string indicating the position of a title.
+#'   One of `"top"` (default), `"bottom"`, `"left"` or `"right"`.
+#' @param margin Margins around the guide. See [margin()] for more details. If
+#'   `NULL` (default), margins are taken from the `legend.margin` theme setting.
+#' @param position Currently not in use.
+#' @inheritParams guide_legend
+#'
+#' @export
+#'
+#' @examples
+#' # A standard plot
+#' p <- ggplot(mpg, aes(displ, hwy)) +
+#'   geom_point()
+#'
+#' # Define a graphical object
+#' circle <- grid::circleGrob()
+#'
+#' # Rendering a grob as a guide
+#' p + guides(custom = guide_custom(circle, title = "My circle"))
+#'
+#' # Controlling the size of the grob defined in relative units
+#' p + guides(custom = guide_custom(
+#'   circle, title = "My circle",
+#'   width = unit(2, "cm"), height = unit(2, "cm"))
+#' )
+#'
+#' # Size of grobs in absolute units is taken directly without the need to
+#' # set these manually
+#' p + guides(custom = guide_custom(
+#'   title = "My circle",
+#'   grob = grid::circleGrob(r = unit(1, "cm"))
+#' ))
+guide_custom <- function(
+  grob, width = grobWidth(grob), height = grobHeight(grob),
+  title = NULL, title.position = "top", margin = NULL,
+  position = waiver(), order = 0
+) {
+  check_object(grob, is.grob, "a {.cls grob} object")
+  check_object(width, is.unit, "a {.cls unit} object")
+  check_object(height, is.unit, "a {.cls unit} object")
+  check_object(margin, is.margin, "a {.cls margin} object", allow_null = TRUE)
+  if (length(width) != 1) {
+    cli::cli_abort("{.arg width} must be a single {.cls unit}, not a unit vector.")
+  }
+  if (length(height) != 1) {
+    cli::cli_abort("{.arg height} must be a single {.cls unit}, not a unit vector.")
+  }
+  title.position <- arg_match0(title.position, .trbl)
+
+  new_guide(
+    grob = grob,
+    width = width,
+    height = height,
+    title = title,
+    title.position = title.position,
+    margin = margin,
+    hash = hash(list(title, grob)), # hash is already known
+    position = position,
+    order = order,
+    available_aes = "any",
+    super = GuideCustom
+  )
+}
+
+#' @rdname ggplot2-ggproto
+#' @format NULL
+#' @usage NULL
+#' @export
+GuideCustom <- ggproto(
+  "GuideCustom", Guide,
+
+  params = c(Guide$params, list(
+    grob = NULL, width = NULL, height = NULL,
+    margin = NULL,
+    title = NULL,
+    title.position = "top"
+  )),
+
+  hashables = exprs(title, grob),
+
+  elements = list(
+    background   = "legend.background",
+    theme.margin = "legend.margin",
+    theme.title  = "legend.title"
+  ),
+
+  train = function(...) {
+    params
+  },
+
+  transform = function(...) {
+    params
+  },
+
+  override_elements = function(params, elements, theme) {
+    elements$title <- elements$theme.title
+    elements$margin <- params$margin %||% elements$theme.margin
+    elements
+  },
+
+  draw = function(self, theme, position = NULL, direction = NULL,
+                  params = self$params) {
+
+    # Render title
+    elems <- self$setup_elements(params, self$elements, theme)
+    elems <- self$override_elements(params, elems, theme)
+    if (!is.waive(params$title) && !is.null(params$title)) {
+      title <- self$build_title(params$title, elems, params)
+    } else {
+      title <- zeroGrob()
+    }
+    title.position <- params$title.position
+    if (is.zero(title)) {
+      title.position <- "none"
+    }
+
+    width  <- convertWidth(params$width, "cm")
+    height <- convertHeight(params$height, "cm")
+    gt <- gtable(widths = width, heights = height)
+    gt <- gtable_add_grob(gt, params$grob, t = 1, l = 1, clip = "off")
+
+    if (params$title.position == "top") {
+      gt <- gtable_add_rows(gt, elems$margin[1], pos = 0)
+      gt <- gtable_add_rows(gt, unit(height_cm(title), "cm"), pos = 0)
+      gt <- gtable_add_grob(gt, title, t = 1, l = 1, name = "title", clip = "off")
+    } else if (params$title.position == "bottom") {
+      gt <- gtable_add_rows(gt, elems$margin[3], pos = -1)
+      gt <- gtable_add_rows(gt, unit(height_cm(title), "cm"), pos = -1)
+      gt <- gtable_add_grob(gt, title, t = -1, l = 1, name = "title", clip = "off")
+    } else if (params$title.position == "left") {
+      gt <- gtable_add_cols(gt, elems$margin[4], pos = 0)
+      gt <- gtable_add_cols(gt, unit(width_cm(title), "cm"), pos = 0)
+      gt <- gtable_add_grob(gt, title, t = 1, l = 1, name = "title", clip = "off")
+    } else if (params$title.position == "right") {
+      gt <- gtable_add_cols(gt, elems$margin[2], pos = -1)
+      gt <- gtable_add_cols(gt, unit(width_cm(title), "cm"), pos = 0)
+      gt <- gtable_add_grob(gt, title, t = 1, l = -1, name = "title", clip = "off")
+    }
+    gt <- gtable_add_padding(gt, elems$margin)
+
+    background <- element_grob(elems$background)
+    gt <- gtable_add_grob(
+      gt, background,
+      t = 1, l = 1, r = -1, b = -1,
+      z = -Inf, clip = "off"
+    )
+    gt
+  }
+)

R/guides-.R

@@ -248,6 +248,18 @@ Guides <- ggproto(
     )
   },
 
+  get_custom = function(self) {
+    custom <- vapply(self$guides, inherits, logical(1), what = "GuideCustom")
+    n_custom <- sum(custom)
+    if (n_custom < 1) {
+      return(guides_list())
+    }
+    custom <- guides_list(self$guides[custom])
+    custom$params <- lapply(custom$guides, `[[`, "params")
+    custom$merge()
+    custom
+  },
+
   ## Building ------------------------------------------------------------------
 
   # The `Guides$build()` method is called in ggplotGrob (plot-build.R) and makes
@@ -281,7 +293,8 @@ Guides <- ggproto(
   build = function(self, scales, layers, labels, layer_data) {
 
     # Empty guides list
-    no_guides <- guides_list()
+    custom <- self$get_custom()
+    no_guides <- custom
 
     # Extract the non-position scales
     scales <- scales$non_position_scales()$scales
@@ -308,6 +321,10 @@ Guides <- ggproto(
     if (length(guides$guides) == 0) {
       return(no_guides)
     }
+
+    guides$guides <- c(guides$guides, custom$guides)
+    guides$params <- c(guides$params, custom$params)
+
     guides
   },
 
@@ -413,22 +430,23 @@ Guides <- ggproto(
     # 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()
-    }
-
     # 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 = "_")
 
+    # If there is only one guide, we can exit early, because nothing to merge
+    if (length(pairs) == 1) {
+      names(self$guides) <- hashes
+      return()
+    }
+
     # Split by hashes
     indices <- split(seq_along(pairs), hashes)
     indices <- vapply(indices, `[[`, 0L, 1L, USE.NAMES = FALSE) # First index
-    groups  <- unname(split(pairs, hashes))
+    groups  <- split(pairs, hashes)
     lens    <- lengths(groups)
 
     # Merge groups with >1 member
@@ -495,6 +513,7 @@ Guides <- ggproto(
     if (length(grobs) < 1) {
       return(zeroGrob())
     }
+    grobs <- grobs[order(names(grobs))]
 
     # Set spacing
     theme$legend.spacing   <- theme$legend.spacing    %||% unit(0.5, "lines")

R/plot-build.R

@@ -94,8 +94,8 @@ ggplot_build.ggplot <- function(plot) {
     plot$guides <- plot$guides$build(npscales, plot$layers, plot$labels, data)
     data <- lapply(data, npscales$map_df)
   } else {
-    # Assign empty guides if there are no non-position scales
-    plot$guides <- guides_list()
+    # Only keep custom guides if there are no non-position scales
+    plot$guides <- plot$guides$get_custom()
   }
 
   # Fill in defaults etc.

_pkgdown.yml

@@ -130,6 +130,7 @@ reference:
   - guide_axis_theta
   - guide_bins
   - guide_coloursteps
+  - guide_custom
   - guide_none
   - guides
   - sec_axis