Old S3 guide wrapper (#5319)

* S3 guide necromancy

* Wrap old guide system in ggproto

* Validate old guides

* Add test for old S3 guides

* Add NEWS bullet

DESCRIPTION

@@ -181,6 +181,7 @@ Collate:
  'guide-colorsteps.R'
  'layer.R'
  'guide-none.R'
+ 'guide-old.R'
  'guides-.R'
  'guides-grid.R'
  'hexbin.R'

NAMESPACE

@@ -75,6 +75,11 @@ S3method(grobWidth,absoluteGrob)
 S3method(grobWidth,zeroGrob)
 S3method(grobX,absoluteGrob)
 S3method(grobY,absoluteGrob)
+S3method(guide_gengrob,default)
+S3method(guide_geom,default)
+S3method(guide_merge,default)
+S3method(guide_train,default)
+S3method(guide_transform,default)
 S3method(heightDetails,titleGrob)
 S3method(heightDetails,zeroGrob)
 S3method(interleave,default)
@@ -211,6 +216,7 @@ export(GuideColourbar)
 export(GuideColoursteps)
 export(GuideLegend)
 export(GuideNone)
+export(GuideOld)
 export(Layout)
 export(Position)
 export(PositionDodge)
@@ -416,8 +422,13 @@ 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)
@@ -451,6 +462,7 @@ export(mean_se)
 export(median_hilow)
 export(merge_element)
 export(new_guide)
+export(old_guide)
 export(panel_cols)
 export(panel_rows)
 export(position_dodge)

NEWS.md

@@ -27,6 +27,13 @@
  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:
+ * A fallback for old S3 guides is encapsulated in the `GuideOld` ggproto
+ class, which mostly just calls the old S3 generics.
+ * While the S3 guide generics are still in place, the S3 methods for 
+ `guide_train()`, `guide_merge()`, `guide_geom()`, `guide_transform()`,
+ `guide_gengrob()` have been superseded by the respective ggproto methods.
+ In practise, this will mean that `NextMethod()` or sub-classing ggplot2's
+ guides with the S3 system will no longer work.
  * 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

R/guide-old.R

@@ -0,0 +1,119 @@
+
+#' The previous S3 guide system
+#'
+#' The guide system has been overhauled to use the ggproto infrastructure to
+#' accommodate guide extensions with the same flexibility as layers, scales and
+#' other ggplot2 objects. In rewriting, the old S3 system has become defunct,
+#' meaning that the previous methods for guides have been superseded by ggproto
+#' methods. As a fallback option, the generics, but not the methods, that the
+#' previous S3 system used are encapsulated in the `GuideOld` ggproto class.
+#'
+#' @param guide An old guide object
+#' @keywords internal
+#' @name old_guide
+
+#' @export
+#' @rdname old_guide
+guide_train <- function(guide, scale, aesthetic = NULL) {
+ UseMethod("guide_train")
+}
+
+#' @export
+guide_train.default <- function(guide, ...) {
+ cli::cli_abort(c(
+ "{.cls Guide} classes have been rewritten as {.cls ggproto} classes.",
+ "The old S3 guide methods have been superseded."
+ ))
+}
+
+#' @export
+#' @rdname old_guide
+guide_merge <- function(guide, new_guide) {
+ UseMethod("guide_merge")
+}
+
+#' @export
+guide_merge.default <- guide_train.default
+
+#' @export
+#' @rdname old_guide
+guide_geom <- function(guide, layers, default_mapping = NULL) {
+ UseMethod("guide_geom")
+}
+
+#' @export
+guide_geom.default <- guide_train.default
+
+#' @export
+#' @rdname old_guide
+guide_transform <- function(guide, coord, panel_params) {
+ UseMethod("guide_transform")
+}
+
+#' @export
+guide_transform.default <- guide_train.default
+
+#' @export
+#' @rdname old_guide
+guide_gengrob <- function(guide, theme) {
+ UseMethod("guide_gengrob")
+}
+
+#' @export
+guide_gengrob.default <- guide_train.default
+
+#' @export
+#' @rdname old_guide
+old_guide <- function(guide) {
+ deprecate_warn0(
+ when = "3.5.0",
+ what = I("The S3 guide system"),
+ details = c(
+ i = "It has been replaced by a ggproto system that can be extended."
+ )
+ )
+
+ ggproto(
+ NULL, GuideOld,
+ params = guide,
+ available_aes = guide$available_aes %||% NULL
+ )
+}
+
+#' @rdname ggplot2-ggproto
+#' @format NULL
+#' @usage NULL
+#' @export
+GuideOld <- ggproto(
+ "GuideOld", Guide,
+
+ train = function(self, params, scale, aesthetic = NULL,
+ title = NULL, direction = NULL) {
+ params <- guide_train(params, scale, aesthetic)
+ params$title <- params$title %|W|% title
+ params$direction <- params$direction %||% direction
+ params
+ },
+
+ merge = function(self, params, new_guide, new_params) {
+ guide_merge(params, new_params)
+ },
+
+ transform = function(self, params, coord, panel_params, ...) {
+ guide_transform(params, coord, panel_params)
+ },
+
+ get_layer_key = function(params, layers) {
+ guide_geom(params, layers, default_mapping = NULL)
+ },
+
+ draw = function(self, theme, params) {
+ params$title.position <- params$title.position %||% switch(
+ params$direction %||% "placeholder",
+ vertical = "top", horizontal = "left",
+ NULL
+ )
+ guide_gengrob(params, theme)
+ }
+)
+

R/guides-.R

@@ -635,8 +635,10 @@ validate_guide <- function(guide) {
  }
  }
  if (inherits(guide, "Guide")) {
- guide
- } else {
- cli::cli_abort("Unknown guide: {guide}")
+ return(guide)
+ }
+ if (inherits(guide, "guide") && is.list(guide)) {
+ return(old_guide(guide))
  }
+ cli::cli_abort("Unknown guide: {guide}")
 }

tests/testthat/_snaps/guides.md

@@ -80,3 +80,8 @@
  The `guide` argument in `scale_*()` cannot be `FALSE`. This was deprecated in ggplot2 3.3.4.
  i Please use "none" instead.
 
+# old S3 guides can be implemented
+
+ The S3 guide system was deprecated in ggplot2 3.5.0.
+ i It has been replaced by a ggproto system that can be extended.
+