POC: double dispatch for ggplot_add()

DESCRIPTION

@@ -40,6 +40,7 @@ Imports:
     MASS,
     mgcv,
     rlang (>= 1.1.0),
+    S7,
     scales (>= 1.2.0),
     stats,
     tibble,

NAMESPACE

@@ -51,20 +51,6 @@ S3method(get_alt_text,ggplot_built)
 S3method(get_alt_text,gtable)
 S3method(ggplot,"function")
 S3method(ggplot,default)
-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,labels)
-S3method(ggplot_add,list)
-S3method(ggplot_add,theme)
-S3method(ggplot_add,uneval)
 S3method(ggplot_build,ggplot)
 S3method(ggplot_gtable,ggplot_built)
 S3method(grid.draw,absoluteGrob)
@@ -700,6 +686,13 @@ import(gtable)
 import(rlang)
 import(scales)
 import(vctrs)
+importFrom(S7,"method<-")
+importFrom(S7,S7_dispatch)
+importFrom(S7,class_any)
+importFrom(S7,class_list)
+importFrom(S7,method)
+importFrom(S7,new_S3_class)
+importFrom(S7,new_generic)
 importFrom(glue,glue)
 importFrom(glue,glue_collapse)
 importFrom(lifecycle,deprecated)

R/ggplot2-package.R

@@ -5,6 +5,7 @@
 #' @import scales grid gtable rlang vctrs
 #' @importFrom glue glue glue_collapse
 #' @importFrom lifecycle deprecated
+#' @importFrom S7 class_any class_list method method<- new_generic new_S3_class S7_dispatch
 #' @importFrom stats setNames
 #' @importFrom utils head tail
 ## usethis namespace: end

R/plot-construction.R

@@ -87,49 +87,80 @@ add_ggplot <- function(p, object, objectname) {
 #'
 #' @keywords internal
 #' @export
-ggplot_add <- function(object, plot, object_name) {
-  UseMethod("ggplot_add")
-}
-#' @export
-ggplot_add.default <- function(object, plot, object_name) {
+ggplot_add <- new_generic(
+  "ggplot_add",
+  dispatch_args = c("object", "plot"),
+  fun = function(object, plot, object_name) S7_dispatch()
+)
+
+class_ggplot <- new_S3_class("ggplot")
+
+method(
+  ggplot_add,
+  list(object = class_any, plot = class_ggplot)
+) <- function(object, plot, object_name) {
   cli::cli_abort("Can't add {.var {object_name}} to a {.cls ggplot} object.")
 }
-#' @export
-ggplot_add.NULL <- function(object, plot, object_name) {
+
+method(
+  ggplot_add,
+  list(object = new_S3_class("NULL"), plot = class_ggplot)
+) <- function(object, plot, object_name) {
   plot
 }
-#' @export
-ggplot_add.data.frame <- function(object, plot, object_name) {
+
+method(
+  ggplot_add,
+  list(object = new_S3_class("data.frame"), plot = class_ggplot)
+) <- function(object, plot, object_name) {
   plot$data <- object
   plot
 }
-#' @export
-ggplot_add.function <- function(object, plot, object_name) {
+
+method(
+  ggplot_add,
+  list(object = new_S3_class("function"), plot = class_ggplot)
+) <- function(object, plot, object_name) {
   cli::cli_abort(c(
-          "Can't add {.var {object_name}} to a {.cls ggplot} object",
+    "Can't add {.var {object_name}} to a {.cls ggplot} object",
     "i" = "Did you forget to add parentheses, as in {.fn {object_name}}?"
   ))
 }
-#' @export
-ggplot_add.theme <- function(object, plot, object_name) {
+
+method(
+  ggplot_add,
+  list(object = new_S3_class("theme"), plot = class_ggplot)
+) <- function(object, plot, object_name) {
   plot$theme <- add_theme(plot$theme, object)
   plot
 }
-#' @export
-ggplot_add.Scale <- function(object, plot, object_name) {
+
+method(
+  ggplot_add,
+  list(object = new_S3_class("Scale"), plot = class_ggplot)
+) <- function(object, plot, object_name) {
   plot$scales$add(object)
   plot
 }
-#' @export
-ggplot_add.labels <- function(object, plot, object_name) {
+
+method(
+  ggplot_add,
+  list(object = new_S3_class("labels"), plot = class_ggplot)
+) <- function(object, plot, object_name) {
   update_labels(plot, object)
 }
-#' @export
-ggplot_add.Guides <- function(object, plot, object_name) {
+
+method(
+  ggplot_add,
+  list(object = new_S3_class("Guides"), plot = class_ggplot)
+) <- function(object, plot, object_name) {
   update_guides(plot, object)
 }
-#' @export
-ggplot_add.uneval <- function(object, plot, object_name) {
+
+method(
+  ggplot_add,
+  list(object = new_S3_class("uneval"), plot = class_ggplot)
+) <- function(object, plot, object_name) {
   plot$mapping <- defaults(object, plot$mapping)
   # defaults() doesn't copy class, so copy it.
   class(plot$mapping) <- class(object)
@@ -138,34 +169,48 @@ ggplot_add.uneval <- function(object, plot, object_name) {
   names(labels) <- names(object)
   update_labels(plot, labels)
 }
-#' @export
-ggplot_add.Coord <- function(object, plot, object_name) {
+
+method(
+  ggplot_add,
+  list(object = new_S3_class("Coord"), plot = class_ggplot)
+) <- function(object, plot, object_name) {
   if (!isTRUE(plot$coordinates$default)) {
     cli::cli_inform("Coordinate system already present. Adding new coordinate system, which will replace the existing one.")
   }
 
   plot$coordinates <- object
   plot
 }
-#' @export
-ggplot_add.Facet <- function(object, plot, object_name) {
+
+method(
+  ggplot_add,
+  list(object = new_S3_class("Facet"), plot = class_ggplot)
+) <- function(object, plot, object_name) {
   plot$facet <- object
   plot
 }
-#' @export
-ggplot_add.list <- function(object, plot, object_name) {
+
+method(
+  ggplot_add,
+  list(object = class_list, plot = class_ggplot)
+) <- function(object, plot, object_name) {
   for (o in object) {
     plot <- plot %+% o
   }
   plot
 }
-#' @export
-ggplot_add.by <- function(object, plot, object_name) {
+
+method(
+  ggplot_add,
+  list(object = new_S3_class("by"), plot = class_ggplot)
+) <- function(object, plot, object_name) {
   ggplot_add.list(object, plot, object_name)
 }
 
-#' @export
-ggplot_add.Layer <- function(object, plot, object_name) {
+method(
+  ggplot_add,
+  list(object = new_S3_class("Layer"), plot = class_ggplot)
+) <- function(object, plot, object_name) {
   plot$layers <- append(plot$layers, object)
 
   # Add any new labels