POC: Boilerplate functions

DESCRIPTION

@@ -96,6 +96,9 @@ Collate:
     'geom-.R'
     'annotation-custom.R'
     'annotation-logticks.R'
+    'scale-type.R'
+    'layer.R'
+    'boilerplates.R'
     'geom-polygon.R'
     'geom-map.R'
     'annotation-map.R'
@@ -134,12 +137,14 @@ Collate:
     'geom-abline.R'
     'geom-rect.R'
     'geom-bar.R'
+    'geom-tile.R'
     'geom-bin2d.R'
     'geom-blank.R'
     'geom-boxplot.R'
     'geom-col.R'
     'geom-path.R'
     'geom-contour.R'
+    'geom-point.R'
     'geom-count.R'
     'geom-crossbar.R'
     'geom-segment.R'
@@ -159,15 +164,13 @@ Collate:
     'geom-jitter.R'
     'geom-label.R'
     'geom-linerange.R'
-    'geom-point.R'
     'geom-pointrange.R'
     'geom-quantile.R'
     'geom-rug.R'
     'geom-sf.R'
     'geom-smooth.R'
     'geom-spoke.R'
     'geom-text.R'
-    'geom-tile.R'
     'geom-violin.R'
     'geom-vline.R'
     'ggplot2-package.R'
@@ -186,7 +189,6 @@ Collate:
     'guide-colorbar.R'
     'guide-colorsteps.R'
     'guide-custom.R'
-    'layer.R'
     'guide-none.R'
     'guide-old.R'
     'guides-.R'
@@ -236,7 +238,6 @@ Collate:
     'scale-shape.R'
     'scale-size.R'
     'scale-steps.R'
-    'scale-type.R'
     'scale-view.R'
     'scale-viridis.R'
     'scales-.R'

NAMESPACE

@@ -16,6 +16,7 @@ S3method(as.data.frame,mapped_discrete)
 S3method(as.list,ggproto)
 S3method(autolayer,default)
 S3method(autoplot,default)
+S3method(boilerplate,Geom)
 S3method(c,mapped_discrete)
 S3method(drawDetails,zeroGrob)
 S3method(element_grob,element_blank)
@@ -297,6 +298,7 @@ export(autolayer)
 export(autoplot)
 export(benchplot)
 export(binned_scale)
+export(boilerplate)
 export(borders)
 export(calc_element)
 export(check_device)

R/boilerplates.R

