Chained errors with contextual info in layers (#4856)

Author: thomasp85

R/ggproto.r

@@ -153,7 +153,7 @@ fetch_ggproto <- function(x, name) {
     return(res)
   }
 
-  make_proto_method(x, res)
+  make_proto_method(x, res, name)
 }
 
 #' @export
@@ -163,20 +163,23 @@ fetch_ggproto <- function(x, name) {
     return(res)
   }
 
-  make_proto_method(.subset2(x, "self"), res)
+  make_proto_method(.subset2(x, "self"), res, name)
 }
 
-make_proto_method <- function(self, f) {
+make_proto_method <- function(self, f, name) {
   args <- formals(f)
   # is.null is a fast path for a common case; the %in% check is slower but also
   # catches the case where there's a `self = NULL` argument.
   has_self  <- !is.null(args[["self"]]) || "self"  %in% names(args)
 
+  # We assign the method with its correct name and construct a call to it to
+  # make errors reported as coming from the method name rather than `f()`
+  assign(name, f, envir = environment())
+  args <- list(quote(...))
   if (has_self) {
-    fun <- function(...) f(..., self = self)
-  } else {
-    fun <- function(...) f(...)
+    args$self <- quote(self)
   }
+  fun <- inject(function(...) !!call2(name, !!!args))
 
   class(fun) <- "ggproto_method"
   fun

R/layer-sf.R

@@ -13,6 +13,7 @@ layer_sf <- function(geom = NULL, stat = NULL,
                      position = NULL, params = list(),
                      inherit.aes = TRUE, check.aes = TRUE, check.param = TRUE,
                      show.legend = NA) {
+  call_env <- caller_env()
   if (is.character(show.legend)) {
     legend_key_type <- show.legend
     show.legend <- TRUE
@@ -21,7 +22,10 @@ layer_sf <- function(geom = NULL, stat = NULL,
   }
 
   # inherit from LayerSf class to add `legend_key_type` slot
-  layer_class <- ggproto(NULL, LayerSf, legend_key_type = legend_key_type)
+  layer_class <- ggproto(NULL, LayerSf,
+    constructor = frame_call(call_env),
+    legend_key_type = legend_key_type
+  )
 
   layer(
     geom = geom, stat = stat, data = data, mapping = mapping,

R/layer.r

@@ -140,7 +140,10 @@ layer <- function(geom = NULL, stat = NULL,
   # adjust the legend draw key if requested
   geom <- set_draw_key(geom, key_glyph)
 
+  fr_call <- layer_class$constructor %||% frame_call(call_env)
+
   ggproto("LayerInstance", layer_class,
+    constructor = fr_call,
     geom = geom,
     geom_params = geom_params,
     stat = stat,
@@ -169,6 +172,7 @@ validate_mapping <- function(mapping, call = caller_env()) {
 }
 
 Layer <- ggproto("Layer", NULL,
+  constructor = NULL,
   geom = NULL,
   geom_params = NULL,
   stat = NULL,
@@ -328,7 +332,7 @@ Layer <- ggproto("Layer", NULL,
       issues <- paste0("{.code ", nondata_stat_cols, " = ", as_label(aesthetics[[nondata_stat_cols]]), "}")
       names(issues) <- rep("x", length(issues))
       cli::cli_abort(c(
-        "Aesthetics are not valid computed stats.",
+        "Aesthetics must be valid computed stats.",
         "x" = "The following aesthetics are invalid:",
         issues,
         "i" = "Did you map your stat in the wrong layer?"

R/plot-build.r

@@ -35,27 +35,19 @@ ggplot_build.ggplot <- function(plot) {
   data <- rep(list(NULL), length(layers))
 
   scales <- plot$scales
-  # Apply function to layer and matching data
-  by_layer <- function(f) {
-    out <- vector("list", length(data))
-    for (i in seq_along(data)) {
-      out[[i]] <- f(l = layers[[i]], d = data[[i]])
-    }
-    out
-  }
 
   # Allow all layers to make any final adjustments based
   # on raw input data and plot info
-  data <- by_layer(function(l, d) l$layer_data(plot$data))
-  data <- by_layer(function(l, d) l$setup_layer(d, plot))
+  data <- by_layer(function(l, d) l$layer_data(plot$data), layers, data, "computing layer data")
+  data <- by_layer(function(l, d) l$setup_layer(d, plot), layers, data, "setting up layer")
 
   # Initialise panels, add extra data for margins & missing faceting
   # variables, and add on a PANEL variable to data
   layout <- create_layout(plot$facet, plot$coordinates)
   data <- layout$setup(data, plot$data, plot$plot_env)
 
   # Compute aesthetics to produce data with generalised variable names
-  data <- by_layer(function(l, d) l$compute_aesthetics(d, plot))
+  data <- by_layer(function(l, d) l$compute_aesthetics(d, plot), layers, data, "computing aesthetics")
 
   # Transform all scales
   data <- lapply(data, scales_transform_df, scales = scales)
@@ -69,17 +61,17 @@ ggplot_build.ggplot <- function(plot) {
   data <- layout$map_position(data)
 
   # Apply and map statistics
-  data <- by_layer(function(l, d) l$compute_statistic(d, layout))
-  data <- by_layer(function(l, d) l$map_statistic(d, plot))
+  data <- by_layer(function(l, d) l$compute_statistic(d, layout), layers, data, "computing stat")
+  data <- by_layer(function(l, d) l$map_statistic(d, plot), layers, data, "mapping stat to aesthetics")
 
   # Make sure missing (but required) aesthetics are added
   scales_add_missing(plot, c("x", "y"), plot$plot_env)
 
   # Reparameterise geoms from (e.g.) y and width to ymin and ymax
-  data <- by_layer(function(l, d) l$compute_geom_1(d))
+  data <- by_layer(function(l, d) l$compute_geom_1(d), layers, data, "setting up geom")
 
   # Apply position adjustments
-  data <- by_layer(function(l, d) l$compute_position(d, layout))
+  data <- by_layer(function(l, d) l$compute_position(d, layout), layers, data, "computing position")
 
   # Reset position scales, then re-train and map.  This ensures that facets
   # have control over the range of a plot: is it generated from what is
@@ -97,10 +89,10 @@ ggplot_build.ggplot <- function(plot) {
   }
 
   # Fill in defaults etc.
-  data <- by_layer(function(l, d) l$compute_geom_2(d))
+  data <- by_layer(function(l, d) l$compute_geom_2(d), layers, data, "setting up geom aesthetics")
 
   # Let layer stat have a final say before rendering
-  data <- by_layer(function(l, d) l$finish_statistics(d))
+  data <- by_layer(function(l, d) l$finish_statistics(d), layers, data, "finishing layer stat")
 
   # Let Layout modify data before rendering
   data <- layout$finish_data(data)
@@ -168,7 +160,7 @@ ggplot_gtable.ggplot_built <- function(data) {
   data <- data$data
   theme <- plot_theme(plot)
 
-  geom_grobs <- Map(function(l, d) l$draw_geom(d, layout), plot$layers, data)
+  geom_grobs <- by_layer(function(l, d) l$draw_geom(d, layout), plot$layers, data, "converting geom to grob")
   layout$setup_panel_guides(plot$guides, plot$layers, plot$mapping)
   plot_table <- layout$render(geom_grobs, data, theme, plot$labels)
 
@@ -419,3 +411,18 @@ ggplot_gtable.ggplot_built <- function(data) {
 ggplotGrob <- function(x) {
   ggplot_gtable(ggplot_build(x))
 }
+
+# Apply function to layer and matching data
+by_layer <- function(f, layers, data, step = NULL) {
+  ordinal <- label_ordinal()
+  out <- vector("list", length(data))
+  try_fetch(
+    for (i in seq_along(data)) {
+      out[[i]] <- f(l = layers[[i]], d = data[[i]])
+    },
+    error = function(cnd) {
+      cli::cli_abort(c("Problem while {step}.", "i" = "Error occurred in the {ordinal(i)} layer."), call = I(layers[[i]]$constructor), parent = cnd)
+    }
+  )
+  out
+}

tests/testthat/_snaps/annotate.md

@@ -1,10 +1,16 @@
 # annotation_raster() and annotation_custom() requires cartesian coordinates
 
-    `annotation_raster()` only works with `coord_cartesian()`
+    Problem while converting geom to grob.
+    i Error occurred in the 1st layer.
+    Caused by error in `draw_panel()`:
+    ! `annotation_raster()` only works with `coord_cartesian()`
 
 ---
 
-    `annotation_custom()` only works with `coord_cartesian()`
+    Problem while converting geom to grob.
+    i Error occurred in the 1st layer.
+    Caused by error in `draw_panel()`:
+    ! `annotation_custom()` only works with `coord_cartesian()`
 
 # annotation_map() checks the input data
 

tests/testthat/_snaps/geom-.md

@@ -1,6 +1,9 @@
 # aesthetic checking in geom throws correct errors
 
-    Aesthetic modifiers returned invalid values
+    Problem while setting up geom aesthetics.
+    i Error occurred in the 1st layer.
+    Caused by error in `use_defaults()`:
+    ! Aesthetic modifiers returned invalid values
     x The following mappings are invalid
     x `colour = after_scale(data)`
     i Did you map the modifier in the wrong layer?

tests/testthat/_snaps/geom-dotplot.md

@@ -5,12 +5,12 @@
 # weight aesthetic is checked
 
     Computation failed in `stat_bindot()`
-    Caused by error in `f()`:
+    Caused by error in `compute_group()`:
     ! Weights must be nonnegative integers.
 
 ---
 
     Computation failed in `stat_bindot()`
-    Caused by error in `f()`:
+    Caused by error in `compute_group()`:
     ! Weights must be nonnegative integers.
 

tests/testthat/_snaps/geom-linerange.md

@@ -1,4 +1,7 @@
 # geom_linerange request the right aesthetics
 
-    `geom_linerange()` requires the following missing aesthetics: ymax or xmin and xmax
+    Problem while setting up geom.
+    i Error occurred in the 1st layer.
+    Caused by error in `compute_geom_1()`:
+    ! `geom_linerange()` requires the following missing aesthetics: ymax or xmin and xmax
 

tests/testthat/_snaps/geom-path.md

@@ -1,4 +1,7 @@
 # geom_path() throws meaningful error on bad combination of varying aesthetics
 
-    `geom_path()` can't have varying colour, size, and/or alpha along the line when linetype isn't solid
+    Problem while converting geom to grob.
+    i Error occurred in the 1st layer.
+    Caused by error in `draw_panel()`:
+    ! `geom_path()` can't have varying colour, size, and/or alpha along the line when linetype isn't solid
 

tests/testthat/_snaps/geom-raster.md

@@ -16,5 +16,8 @@
 
 ---
 
-    `geom_raster()` only works with `coord_cartesian()`
+    Problem while converting geom to grob.
+    i Error occurred in the 1st layer.
+    Caused by error in `draw_panel()`:
+    ! `geom_raster()` only works with `coord_cartesian()`