Convert guides to ggproto (#4879)

The guide system, as the last remaining chunk of ggplot2, has been rewritten 
in ggproto. The axes and legends now inherit from a <Guide> 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 <element> 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).

Author: teunbrand

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'

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)

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 <Guide> 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 <element> 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 

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()) {

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]
+  )
 }

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)