@@ -0,0 +1,125 @@
+#' @include layer.R
+#' @include scale-type.R
+NULL
+
+#' Produce boilerplate constructors
+#'
+#' The `boilerplate()` functions sets up a user-facing constructor for ggproto
+#' classes. Currently, `boilerplate()` is implemented for `Geom` classes.
+#'
+#' @param x An object to setup a constructor for.
+#' @param ... Name-value pairs to use as additional arguments in the
+#'   constructor. For layers, these are passed on to [`layer(params)`][layer()].
+#' @param checks A list of calls to be evaluated before construction of the
+#'   object, such as one constructed with [`exprs()`][rlang::exprs()].
+#' @param env An environment to search for the object.
+#'
+#' @return A function
+#' @export
+#' @keywords internal
+#'
+#' @examples
+#' # For testing purposes, a geom that returns grobs
+#' GeomTest <- ggproto(
+#'   "GeomTest", Geom,
+#'   draw_group = function(..., grob = grid::pointsGrob()) {
+#'     return(grob)
+#'   }
+#' )
+#' # Creating a constructor
+#' geom_test <- boilerplate(GeomTest)
+#'
+#' # Note that `grob` is automatically an argument to the function
+#' names(formals(geom_test))
+#'
+#' # Use in a plot
+#' set.seed(1234)
+#' p <- ggplot(mtcars, aes(disp, mpg))
+#' p + geom_test()
+#' p + geom_test(grob = grid::circleGrob())
+boilerplate <- function(x, ...) {
+  UseMethod("boilerplate")
+}
+
+#' @export
+#' @rdname boilerplate
+boilerplate.Geom <- function(x, ..., checks = NULL, env = caller_env()) {
+
+  # Check that we can independently find the geom
+  geom <- gsub("^geom_", "", snake_class(x))
+  check_subclass(geom, "Geom", env = env)
+
+  # Split additional arguments into required and extra ones
+  args <- enexprs(...)
+  fixed_fmls_names <- c("mapping", "data", "stat", "position", "...",
+                        "na.rm", "show.legend", "inherit.aes")
+  extra_args <- setdiff(names(args), fixed_fmls_names)
+  if ("geom" %in% extra_args) {
+    cli::cli_abort("{.arg geom} is a reserved argument.")
+  }
+
+  # Fill in values for parameters from draw functions
+  known_params <-
+    unique(c(names(args), fixed_fmls_names, "flipped_aes", x$aesthetics()))
+  missing_params <- setdiff(x$parameters(), known_params)
+  if (length(missing_params) > 0) {
+    draw_args <- ggproto_formals(x$draw_panel)
+    if ("..." %in% names(draw_args)) {
+      draw_args <- ggproto_formals(x$draw_group)
+    }
+    params <- intersect(missing_params, names(draw_args))
+    extra_args <- c(extra_args, params)
+    for (param in params) {
+      if (!identical(draw_args[[param]], quote(expr = ))) {
+        args[param] <- draw_args[param]
+      }
+    }
+    missing_params <- setdiff(missing_params, names(args))
+    if (length(missing_params) > 0) {
+      cli::cli_warn(
+        "In {.fn geom_{geom}}: please consider providing default values for: \\
+        {missing_params}."
+      )
+    }
+  }
+
+  # Build function formals
+  fmls <- pairlist2(
+    mapping  = args$mapping,
+    data     = args$data,
+    stat     = args$stat %||% "identity",
+    position = args$position %||% "identity",
+    `...` = missing_arg(),
+    !!!args[extra_args],
+    na.rm    = args$na.rm %||% FALSE,
+    show.legend = args$show.legend %||% NA,
+    inherit.aes = args$inherit.aes %||% TRUE
+  )
+
+  # Construct call for the 'layer(params)' argument
+  params <- exprs(!!!syms(c("na.rm", extra_args)), .named = TRUE)
+  params <- call2("list2", !!!params, quote(...))
+
+  # Construct rest of 'layer()' call
+  layer_args <- syms(setdiff(fixed_fmls_names, c("...", "na.rm")))
+  layer_args <- append(layer_args, list(geom = geom), after = 2)
+  layer_args <- exprs(!!!layer_args, params = !!params, .named = TRUE)
+  body <- call2("layer", !!!layer_args)
+
+  # Prepend any checks
+  if (!missing(checks)) {
+    lang <- vapply(checks, is_call, logical(1))
+    if (!all(lang)) {
+      cli::cli_abort(
+        "{.arg checks} must be a list of calls, such as one constructed \\
+        with {.fn rlang::exprs}."
+      )
+    }
+    body <- call2("{", !!!checks, body)
+  }
+
+  # We encapsulate rlang::list2
+  new_env <- new_environment(list(list2 = list2), env)
+
+  new_function(fmls, body, env = new_env)
+}

R/geom-bar.R

@@ -1,3 +1,45 @@
+#' @rdname ggplot2-ggproto
+#' @format NULL
+#' @usage NULL
+#' @export
+#' @include geom-rect.R
+GeomBar <- ggproto("GeomBar", GeomRect,
+  required_aes = c("x", "y"),
+
+  # These aes columns are created by setup_data(). They need to be listed here so
+  # that GeomRect$handle_na() properly removes any bars that fall outside the defined
+  # limits, not just those for which x and y are outside the limits
+  non_missing_aes = c("xmin", "xmax", "ymin", "ymax"),
+
+  default_aes = aes(!!!GeomRect$default_aes, width = NULL),
+
+  setup_params = function(data, params) {
+    params$flipped_aes <- has_flipped_aes(data, params)
+    params
+  },
+
+  extra_params = c("just", "na.rm", "orientation"),
+
+  setup_data = function(data, params) {
+    data$flipped_aes <- params$flipped_aes
+    data <- flip_data(data, params$flipped_aes)
+    data$width <- data$width %||%
+      params$width %||% (min(vapply(
+        split(data$x, data$PANEL, drop = TRUE),
+        resolution, numeric(1), zero = FALSE
+      )) * 0.9)
+    data$just <- params$just %||% 0.5
+    data <- transform(data,
+      ymin = pmin(y, 0), ymax = pmax(y, 0),
+      xmin = x - width * just, xmax = x + width * (1 - just),
+      width = NULL, just = NULL
+    )
+    flip_data(data, params$flipped_aes)
+  },
+
+  rename_size = TRUE
+)
+
 #' Bar charts
 #'
 #' There are two types of bar charts: `geom_bar()` and `geom_col()`.
@@ -48,6 +90,8 @@
 #' @param geom,stat Override the default connection between `geom_bar()` and
 #'   `stat_count()`. For more information about overriding these connections,
 #'   see how the [stat][layer_stats] and [geom][layer_geoms] arguments work.
+#' @param lineend Line end style (round, butt, square).
+#' @param linejoin Line join style (round, mitre, bevel).
 #' @examples
 #' # geom_bar is designed to make it easy to create bar charts that show
 #' # counts (or sums of weights)
@@ -92,69 +136,4 @@
 #' ggplot(df, aes(x, y)) + geom_col(just = 0.5)
 #' # Columns begin on the first day of the month
 #' ggplot(df, aes(x, y)) + geom_col(just = 1)
