Customizable key glyphs (#3236)

* implement customizable key glyphs. closes #3145

* provide all draw_key functions with sane defaults.

* fix comment

* improve news item

* add unit tests for customizable key glyphs

Author: clauswilke

NAMESPACE

@@ -273,6 +273,7 @@ export(draw_key_polygon)
 export(draw_key_rect)
 export(draw_key_smooth)
 export(draw_key_text)
+export(draw_key_timeseries)
 export(draw_key_vline)
 export(draw_key_vpath)
 export(dup_axis)

NEWS.md

@@ -35,6 +35,11 @@ core developer team.
 * `geom_rug()` gains an "outside" option to allow for moving the rug tassels to 
   outside the plot area (@njtierney, #3085) and a `length` option to allow for 
   changing the length of the rug lines (@daniel-wells, #3109). 
+  
+* All geoms now take a `key_glyph` paramter that allows users to customize
+  how legend keys are drawn (@clauswilke, #3145). In addition, a new key glyph
+  `timeseries` is provided to draw nice legends for time series
+  (@mitchelloharawild, #3145).
 
 ## Extensions
 

R/layer.r

@@ -42,6 +42,8 @@
 #'   supplied parameters and aesthetics are understood by the `geom` or
 #'   `stat`. Use `FALSE` to suppress the checks.
 #' @param params Additional parameters to the `geom` and `stat`.
+#' @param key_glyph A legend key drawing function or a string providing the
+#'   function name minus the `draw_key_` prefix. See [draw_key] for details.
 #' @param layer_class The type of layer object to be constructued. This is
 #'   intended for ggplot2 internal use only.
 #' @keywords internal
@@ -64,7 +66,7 @@ layer <- function(geom = NULL, stat = NULL,
                   data = NULL, mapping = NULL,
                   position = NULL, params = list(),
                   inherit.aes = TRUE, check.aes = TRUE, check.param = TRUE,
-                  show.legend = NA, layer_class = Layer) {
+                  show.legend = NA, key_glyph = NULL, layer_class = Layer) {
   if (is.null(geom))
     stop("Attempted to create layer with no geom.", call. = FALSE)
   if (is.null(stat))
@@ -103,6 +105,13 @@ layer <- function(geom = NULL, stat = NULL,
     params$na.rm <- FALSE
   }
 
+  # Special case for key_glyph parameter which is handed in through
+  # params since all geoms/stats forward ... to params
+  if (!is.null(params$key_glyph)) {
+    key_glyph <- params$key_glyph
+    params$key_glyph <- NULL # remove to avoid warning about unknown parameter
+  }
+
   # Split up params between aesthetics, geom, and stat
   params <- rename_aes(params)
   aes_params  <- params[intersect(names(params), geom$aesthetics())]
@@ -133,6 +142,9 @@ layer <- function(geom = NULL, stat = NULL,
     )
   }
 
+  # adjust the legend draw key if requested
+  geom <- set_draw_key(geom, key_glyph)
+
   ggproto("LayerInstance", layer_class,
     geom = geom,
     geom_params = geom_params,
@@ -388,3 +400,18 @@ obj_desc <- function(x) {
     )
   }
 }
+
+# helper function to adjust the draw_key slot of a geom
+# if a custom key glyph is requested
+set_draw_key <- function(geom, draw_key = NULL) {
+  if (is.null(draw_key)) {
+    return(geom)
+  }
+  if (is.character(draw_key)) {
+    draw_key <- paste0("draw_key_", draw_key)
+  }
+  draw_key <- match.fun(draw_key)
+
+  ggproto("", geom, draw_key = draw_key)
+}
+

R/legend-draw.r

@@ -1,31 +1,42 @@
-#' Key drawing functions
+#' Key glyphs for legends
 #'
-#' Each Geom has an associated function that draws the key when the geom needs
-#' to be displayed in a legend. These are the options built into ggplot2.
+#' Each geom has an associated function that draws the key when the geom needs
+#' to be displayed in a legend. These functions are called `draw_key_*()`, where
+#' `*` stands for the name of the respective key glyph. The key glyphs can be
+#' customized for individual geoms by providing a geom with the `key_glyph`
+#' argument (see [`layer()`] or examples below.)
 #'
 #' @return A grid grob.
 #' @param data A single row data frame containing the scaled aesthetics to
 #'   display in this key
 #' @param params A list of additional parameters supplied to the geom.
 #' @param size Width and height of key in mm.
-#' @keywords internal
+#' @examples
+#' p <- ggplot(economics, aes(date, psavert, color = "savings rate"))
+#' # key glyphs can be specified by their name
+#' p + geom_line(key_glyph = "timeseries")
+#'
+#' # key glyphs can be specified via their drawing function
+#' p + geom_line(key_glyph = draw_key_rect)
 #' @name draw_key
 NULL
 
 #' @export
 #' @rdname draw_key
 draw_key_point <- function(data, params, size) {
-  if (is.character(data$shape)) {
+  if (is.null(data$shape)) {
+    data$shape <- 19
+  } else if (is.character(data$shape)) {
     data$shape <- translate_shape_string(data$shape)
   }
 
   pointsGrob(0.5, 0.5,
     pch = data$shape,
     gp = gpar(
-      col = alpha(data$colour, data$alpha),
-      fill = alpha(data$fill, data$alpha),
-      fontsize = data$size * .pt + data$stroke * .stroke / 2,
-      lwd = data$stroke * .stroke / 2
+      col = alpha(data$colour %||% "black", data$alpha),
+      fill = alpha(data$fill %||% "black", data$alpha),
+      fontsize = (data$size %||% 1.5) * .pt + (data$stroke %||% 0.5) * .stroke / 2,
+      lwd = (data$stroke %||% 0.5) * .stroke / 2
     )
   )
 }
@@ -35,9 +46,9 @@ draw_key_point <- function(data, params, size) {
 draw_key_abline <- function(data, params, size) {
   segmentsGrob(0, 0, 1, 1,
     gp = gpar(
-      col = alpha(data$colour, data$alpha),
-      lwd = data$size * .pt,
-      lty = data$linetype,
+      col = alpha(data$colour %||% data$fill %||% "black", data$alpha),
+      lwd = (data$size %||% 0.5) * .pt,
+      lty = data$linetype %||% 1,
       lineend = "butt"
     )
   )
@@ -48,22 +59,26 @@ draw_key_abline <- function(data, params, size) {
 draw_key_rect <- function(data, params, size) {
   rectGrob(gp = gpar(
     col = NA,
-    fill = alpha(data$fill, data$alpha),
-    lty = data$linetype
+    fill = alpha(data$fill %||% data$colour %||% "grey20", data$alpha),
+    lty = data$linetype %||% 1
   ))
 }
 #' @export
 #' @rdname draw_key
 draw_key_polygon <- function(data, params, size) {
+  if (is.null(data$size)) {
+    data$size <- 0.5
+  }
+
   lwd <- min(data$size, min(size) / 4)
 
   rectGrob(
     width = unit(1, "npc") - unit(lwd, "mm"),
     height = unit(1, "npc") - unit(lwd, "mm"),
     gp = gpar(
-      col = data$colour,
-      fill = alpha(data$fill, data$alpha),
-      lty = data$linetype,
+      col = data$colour %||% NA,
+      fill = alpha(data$fill %||% "grey20", data$alpha),
+      lty = data$linetype %||% 1,
       lwd = lwd * .pt,
       linejoin = "mitre"
   ))
@@ -84,10 +99,10 @@ draw_key_boxplot <- function(data, params, size) {
     rectGrob(height = 0.5, width = 0.75),
     linesGrob(c(0.125, 0.875), 0.5),
     gp = gpar(
-      col = data$colour,
-      fill = alpha(data$fill, data$alpha),
-      lwd = data$size * .pt,
-      lty = data$linetype
+      col = data$colour %||% "grey20",
+      fill = alpha(data$fill %||% "white", data$alpha),
+      lwd = (data$size %||% 0.5) * .pt,
+      lty = data$linetype %||% 1
     )
   )
 }
@@ -99,24 +114,28 @@ draw_key_crossbar <- function(data, params, size) {
     rectGrob(height = 0.5, width = 0.75),
     linesGrob(c(0.125, 0.875), 0.5),
     gp = gpar(
-      col = data$colour,
-      fill = alpha(data$fill, data$alpha),
-      lwd = data$size * .pt,
-      lty = data$linetype
+      col = data$colour %||% "grey20",
+      fill = alpha(data$fill %||% "white", data$alpha),
+      lwd = (data$size %||% 0.5) * .pt,
+      lty = data$linetype %||% 1
     )
   )
 }
 
 #' @export
 #' @rdname draw_key
 draw_key_path <- function(data, params, size) {
-  data$linetype[is.na(data$linetype)] <- 0
+  if (is.null(data$linetype)) {
+    data$linetype <- 0
+  } else {
+    data$linetype[is.na(data$linetype)] <- 0
+  }
 
   segmentsGrob(0.1, 0.5, 0.9, 0.5,
     gp = gpar(
-      col = alpha(data$colour, data$alpha),
-      lwd = data$size * .pt,
-      lty = data$linetype,
+      col = alpha(data$colour %||% data$fill %||% "black", data$alpha),
+      lwd = (data$size %||% 0.5) * .pt,
+      lty = data$linetype %||% 1,
       lineend = "butt"
     ),
     arrow = params$arrow
@@ -128,9 +147,9 @@ draw_key_path <- function(data, params, size) {
 draw_key_vpath <- function(data, params, size) {
   segmentsGrob(0.5, 0.1, 0.5, 0.9,
     gp = gpar(
-      col = alpha(data$colour, data$alpha),
-      lwd = data$size * .pt,
-      lty = data$linetype,
+      col = alpha(data$colour %||% data$fill %||% "black", data$alpha),
+      lwd = (data$size %||% 0.5) * .pt,
+      lty = data$linetype %||% 1,
       lineend = "butt"
     ),
     arrow = params$arrow
@@ -143,8 +162,8 @@ draw_key_dotplot <- function(data, params, size) {
   pointsGrob(0.5, 0.5, size = unit(.5, "npc"),
     pch = 21,
     gp = gpar(
-      col = alpha(data$colour, data$alpha),
-      fill = alpha(data$fill, data$alpha)
+      col = alpha(data$colour %||% "black", data$alpha),
+      fill = alpha(data$fill %||% "black", data$alpha)
     )
   )
 }
@@ -154,14 +173,14 @@ draw_key_dotplot <- function(data, params, size) {
 draw_key_pointrange <- function(data, params, size) {
   grobTree(
     draw_key_vpath(data, params, size),
-    draw_key_point(transform(data, size = data$size * 4), params)
+    draw_key_point(transform(data, size = (data$size %||% 1.5) * 4), params)
   )
 }
 
 #' @export
 #' @rdname draw_key
 draw_key_smooth <- function(data, params, size) {
-  data$fill <- alpha(data$fill, data$alpha)
+  data$fill <- alpha(data$fill %||% "grey60", data$alpha)
   data$alpha <- 1
 
   grobTree(
@@ -174,14 +193,14 @@ draw_key_smooth <- function(data, params, size) {
 #' @rdname draw_key
 draw_key_text <- function(data, params, size) {
   if(is.null(data$label)) data$label <- "a"
-  
+
   textGrob(data$label, 0.5, 0.5,
-    rot = data$angle,
+    rot = data$angle %||% 0,
     gp = gpar(
-      col = alpha(data$colour, data$alpha),
-      fontfamily = data$family,
-      fontface = data$fontface,
-      fontsize = data$size * .pt
+      col = alpha(data$colour %||% data$fill %||% "black", data$alpha),
+      fontfamily = data$family %||% "",
+      fontface = data$fontface %||% 1,
+      fontsize = (data$size %||% 3.88) * .pt
     )
   )
 }
@@ -200,9 +219,30 @@ draw_key_label <- function(data, params, size) {
 draw_key_vline <- function(data, params, size) {
   segmentsGrob(0.5, 0, 0.5, 1,
     gp = gpar(
-      col = alpha(data$colour, data$alpha),
-      lwd = data$size * .pt,
-      lty = data$linetype,
+      col = alpha(data$colour %||% data$fill %||% "black", data$alpha),
+      lwd = (data$size %||% 0.5) * .pt,
+      lty = data$linetype %||% 1,
+      lineend = "butt"
+    )
+  )
+}
+
+#' @export
+#' @rdname draw_key
+draw_key_timeseries <- function(data, params, size) {
+  if (is.null(data$linetype)) {
+    data$linetype <- 0
+  } else {
+    data$linetype[is.na(data$linetype)] <- 0
+  }
+
+  grid::linesGrob(
+    x = c(0, 0.4, 0.6, 1),
+    y = c(0.1, 0.6, 0.4, 0.9),
+    gp = gpar(
+      col = alpha(data$colour %||% data$fill %||% "black", data$alpha),
+      lwd = (data$size %||% 0.5) * .pt,
+      lty = data$linetype %||% 1,
       lineend = "butt"
     )
   )