POC: double dispatch for ggplot_add()

DESCRIPTION

@@ -91,6 +91,7 @@ Collate:
     'compat-plyr.R'
     'utilities.R'
     'aes.R'
+    'all-classes.R'
     'utilities-checks.R'
     'legend-draw.R'
     'geom-.R'
@@ -197,9 +198,9 @@ Collate:
     'margins.R'
     'performance.R'
     'plot-build.R'
+    'plot.R'
     'plot-construction.R'
     'plot-last.R'
-    'plot.R'
     'position-.R'
     'position-collide.R'
     'position-dodge.R'

NAMESPACE

@@ -49,8 +49,6 @@ S3method(fortify,tbl_df)
 S3method(get_alt_text,ggplot)
 S3method(get_alt_text,ggplot_built)
 S3method(get_alt_text,gtable)
-S3method(ggplot,"function")
-S3method(ggplot,default)
 S3method(ggplot_build,ggplot)
 S3method(ggplot_gtable,ggplot_built)
 S3method(grid.draw,absoluteGrob)

R/all-classes.R

@@ -0,0 +1,11 @@
+# Class declarations for S7 dispatch.
+class_theme  <- S7::new_S3_class("theme")
+class_scale  <- S7::new_S3_class("Scale")
+class_labels <- S7::new_S3_class("labels")
+class_guides <- S7::new_S3_class("Guides")
+class_aes    <- S7::new_S3_class("uneval")
+class_coord  <- S7::new_S3_class("Coord")
+class_facet  <- S7::new_S3_class("Facet")
+class_by     <- S7::new_S3_class("by")
+class_layer  <- S7::new_S3_class("Layer")
+class_scales_list <- S7::new_S3_class("ScalesList")

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
@@ -91,79 +94,68 @@ add_ggplot <- function(p, object, objectname) {
 #' @export
 ggplot_add <- S7::new_generic("ggplot_add", c("object", "plot"))
 
-# Class declarations for S7 dispatch. If S7 gets implemented more broadly,
-# consider moving these to a new file.
-class_ggplot <- S7::new_S3_class("ggplot")
-class_theme  <- S7::new_S3_class("theme")
-class_scale  <- S7::new_S3_class("Scale")
-class_labels <- S7::new_S3_class("labels")
-class_guides <- S7::new_S3_class("Guides")
-class_aes    <- S7::new_S3_class("uneval")
-class_coord  <- S7::new_S3_class("Coord")
-class_facet  <- S7::new_S3_class("Facet")
-class_by     <- S7::new_S3_class("by")
-class_layer  <- S7::new_S3_class("Layer")
-
-S7::method(ggplot_add, list(S7::class_any, class_ggplot)) <-
+S7::method(ggplot_add, list(S7::class_any, ggplot)) <-
   function(object, plot, object_name) {
     cli::cli_abort("Can't add {.var {object_name}} to a {.cls ggplot} object.")
   }
 
 # Cannot currently double dispatch on NULL directly
 # replace `S7::new_S3_class("NULL")` with `NULL` when S7 version > 0.1.1
-S7::method(ggplot_add, list(S7::new_S3_class("NULL"), class_ggplot)) <-
+S7::method(ggplot_add, list(S7::new_S3_class("NULL"), ggplot)) <-
   function(object, plot, object_name) {
     plot
   }
 
-S7::method(ggplot_add, list(S7::class_data.frame, class_ggplot)) <-
+S7::method(ggplot_add, list(S7::class_data.frame, ggplot)) <-
   function(object, plot, object_name) {
     plot$data <- object
     plot
   }
 
-S7::method(ggplot_add, list(S7::class_function, class_ggplot)) <-
+S7::method(ggplot_add, list(S7::class_function, 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(class_theme, class_ggplot)) <-
+S7::method(ggplot_add, list(class_theme, ggplot)) <-
   function(object, plot, object_name) {
     plot$theme <- add_theme(plot$theme, object)
     plot
   }
 
-S7::method(ggplot_add, list(class_scale, class_ggplot)) <-
+S7::method(ggplot_add, list(class_scale, ggplot)) <-
   function(object, plot, object_name) {
     plot$scales$add(object)
     plot
   }
 
-S7::method(ggplot_add, list(class_labels, class_ggplot)) <-
+S7::method(ggplot_add, list(class_labels, ggplot)) <-
   function(object, plot, object_name) {
     update_labels(plot, object)
   }
 
-S7::method(ggplot_add, list(class_guides, class_ggplot)) <-
+S7::method(ggplot_add, list(class_guides, ggplot)) <-
   function(object, plot, object_name) {
     update_guides(plot, object)
   }
 
-S7::method(ggplot_add, list(class_aes, class_ggplot)) <-
+S7::method(ggplot_add, list(class_aes, ggplot)) <-
   function(object, plot, object_name) {
-    plot$mapping <- defaults(object, plot$mapping)
+    mapping <- defaults(object, plot$mapping)
     # defaults() doesn't copy class, so copy it.
-    class(plot$mapping) <- class(object)
+    class(mapping) <- class(object)
+    S7::prop(plot, "mapping") <- mapping
+
 
     labels <- make_labels(object)
     names(labels) <- names(object)
     update_labels(plot, labels)
   }
 
-S7::method(ggplot_add, list(class_coord, class_ggplot)) <-
+S7::method(ggplot_add, list(class_coord, 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.")
@@ -173,28 +165,28 @@ S7::method(ggplot_add, list(class_coord, class_ggplot)) <-
     plot
   }
 
-S7::method(ggplot_add, list(class_facet, class_ggplot)) <-
+S7::method(ggplot_add, list(class_facet, ggplot)) <-
   function(object, plot, object_name) {
     plot$facet <- object
     plot
   }
 
-S7::method(ggplot_add, list(S7::class_list, class_ggplot)) <-
+S7::method(ggplot_add, list(S7::class_list, ggplot)) <-
   function(object, plot, object_name) {
     for (o in object) {
       plot <- plot %+% o
     }
     plot
   }
 
-S7::method(ggplot_add, list(class_by, class_ggplot)) <-
+S7::method(ggplot_add, list(class_by, ggplot)) <-
   function(object, plot, object_name) {
-    S7::method(ggplot_add, list(class_list, class_ggplot))(
+    S7::method(ggplot_add, list(class_list, ggplot))(
       object, plot, object_name
     )
   }
 
-S7::method(ggplot_add, list(class_layer, class_ggplot)) <-
+S7::method(ggplot_add, list(class_layer, ggplot)) <-
   function(object, plot, object_name) {
     plot$layers <- append(plot$layers, object)
 

R/plot.R

@@ -1,3 +1,6 @@
+
+gg <- S7::new_class("gg", abstract = TRUE)
+
 #' Create a new ggplot
 #'
 #' `ggplot()` initializes a ggplot object. It can be used to
@@ -101,49 +104,67 @@
 #'     mapping = aes(x = group, y = group_mean), data = group_means_df,
 #'     colour = 'red', size = 3
 #'   )
-ggplot <- function(data = NULL, mapping = aes(), ...,
-                   environment = parent.frame()) {
-  UseMethod("ggplot")
-}
+ggplot <- S7::new_class(
+  name = "ggplot", parent = gg,
+  properties = list(
+    data        = S7::class_any,
+    layers      = S7::class_list,
+    scales      = class_scales_list,
+    guides      = class_guides,
+    mapping     = class_aes,
+    theme       = class_theme,
+    coordinates = class_coord,
+    facet       = class_facet,
+    labels      = S7::class_list,
+    plot_env    = S7::class_environment
+  ),
+  constructor = function(data = NULL, mapping = aes(), ...,
+                         environment = parent.frame()) {
 
-#' @export
-ggplot.default <- function(data = NULL, mapping = aes(), ...,
-                           environment = parent.frame()) {
-  if (!missing(mapping) && !inherits(mapping, "uneval")) {
-    cli::cli_abort(c(
-      "{.arg mapping} should be created with {.fn aes}.",
-      "x" = "You've supplied a {.cls {class(mapping)[1]}} object"
-    ))
-  }
+    if (!missing(mapping) && !inherits(mapping, "uneval")) {
+      cli::cli_abort(c(
+        "{.arg mapping} should be created with {.fn aes}.",
+        "x" = "You've supplied a {.cls {class(mapping)[1]}} object."
+      ))
+    }
 
-  data <- fortify(data, ...)
+    if (is.function(data)) {
+      cli::cli_abort(c(
+        "{.arg data} cannot be a function.",
+        "i" = "Have you misspelled the {.arg data} argument in {.fn ggplot}?"
+      ))
+    }
 
-  p <- structure(list(
-    data = data,
-    layers = list(),
-    scales = scales_list(),
-    guides = guides_list(),
-    mapping = mapping,
-    theme = list(),
-    coordinates = coord_cartesian(default = TRUE),
-    facet = facet_null(),
-    plot_env = environment
-  ), class = c("gg", "ggplot"))
+    data <- fortify(data, ...)
 
-  p$labels <- make_labels(mapping)
+    obj <- S7::new_object(
+      S7::S7_object(),
+      data    = data,
+      layers  = list(),
+      scales  = scales_list(),
+      guides  = guides_list(),
+      mapping = mapping,
+      theme   = theme(),
+      coordinates = coord_cartesian(default = TRUE),
+      facet   = facet_null(),
+      labels  = make_labels(mapping),
+      plot_env = environment
+    )
 
-  set_last_plot(p)
-  p
+    set_last_plot(obj)
+    obj
+  }
+)
+
+S7::method(`$`, ggplot) <- function(x, i) {
+  if (!S7::prop_exists(x, i)) {
+    return(NULL)
+  }
+  S7::prop(x, i)
 }
 
-#' @export
-ggplot.function <- function(data = NULL, mapping = aes(), ...,
-                            environment = parent.frame()) {
-  # Added to avoid functions end in ggplot.default
-  cli::cli_abort(c(
-    "{.arg data} cannot be a function.",
-    "i" = "Have you misspelled the {.arg data} argument in {.fn ggplot}"
-  ))
+S7::method(`$<-`, ggplot) <- function(x, ...) {
+  S7::`prop<-`(x, ...)
 }
 
 plot_clone <- function(plot) {

tests/testthat/_snaps/plot.md

@@ -1,12 +1,12 @@
 # ggplot() throws informative errors
 
     `mapping` should be created with `aes()`.
-    x You've supplied a <character> object
+    x You've supplied a <character> object.
 
 ---
 
     `data` cannot be a function.
-    i Have you misspelled the `data` argument in `ggplot()`
+    i Have you misspelled the `data` argument in `ggplot()`?
 
 # construction have user friendly errors