Make position guides customizable (#3398, closes #3322)

* Position guides can now be customized using the new `guide_axis()`, which can be passed to position `scale_*()` functions or via `guides()`. The new axis guide (`guide_axis()`) comes with arguments `check.overlap` (automatic removal of overlapping labels), `angle` (easy rotation of axis labels), and `n.dodge` (dodge labels into multiple rows/columns)

* `CoordCartesian` gets new methods to resolve/train the new position guides

Author: paleolimbot

DESCRIPTION

@@ -158,6 +158,7 @@ Collate:
     'guides-.r'
     'guides-axis.r'
     'guides-grid.r'
+    'guides-none.r'
     'hexbin.R'
     'labeller.r'
     'labels.r'

NAMESPACE

@@ -67,14 +67,25 @@ S3method(grobWidth,absoluteGrob)
 S3method(grobWidth,zeroGrob)
 S3method(grobX,absoluteGrob)
 S3method(grobY,absoluteGrob)
+S3method(guide_gengrob,axis)
 S3method(guide_gengrob,colorbar)
+S3method(guide_gengrob,guide_none)
 S3method(guide_gengrob,legend)
+S3method(guide_geom,axis)
 S3method(guide_geom,colorbar)
+S3method(guide_geom,guide_none)
 S3method(guide_geom,legend)
+S3method(guide_merge,axis)
 S3method(guide_merge,colorbar)
+S3method(guide_merge,guide_none)
 S3method(guide_merge,legend)
+S3method(guide_train,axis)
 S3method(guide_train,colorbar)
+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)
@@ -358,13 +369,16 @@ export(ggproto)
 export(ggproto_parent)
 export(ggsave)
 export(ggtitle)
+export(guide_axis)
 export(guide_colorbar)
 export(guide_colourbar)
 export(guide_gengrob)
 export(guide_geom)
 export(guide_legend)
 export(guide_merge)
+export(guide_none)
 export(guide_train)
+export(guide_transform)
 export(guides)
 export(is.Coord)
 export(is.facet)

NEWS.md

@@ -1,5 +1,12 @@
 # ggplot2 (development version)
 
