Better error messages for bad geom, stat, and position

Fixes #2401

Author: hadley

NEWS.md

@@ -191,6 +191,9 @@ up correct aspect ratio, and draws a graticule.
 
 * In most cases, using `%>%` instead of `+` should generate an informative
   error (#2400).
+  
+* `layer()` gives considerably better error messages for incorrectly specified
+  `geom`, `stat`, or `position` (#2401).
 
 * In all layers that use it, `linemitre` now defaults to 10 (instead of 1)
   to better match base R.

R/fortify.r

@@ -23,7 +23,7 @@ fortify.function <- function(model, data, ...) model
 fortify.default <- function(model, data, ...) {
   msg <- paste0(
     "`data` must be a data frame, or other object coercible by `fortify()`, ",
-    "not an object of class ", paste(class(model), collapse = "/")
+    "not ", obj_desc(x)
   )
   if (inherits(model, "uneval")) {
     msg <- paste0(

R/geom-defaults.r

@@ -12,31 +12,17 @@
 #' update_geom_defaults("point", list(colour = "black"))
 #' @rdname update_defaults
 update_geom_defaults <- function(geom, new) {
-  if (is.character(geom)) {
-    g <- find_subclass("Geom", geom, parent.frame())
-  } else if (inherits(geom, "Geom")) {
-    g <- geom
-  } else {
-    stop('`geom` must be a string (like "point") or a Geom object (like GeomPoint).',
-      call. = FALSE)
-  }
-
+  g <- check_subclass(geom, "Geom", env = parent.frame())
   old <- g$default_aes
   g$default_aes <- defaults(rename_aes(new), old)
+  invisible()
 }
 
 #' @rdname update_defaults
 #' @export
 update_stat_defaults <- function(stat, new) {
-  if (is.character(stat)) {
-    g <- find_subclass("Stat", stat, parent.frame())
-  } else if (inherits(stat, "Stat")) {
-    g <- stat
-  } else {
-    stop('`stat` must be a string (like "point") or a Stat object (like StatBin).',
-      call. = FALSE)
-  }
-
+  g <- check_subclass(stat, "Stat", env = parent.frame())
   old <- g$default_aes
   g$default_aes <- defaults(rename_aes(new), old)
+  invisible()
 }

R/layer.r

@@ -89,12 +89,9 @@ layer <- function(geom = NULL, stat = NULL,
     mapping <- validate_mapping(mapping)
   }
 
-  if (is.character(geom))
-    geom <- find_subclass("Geom", geom, parent.frame())
-  if (is.character(stat))
-    stat <- find_subclass("Stat", stat, parent.frame())
-  if (is.character(position))
-    position <- find_subclass("Position", position, parent.frame())
+  geom <- check_subclass(geom, "Geom", env = parent.frame())
+  stat <- check_subclass(stat, "Stat", env = parent.frame())
+  position <- check_subclass(position, "Position", env = parent.frame())
 
   # Special case for na.rm parameter needed by all layers
   if (is.null(params$na.rm)) {
@@ -344,15 +341,51 @@ Layer <- ggproto("Layer", NULL,
 is.layer <- function(x) inherits(x, "Layer")
 
 
-find_subclass <- function(super, class, env) {
-  name <- paste0(super, camelize(class, first = TRUE))
-  obj <- find_global(name, env = env)
 
-  if (is.null(obj)) {
-    stop("No ", tolower(super), " called '", class, "'.", call. = FALSE)
-  } else if (!inherits(obj, super)) {
-    stop("Found object is not a ", tolower(super), ".", call. = FALSE)
+check_subclass <- function(x, subclass,
+                           argname = tolower(subclass),
+                           env = parent.frame()) {
+  if (inherits(x, subclass)) {
+    x
+  } else if (is.character(x) && length(x) == 1) {
+    name <- paste0(subclass, camelize(x, first = TRUE))
+    obj <- find_global(name, env = env)
+
+    if (is.null(obj) || !inherits(obj, subclass)) {
+      stop("Can't find `", argname, "` called \"", x, "\"", call. = FALSE)
+    } else {
+      obj
+    }
+  } else {
+    stop(
+      "`", argname, "` must be either a string or a ", subclass, " object, ",
+      "not ", obj_desc(x),
+      call. = FALSE
+    )
   }
+}
 
-  obj
+obj_desc <- function(x) {
+  if (isS4(x)) {
+    paste0("an S4 object with class ", class(x)[[1]])
+  } else if (is.object(x)) {
+    if (is.data.frame(x)) {
+      "a data frame"
+    } else if (is.factor(x)) {
+      "a factor"
+    } else {
+      paste0("an S3 object with class ", paste(class(x), collapse = "/"))
+    }
+  } else {
+    switch(typeof(x),
+      "NULL" = "a NULL",
+      character = "a character vector",
+      integer = "an integer vector",
+      logical = "a logical vector",
+      double = "a numeric vector",
+      list = "a list",
+      closure = "a function",
+      paste0("a base object of type", typeof(x))
+    )
+  }
 }

R/utilities-help.r

@@ -1,8 +1,8 @@
 
 rd_aesthetics <- function(type, name) {
   obj <- switch(type,
-    geom = find_subclass("Geom", name, globalenv()),
-    stat = find_subclass("Stat", name, globalenv())
+    geom = check_subclass(name, "Geom", env = globalenv()),
+    stat = check_subclass(name, "Stat", env = globalenv())
   )
   aes <- rd_aesthetics_item(obj)