double dispatch for ggplot_add()

Author: teunbrand

NAMESPACE

@@ -54,17 +54,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,list)
 S3method(ggplot_build,ggplot)
 S3method(ggplot_build,ggplot_built)
 S3method(ggplot_gtable,ggplot_built)

R/plot-construction.R

@@ -1,3 +1,6 @@
+#' @include plot.R
+NULL
+
 #' Add components to a plot
 #'
 #' `+` is the key to constructing sophisticated ggplot2 graphics. It
@@ -52,7 +55,6 @@
   e2name <- deparse(substitute(e2))
 
   if      (is.theme(e1))  add_theme(e1, e2, e2name)
-  else if (is.ggplot(e1)) add_ggplot(e1, e2, e2name)
   else if (is.ggproto(e1)) {
     cli::cli_abort(c(
       "Cannot add {.cls ggproto} objects together.",
@@ -61,10 +63,15 @@
   }
 }
 
+S7::method(`+`, list(class_ggplot, S7::class_any)) <- function(e1, e2) {
+  e2name <- deparse(substitute(e2, env = caller_env(2)))
+  add_ggplot(e1, e2, e2name)
+}
+
 
 #' @rdname gg-add
 #' @export
-"%+%" <- `+.gg`
+"%+%" <- function(e1, e2) e1 + e2
 
 add_ggplot <- function(p, object, objectname) {
   if (is.null(object)) return(p)
@@ -110,88 +117,88 @@ add_ggplot <- function(p, object, objectname) {
 #'
 #' # clean-up
 #' rm(ggplot_add.element_text)
-ggplot_add <- function(object, plot, object_name) {
-  UseMethod("ggplot_add")
-}
-#' @export
-ggplot_add.default <- 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) {
-  plot
-}
-#' @export
-ggplot_add.data.frame <- function(object, plot, object_name) {
-  plot@data <- object
-  plot
-}
-#' @export
-ggplot_add.function <- function(object, plot, object_name) {
-  cli::cli_abort(c(
-          "Can't add {.var {object_name}} to a {.cls ggplot} object",
-    "i" = "Did you forget to add parentheses, as in {.fn {object_name}}?"
-  ))
-}
+ggplot_add <- S7::new_generic("ggplot_add", c("object", "plot"))
 
-#' @export
-ggplot_add.Scale <- function(object, plot, object_name) {
-  plot@scales$add(object)
-  plot
-}
-S7::method(ggplot_add, labs) <- function(object, plot, object_name) {
-  update_labels(plot, object)
-}
-#' @export
-ggplot_add.Guides <- function(object, plot, object_name) {
-  if (is.guides(plot@guides)) {
-    # We clone the guides object to prevent modify-in-place of guides
+S7::method(ggplot_add, list(S7::class_any, class_ggplot)) <-
+  function(object, plot, object_name, ...) {
+    cli::cli_abort("Can't add {.var {object_name}} to a {.cls ggplot} object.")
+  }
+
+S7::method(ggplot_add, list(S7::class_function, class_ggplot)) <-
+  function(object, plot, object_name, ...) {
+    cli::cli_abort(c(
+      "Can't add {.var {object_name}} to a {.cls ggplot} object",
+      "i" = "Did you forget to add parentheses, as in {.fn {object_name}}?"
+    ))
+  }
+
+S7::method(ggplot_add, list(NULL, class_ggplot)) <-
+  function(object, plot, ...) { plot }
+
+S7::method(ggplot_add, list(S7::class_data.frame, class_ggplot)) <-
+  function(object, plot, ...) { S7::set_props(plot, data = object) }
+
+S7::method(ggplot_add, list(class_scale, class_ggplot)) <-
+  function(object, plot, ...) {
+    plot@scales$add(object)
+    plot
+  }
+
+S7::method(ggplot_add, list(labs, class_ggplot)) <-
+  function(object, plot, ...) { update_labels(plot, object) }
+
+S7::method(ggplot_add, list(class_guides, class_ggplot)) <-
+  function(object, plot, ...) {
     old <- plot@guides
     new <- ggproto(NULL, old)
     new$add(object)
     plot@guides <- new
-  } else {
-    plot@guides <- object
+    plot
   }
-  plot
-}
-S7::method(ggplot_add, mapping) <- function(object, plot, object_name) {
-  plot@mapping <- mapping(defaults(object, plot@mapping))
-  plot
-}
-#' @export
-ggplot_add.Coord <- 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.")
+
+S7::method(ggplot_add, list(mapping, class_ggplot)) <-
+  function(object, plot, ...) {
+    S7::set_props(plot, mapping = mapping(defaults(object, plot@mapping)))
   }
 
-  plot@coordinates <- object
-  plot
-}
-#' @export
-ggplot_add.Facet <- function(object, plot, object_name) {
-  plot@facet <- object
-  plot
-}
-#' @export
-ggplot_add.list <- function(object, plot, object_name) {
-  for (o in object) {
-    plot <- ggplot_add(o, plot, object_name)
+S7::method(ggplot_add, list(theme, class_ggplot)) <-
+  function(object, plot, ...) {
+    S7::set_props(plot, theme = add_theme(plot@theme, object))
   }
-  plot
-}
-#' @export
-ggplot_add.by <- function(object, plot, object_name) {
-  ggplot_add.list(object, plot, object_name)
-}
 
-#' @export
-ggplot_add.Layer <- function(object, plot, object_name) {
-  layers_names <- new_layer_names(object, names2(plot@layers))
-  plot@layers <- append(plot@layers, object)
-  names(plot@layers) <- layers_names
-  plot
-}
+S7::method(ggplot_add, list(class_coord, class_ggplot)) <-
+  function(object, plot, ...) {
+    if (!isTRUE(plot@coordinates$default)) {
+      cli::cli_inform(c(
+        "Coordinate system already present.",
+        i = "Adding new coordinate system, which will replace the existing one."
+      ))
+    }
+    S7::set_props(plot, coordinates = object)
+  }
+
+S7::method(ggplot_add, list(class_facet, class_ggplot)) <-
+  function(object, plot, ...) { S7::set_props(plot, facet = object) }
+
+S7::method(ggplot_add, list(class_layer, class_ggplot)) <-
+  function(object, plot, ...) {
+    layers_names <- new_layer_names(object, names2(plot@layers))
+    object <- setNames(append(plot@layers, object), layers_names)
+    S7::set_props(plot, layers = object)
+  }
+
+S7::method(ggplot_add, list(S7::class_list, class_ggplot)) <-
+  function(object, plot, object_name, ...) {
+    for (o in object) {
+      plot <- ggplot_add(o, plot, object_name)
+    }
+    plot
+  }
+
+S7::method(ggplot_add, list(S7::new_S3_class("by"), class_ggplot)) <-
+  function(object, plot, object_name, ...) {
+    ggplot_add(unclass(object), plot, object_name)
+  }
 
 new_layer_names <- function(layer, existing) {
 

R/theme.R

@@ -565,11 +565,6 @@ theme <- S7::new_class(
   constructor = theme
 )
 
-S7::method(ggplot_add, theme) <- function(object, plot, object_name, ...) {
-  plot$theme <- add_theme(plot$theme, object)
-  plot
-}
-
 #' @export
 #' @rdname is_tests
 is.theme <- function(x) S7::S7_inherits(x, theme)

tests/testthat/_snaps/prohibited-functions.md

@@ -52,9 +52,6 @@
       $geom_violin
       [1] "draw_quantiles"
       
-      $ggplot_add
-      [1] "object_name"
-      
       $ggproto
       [1] "_class"   "_inherit"