+* Position guides can now be customized using the new `guide_axis()`,
+  which can be passed to position `scale_*()` functions or via
+  `guides()`. The new axis guide (`guide_axis()`) comes with
+  arguments `check.overlap` (automatic removal of overlapping
+  labels), `angle` (easy rotation of axis labels), and
+  `n.dodge` (dodge labels into multiple rows/columns) (@paleolimbot, #3322).
+
 * `Geom` now gains a `setup_params()` method in line with the other ggproto
   classes (@thomasp85, #3509)
 

R/axis-secondary.R

@@ -20,6 +20,9 @@
 #'   - A character vector giving labels (must be same length as `breaks`)
 #'   - A function that takes the breaks as input and returns labels as output
 #'
+#' @param guide A position guide that will be used to render
+#'   the axis on the plot. Usually this is [guide_axis()].
+#'
 #' @details
 #' `sec_axis` is used to create the specifications for a secondary axis.
 #' Except for the `trans` argument any of the arguments can be set to
@@ -79,7 +82,8 @@
 #'   labels = scales::time_format("%b %d %I %p")))
 #'
 #' @export
-sec_axis <- function(trans = NULL, name = waiver(), breaks = waiver(), labels = waiver()) {
+sec_axis <- function(trans = NULL, name = waiver(), breaks = waiver(), labels = waiver(),
+                     guide = waiver()) {
   # sec_axis() historically accpeted two-sided formula, so be permissive.
   if (length(trans) > 2) trans <- trans[c(1,3)]
 
@@ -88,14 +92,15 @@ sec_axis <- function(trans = NULL, name = waiver(), breaks = waiver(), labels =
     trans = trans,
     name = name,
     breaks = breaks,
-    labels = labels
+    labels = labels,
+    guide = guide
   )
 }
 #' @rdname sec_axis
 #'
 #' @export
-dup_axis <- function(trans = ~., name = derive(), breaks = derive(), labels = derive()) {
-  sec_axis(trans, name, breaks, labels)
+dup_axis <- function(trans = ~., name = derive(), breaks = derive(), labels = derive(), guide = derive()) {
+  sec_axis(trans, name, breaks, labels, guide)
 }
 
 is.sec_axis <- function(x) {
@@ -148,6 +153,7 @@ AxisSecondary <- ggproto("AxisSecondary", NULL,
     if (is.derived(self$breaks)) self$breaks <- scale$breaks
     if (is.waive(self$breaks)) self$breaks <- scale$trans$breaks
     if (is.derived(self$labels)) self$labels <- scale$labels
+    if (is.derived(self$guide)) self$guide <- scale$guide
   },
 
   transform_range = function(self, range) {

R/coord-.r

@@ -59,7 +59,7 @@ Coord <- ggproto("Coord",
 
   aspect = function(ranges) NULL,
 
-  labels = function(panel_params) panel_params,
+  labels = function(labels, panel_params) labels,
 
   render_fg = function(panel_params, theme) element_render(theme, "panel.border"),
 
@@ -91,6 +91,14 @@ Coord <- ggproto("Coord",
     list()
   },
 
+  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(data, range) NULL,
 
   distance = function(x, y, panel_params) NULL,

R/coord-cartesian-.r

@@ -103,6 +103,75 @@ CoordCartesian <- ggproto("CoordCartesian", Coord,
     )
   },
 
+  setup_panel_guides = function(self, panel_params, guides, params = list()) {
+    aesthetics <- c("x", "y", "x.sec", "y.sec")
+    names(aesthetics) <- aesthetics
+
+    # 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 an "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
+    })
+
+    panel_params$guides <- guides
+    panel_params
+  },
+
+  train_panel_guides = function(self, panel_params, layers, default_mapping, params = list()) {
+    aesthetics <- c("x", "y", "x.sec", "y.sec")
+    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
+    })
+
+    panel_params
+  },
+
+  labels = function(self, labels, panel_params) {
+    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]])
+      })
+    )
+  },
+
   render_bg = function(panel_params, theme) {
     guide_grid(
       theme,
@@ -114,24 +183,16 @@ CoordCartesian <- ggproto("CoordCartesian", Coord,
   },
 
   render_axis_h = function(panel_params, theme) {
-    arrange <- panel_params$x.arrange %||% c("secondary", "primary")
-    arrange_scale_keys <- c("primary" = "x", "secondary" = "x.sec")[arrange]
-    arrange_scales <- panel_params[arrange_scale_keys]
-
     list(
-      top = draw_view_scale_axis(arrange_scales[[1]], "top", theme),
-      bottom = draw_view_scale_axis(arrange_scales[[2]], "bottom", theme)
+      top = panel_guides_grob(panel_params$guides, position = "top", theme = theme),
+      bottom = panel_guides_grob(panel_params$guides, position = "bottom", theme = theme)
     )
   },
 
   render_axis_v = function(panel_params, theme) {
-    arrange <- panel_params$y.arrange %||% c("primary", "secondary")
-    arrange_scale_keys <- c("primary" = "y", "secondary" = "y.sec")[arrange]
-    arrange_scales <- panel_params[arrange_scale_keys]
-
     list(
-      left = draw_view_scale_axis(arrange_scales[[1]], "left", theme),
-      right = draw_view_scale_axis(arrange_scales[[2]], "right", theme)
+      left = panel_guides_grob(panel_params$guides, position = "left", theme = theme),
+      right = panel_guides_grob(panel_params$guides, position = "right", theme = theme)
     )
   }
 )
@@ -153,10 +214,24 @@ view_scales_from_scale <- function(scale, coord_limits = NULL, expand = TRUE) {
   view_scales
 }
 
-draw_view_scale_axis <- function(view_scale, axis_position, theme) {
-  if(is.null(view_scale) || view_scale$is_empty()) {
-    return(zeroGrob())
-  }
+panel_guide_label <- function(guides, position, default_label) {
+  guide <- guide_for_position(guides, position) %||% guide_none(title = NULL)
+  guide$title %|W|% default_label
+}
+
+panel_guides_grob <- function(guides, position, theme) {
+  guide <- guide_for_position(guides, position) %||% guide_none()
+  guide_gengrob(guide, theme)
+}
+
+guide_for_position <- function(guides, position) {
+  has_position <- vapply(
+    guides,
+    function(guide) identical(guide$position, position),
+    logical(1)
+  )
 
-  draw_axis(view_scale$break_positions(), view_scale$get_labels(), axis_position, theme)
+  guides <- guides[has_position]
+  guides_order <- vapply(guides, function(guide) as.numeric(guide$order)[1], numeric(1))
+  Reduce(guide_merge, guides[order(guides_order)])
 }

R/coord-flip.r

@@ -40,7 +40,7 @@ coord_flip <- function(xlim = NULL, ylim = NULL, expand = TRUE, clip = "on") {
 CoordFlip <- ggproto("CoordFlip", CoordCartesian,
 
   transform = function(data, panel_params) {
-    data <- flip_labels(data)
+    data <- flip_axis_labels(data)
     CoordCartesian$transform(data, panel_params)
   },
 
@@ -58,11 +58,11 @@ CoordFlip <- ggproto("CoordFlip", CoordCartesian,
   setup_panel_params = function(self, scale_x, scale_y, params = list()) {
     parent <- ggproto_parent(CoordCartesian, self)
     panel_params <- parent$setup_panel_params(scale_x, scale_y, params)
-    flip_labels(panel_params)
+    flip_axis_labels(panel_params)
   },
 
-  labels = function(panel_params) {
-    flip_labels(CoordCartesian$labels(panel_params))
+  labels = function(labels, panel_params) {
+    flip_axis_labels(CoordCartesian$labels(labels, panel_params))
   },
 
   setup_layout = function(layout, params) {
@@ -72,14 +72,29 @@ CoordFlip <- ggproto("CoordFlip", CoordCartesian,
   },
 
   modify_scales = function(scales_x, scales_y) {
-    lapply(scales_x, scale_flip_position)
-    lapply(scales_y, scale_flip_position)
+    lapply(scales_x, scale_flip_axis)
+    lapply(scales_y, scale_flip_axis)
   }
 
 )
 
+# In-place modification of a scale position to swap axes
+scale_flip_axis <- function(scale) {
+  scale$position <- switch(scale$position,
+    top = "right",
+    bottom = "left",
+    left = "bottom",
+    right = "top",
+    scale$position
+  )
+
+  invisible(scale)
+}
 
-flip_labels <- function(x) {
+# maintaining the position of the x* and y* names is
+# important for re-using the same guide_transform()
+# as CoordCartesian
+flip_axis_labels <- function(x) {
   old_names <- names(x)
 
   new_names <- old_names

R/coord-polar.r

@@ -305,11 +305,11 @@ CoordPolar <- ggproto("CoordPolar", Coord,
     )
   },
 
-  labels = function(self, panel_params) {
+  labels = function(self, labels, panel_params) {
     if (self$theta == "y") {
-      list(x = panel_params$y, y = panel_params$x)
+      list(x = labels$y, y = labels$x)
     } else {
-      panel_params
+      labels
     }
   },
 

R/coord-sf.R

@@ -195,6 +195,8 @@ CoordSf <- ggproto("CoordSf", CoordCartesian,
     diff(panel_params$y_range) / diff(panel_params$x_range) / ratio
   },
 
+  labels = function(labels, panel_params) labels,
+
   render_bg = function(self, panel_params, theme) {
     el <- calc_element("panel.grid.major", theme)