Implement <ggplot_built> as S7

Author: teunbrand

R/all-classes.R

@@ -5,6 +5,8 @@ class_guides <- S7::new_S3_class("Guides")
 class_coord  <- S7::new_S3_class("Coord")
 class_facet  <- S7::new_S3_class("Facet")
 class_layer  <- S7::new_S3_class("Layer")
+class_layout <- S7::new_S3_class("Layout")
 class_scales_list <- S7::new_S3_class("ScalesList")
 class_layout <- S7::new_S3_class("Layout")
 class_ggproto <- S7::new_S3_class("ggproto")
+class_gtable <- S7::new_S3_class("gtable")

R/facet-.R

@@ -399,9 +399,9 @@ vars <- function(...) {
 #' get_strip_labels(p + facet_grid(year ~ cyl))
 get_strip_labels <- function(plot = get_last_plot()) {
   plot   <- ggplot_build(plot)
-  layout <- plot$layout$layout
-  params <- plot$layout$facet_params
-  plot$plot@facet$format_strip_labels(layout, params)
+  layout <- plot@layout$layout
+  params <- plot@layout$facet_params
+  plot@plot@facet$format_strip_labels(layout, params)
 }
 
 # A "special" value, currently not used but could be used to determine

R/guides-.R

@@ -832,20 +832,20 @@ get_guide_data <- function(plot = get_last_plot(), aesthetic, panel = 1L) {
 
   if (!aesthetic %in% c("x", "y", "x.sec", "y.sec", "theta", "r")) {
     # Non position guides: check if aesthetic in colnames of key
-    keys <- lapply(plot$plot@guides$params, `[[`, "key")
+    keys <- lapply(plot@plot@guides$params, `[[`, "key")
     keep <- vapply(keys, function(x) any(colnames(x) %in% aesthetic), logical(1))
     keys <- switch(sum(keep) + 1, NULL, keys[[which(keep)]], keys[keep])
     return(keys)
   }
 
   # Position guides: find the right layout entry
   check_number_whole(panel)
-  layout <- plot$layout$layout
+  layout <- plot@layout$layout
   select <- layout[layout$PANEL == panel, , drop = FALSE]
   if (nrow(select) == 0) {
     return(NULL)
   }
-  params <- plot$layout$panel_params[select$PANEL][[1]]
+  params <- plot@layout$panel_params[select$PANEL][[1]]
 
   # If panel params don't have guides, we probably have old coord system
   # that doesn't use the guide system.

R/labels.R

@@ -220,18 +220,18 @@ ggtitle <- function(label, subtitle = waiver()) {
 get_labs <- function(plot = get_last_plot()) {
   plot <- ggplot_build(plot)
 
-  labs <- plot$plot@labels
+  labs <- plot@plot@labels
 
   xy_labs <- rename(
-    c(x = plot$layout$resolve_label(plot$layout$panel_scales_x[[1]], labs),
-      y = plot$layout$resolve_label(plot$layout$panel_scales_y[[1]], labs)),
+    c(x = plot@layout$resolve_label(plot@layout$panel_scales_x[[1]], labs),
+      y = plot@layout$resolve_label(plot@layout$panel_scales_y[[1]], labs)),
     c(x.primary = "x", x.secondary = "x.sec",
       y.primary = "y", y.secondary = "y.sec")
   )
 
   labs <- defaults(xy_labs, labs)
 
-  guides <- plot$plot@guides
+  guides <- plot@plot@guides
   if (length(guides$aesthetics) == 0) {
     return(labs)
   }
@@ -287,14 +287,14 @@ get_alt_text.ggplot <- function(p, ...) {
   }
   p@labels[["alt"]] <- NULL
   build <- ggplot_build(p)
-  build$plot@labels[["alt"]] <- alt
+  build@plot@labels[["alt"]] <- alt
   get_alt_text(build)
 }
 #' @export
 get_alt_text.ggplot_built <- function(p, ...) {
-  alt <- p$plot@labels[["alt"]] %||% ""
-  p$plot@labels[["alt"]] <- NULL
-  if (is.function(alt)) alt(p$plot) else alt
+  alt <- p@plot@labels[["alt"]] %||% ""
+  p@plot@labels[["alt"]] <- NULL
+  if (is.function(alt)) alt(p@plot) else alt
 }
 #' @export
 get_alt_text.gtable <- function(p, ...) {

R/plot-build.R

@@ -1,3 +1,14 @@
+#' @include plot.R
+
+class_ggplot_built <- S7::new_class(
+  "ggplot_built",
+  properties = list(
+    data = S7::class_list,
+    layout = class_layout,
+    plot = class_ggplot
+  )
+)
+
 #' Build ggplot for rendering.
 #'
 #' `ggplot_build()` takes the plot object, and performs all steps necessary
@@ -131,16 +142,13 @@ ggplot_build.ggplot <- function(plot) {
   # Consolidate alt-text
   plot@labels$alt <- get_alt_text(plot)
 
-  structure(
-    list(data = data, layout = layout, plot = plot),
-    class = "ggplot_built"
-  )
+  class_ggplot_built(data = data, layout = layout, plot = plot)
 }
 
 #' @export
 #' @rdname ggplot_build
 get_layer_data <- function(plot = get_last_plot(), i = 1L) {
-  ggplot_build(plot)$data[[i]]
+  ggplot_build(plot)@data[[i]]
 }
 #' @export
 #' @rdname ggplot_build
@@ -151,12 +159,12 @@ layer_data <- get_layer_data
 get_panel_scales <- function(plot = get_last_plot(), i = 1L, j = 1L) {
   b <- ggplot_build(plot)
 
-  layout <- b$layout$layout
+  layout <- b@layout$layout
   selected <- layout[layout$ROW == i & layout$COL == j, , drop = FALSE]
 
   list(
-    x = b$layout$panel_scales_x[[selected$SCALE_X]],
-    y = b$layout$panel_scales_y[[selected$SCALE_Y]]
+    x = b@layout$panel_scales_x[[selected$SCALE_X]],
+    y = b@layout$panel_scales_y[[selected$SCALE_Y]]
   )
 }
 
@@ -169,7 +177,7 @@ layer_scales <- get_panel_scales
 get_layer_grob <- function(plot = get_last_plot(), i = 1L) {
   b <- ggplot_build(plot)
 
-  b$plot@layers[[i]]$draw_geom(b$data[[i]], b$layout)
+  b@plot@layers[[i]]$draw_geom(b@data[[i]], b@layout)
 }
 
 #' @export
@@ -203,9 +211,9 @@ ggplot_gtable <- function(data) {
 
 #' @export
 ggplot_gtable.ggplot_built <- function(data) {
-  plot <- data$plot
-  layout <- data$layout
-  data <- data$data
+  plot <- data@plot
+  layout <- data@layout
+  data <- data@data
   theme <- plot@theme
 
   geom_grobs <- by_layer(function(l, d) l$draw_geom(d, layout), plot@layers, data, "converting geom to grob")

R/summarise-plot.R

@@ -62,8 +62,8 @@ NULL
 #' @rdname summarise_plot
 #' @export
 summarise_layout <- function(p) {
-  check_inherits(p, "ggplot_built")
-  l <- p$layout
+  check_inherits(p, "ggplot2::ggplot_built")
+  l <- p@layout
 
   layout <- l$layout
   layout <- data_frame0(
@@ -99,7 +99,7 @@ summarise_layout <- function(p) {
 #' @rdname summarise_plot
 #' @export
 summarise_coord <- function(p) {
-  check_inherits(p, "ggplot_built")
+  check_inherits(p, "ggplot2::ggplot_built")
 
   # Given a transform object, find the log base; if the transform object is
   # NULL, or if it's not a log transform, return NA.
@@ -112,23 +112,23 @@ summarise_coord <- function(p) {
   }
 
   list(
-    xlog = trans_get_log_base(p$layout$coord$trans$x),
-    ylog = trans_get_log_base(p$layout$coord$trans$y),
-    flip = inherits(p$layout$coord, "CoordFlip")
+    xlog = trans_get_log_base(p@layout$coord$trans$x),
+    ylog = trans_get_log_base(p@layout$coord$trans$y),
+    flip = inherits(p@layout$coord, "CoordFlip")
   )
 }
 
 
 #' @rdname summarise_plot
 #' @export
 summarise_layers <- function(p) {
-  check_inherits(p, "ggplot_built")
+  check_inherits(p, "ggplot2::ggplot_built")
 
   # Default mappings. Make sure it's a regular list instead of a mapping
   # object.
-  default_mapping <- unclass(p$plot@mapping)
+  default_mapping <- unclass(p@plot@mapping)
 
-  layer_mappings <- lapply(p$plot@layers, function(layer) {
+  layer_mappings <- lapply(p@plot@layers, function(layer) {
     defaults(layer$mapping, default_mapping)
   })
 

tests/testthat/_snaps/summarise-plot.md

@@ -1,12 +1,12 @@
 # summarise_*() throws appropriate errors
 
-    `p` must be a <ggplot_built> object, not the number 10.
+    `p` must be a <ggplot2::ggplot_built> object, not the number 10.
 
 ---
 
-    `p` must be a <ggplot_built> object, not the string "A".
+    `p` must be a <ggplot2::ggplot_built> object, not the string "A".
 
 ---
 
-    `p` must be a <ggplot_built> object, not `TRUE`.
+    `p` must be a <ggplot2::ggplot_built> object, not `TRUE`.
 

tests/testthat/helper-plot-data.R

@@ -2,17 +2,17 @@
 cdata <- function(plot) {
   pieces <- ggplot_build(plot)
 
-  lapply(pieces$data, function(d) {
+  lapply(pieces@data, function(d) {
     dapply(d, "PANEL", function(panel_data) {
-      scales <- pieces$layout$get_scales(panel_data$PANEL[1])
-      panel_params <- plot@coordinates$setup_panel_params(scales$x, scales$y, params = pieces$layout$coord_params)
+      scales <- pieces@layout$get_scales(panel_data$PANEL[1])
+      panel_params <- plot@coordinates$setup_panel_params(scales$x, scales$y, params = pieces@layout$coord_params)
       plot@coordinates$transform(panel_data, panel_params)
     })
   })
 }
 
 pranges <- function(plot) {
-  layout <- ggplot_build(plot)$layout
+  layout <- ggplot_build(plot)@layout
 
   x_ranges <- lapply(layout$panel_scales_x, function(scale) scale$get_limits())
   y_ranges <- lapply(layout$panel_scales_y, function(scale) scale$get_limits())

tests/testthat/test-aes.R

@@ -96,13 +96,13 @@ test_that("assignment methods pull unwrap constants from quosures", {
 
 test_that("quosures are squashed when creating default label for a mapping", {
   p <- ggplot(mtcars) + aes(!!quo(identity(!!quo(cyl))))
-  labels <- ggplot_build(p)$plot@labels
+  labels <- ggplot_build(p)@plot@labels
   expect_identical(labels$x, "identity(cyl)")
 })
 
 test_that("labelling doesn't cause error if aesthetic is NULL", {
   p <- ggplot(mtcars) + aes(x = NULL)
-  labels <- ggplot_build(p)$plot@labels
+  labels <- ggplot_build(p)@plot@labels
   expect_identical(labels$x, "x")
 })
 

tests/testthat/test-build.R

@@ -2,7 +2,7 @@
 df <- data_frame(x = 1:3, y = 3:1, z = letters[1:3])
 
 test_that("there is one data frame for each layer", {
-  nlayers <- function(x) length(ggplot_build(x)$data)
+  nlayers <- function(x) length(ggplot_build(x)@data)
 
   l1 <- ggplot(df, aes(x, y)) + geom_point()
   l2 <- ggplot(df, aes(x, y)) + geom_point() + geom_line()