-geom_bar <- function(mapping = NULL, data = NULL,
-                     stat = "count", position = "stack",
-                     ...,
-                     just = 0.5,
-                     na.rm = FALSE,
-                     orientation = NA,
-                     show.legend = NA,
-                     inherit.aes = TRUE) {
-  layer(
-    data = data,
-    mapping = mapping,
-    stat = stat,
-    geom = GeomBar,
-    position = position,
-    show.legend = show.legend,
-    inherit.aes = inherit.aes,
-    params = list2(
-      just = just,
-      na.rm = na.rm,
-      orientation = orientation,
-      ...
-    )
-  )
-}
-
-#' @rdname ggplot2-ggproto
-#' @format NULL
-#' @usage NULL
-#' @export
-#' @include geom-rect.R
-GeomBar <- ggproto("GeomBar", GeomRect,
-  required_aes = c("x", "y"),
-
-  # These aes columns are created by setup_data(). They need to be listed here so
-  # that GeomRect$handle_na() properly removes any bars that fall outside the defined
-  # limits, not just those for which x and y are outside the limits
-  non_missing_aes = c("xmin", "xmax", "ymin", "ymax"),
-
-  default_aes = aes(!!!GeomRect$default_aes, width = NULL),
-
-  setup_params = function(data, params) {
-    params$flipped_aes <- has_flipped_aes(data, params)
-    params
-  },
-
-  extra_params = c("just", "na.rm", "orientation"),
-
-  setup_data = function(data, params) {
-    data$flipped_aes <- params$flipped_aes
-    data <- flip_data(data, params$flipped_aes)
-    data$width <- data$width %||%
-      params$width %||% (min(vapply(
-        split(data$x, data$PANEL, drop = TRUE),
-        resolution, numeric(1), zero = FALSE
-      )) * 0.9)
-    data$just <- params$just %||% 0.5
-    data <- transform(data,
-      ymin = pmin(y, 0), ymax = pmax(y, 0),
-      xmin = x - width * just, xmax = x + width * (1 - just),
-      width = NULL, just = NULL
-    )
-    flip_data(data, params$flipped_aes)
-  },
-
-  rename_size = TRUE
-)
+geom_bar <- boilerplate(GeomBar, stat = "count", position = "stack", just = 0.5)

R/geom-bin2d.R

@@ -1,3 +1,6 @@
+#' @include geom-tile.R
+NULL
+
 #' Heatmap of 2d bin counts
 #'
 #' Divides the plane into rectangles, counts the number of cases in
@@ -14,6 +17,8 @@
 #'   `geom_bin_2d()` and `stat_bin_2d()`. For more information about overriding
 #'   these connections, see how the [stat][layer_stats] and [geom][layer_geoms]
 #'   arguments work.
+#' @param lineend Line end style (round, butt, square).
+#' @param linejoin Line join style (round, mitre, bevel).
 #' @seealso [stat_bin_hex()] for hexagonal binning
 #' @examples
 #' d <- ggplot(diamonds, aes(x, y)) + xlim(4, 10) + ylim(4, 10)
@@ -26,27 +31,7 @@
 #'
 #' # Or by specifying the width of the bins
 #' d + geom_bin_2d(binwidth = c(0.1, 0.1))
-geom_bin_2d <- function(mapping = NULL, data = NULL,
-                       stat = "bin2d", position = "identity",
-                       ...,
-                       na.rm = FALSE,
-                       show.legend = NA,
-                       inherit.aes = TRUE) {
-
-  layer(
-    data = data,
-    mapping = mapping,
-    stat = stat,
-    geom = GeomTile,
-    position = position,
-    show.legend = show.legend,
-    inherit.aes = inherit.aes,
-    params = list2(
-      na.rm = na.rm,
-      ...
-    )
-  )
-}
+geom_bin_2d <- boilerplate(GeomTile, stat = "bin2d")
 
 #' @export
 #' @rdname geom_bin_2d

R/geom-col.R

@@ -1,28 +1,6 @@
 #' @export
 #' @rdname geom_bar
-geom_col <- function(mapping = NULL, data = NULL,
-                     position = "stack",
-                     ...,
-                     just = 0.5,
-                     na.rm = FALSE,
-                     show.legend = NA,
-                     inherit.aes = TRUE) {
-
-  layer(
-    data = data,
-    mapping = mapping,
-    stat = "identity",
-    geom = GeomCol,
-    position = position,
-    show.legend = show.legend,
-    inherit.aes = inherit.aes,
-    params = list2(
-      just = just,
-      na.rm = na.rm,
-      ...
-    )
-  )
-}
+geom_col <- boilerplate(GeomBar, position = "stack", just = 0.5)
 
 #' @rdname ggplot2-ggproto
 #' @format NULL