Move error signalling to rlang::abort() (#3526)

DESCRIPTION

@@ -21,6 +21,7 @@ Depends:
     R (>= 3.2)
 Imports: 
     digest,
+    glue,
     grDevices,
     grid,
     gtable (>= 0.1.1),

NAMESPACE

@@ -643,6 +643,8 @@ import(grid)
 import(gtable)
 import(rlang)
 import(scales)
+importFrom(glue,glue)
+importFrom(glue,glue_collapse)
 importFrom(stats,setNames)
 importFrom(tibble,tibble)
 importFrom(utils,.DollarNames)

R/aes-evaluation.r

@@ -121,7 +121,7 @@ is_calculated <- function(x) {
   } else if (is.pairlist(x)) {
     FALSE
   } else {
-    stop("Unknown input:", class(x)[1])
+    abort(glue("Unknown input: {class(x)[1]}"))
   }
 }
 is_scaled <- function(x) {
@@ -162,7 +162,7 @@ strip_dots <- function(expr) {
     # For list of aesthetics
     lapply(expr, strip_dots)
   } else {
-    stop("Unknown input:", class(expr)[1])
+    abort(glue("Unknown input: {class(expr)[1]}"))
   }
 }
 

R/aes.r

@@ -102,7 +102,9 @@ new_aesthetic <- function(x, env = globalenv()) {
   x
 }
 new_aes <- function(x, env = globalenv()) {
-  stopifnot(is.list(x))
+  if (!is.list(x)) {
+    abort("`x` must be a list")
+  }
   x <- lapply(x, new_aesthetic, env = env)
   structure(x, class = "uneval")
 }
@@ -168,9 +170,7 @@ rename_aes <- function(x) {
   duplicated_names <- names(x)[duplicated(names(x))]
   if (length(duplicated_names) > 0L) {
     duplicated_message <- paste0(unique(duplicated_names), collapse = ", ")
-    warning(
-      "Duplicated aesthetics after name standardisation: ", duplicated_message, call. = FALSE
-    )
+    warn(glue("Duplicated aesthetics after name standardisation: {duplicated_message}"))
   }
   x
 }
@@ -270,8 +270,7 @@ aes_ <- function(x, y, ...) {
     } else if (is.call(x) || is.name(x) || is.atomic(x)) {
       new_aesthetic(x, caller_env)
     } else {
-      stop("Aesthetic must be a one-sided formula, call, name, or constant.",
-        call. = FALSE)
+      abort("Aesthetic must be a one-sided formula, call, name, or constant.")
     }
   }
   mapping <- lapply(mapping, as_quosure_aes)
@@ -327,11 +326,11 @@ aes_all <- function(vars) {
 #' @keywords internal
 #' @export
 aes_auto <- function(data = NULL, ...) {
-  warning("aes_auto() is deprecated", call. = FALSE)
+  warn("aes_auto() is deprecated")
 
   # detect names of data
   if (is.null(data)) {
-    stop("aes_auto requires data.frame or names of data.frame.")
+    abort("aes_auto requires data.frame or names of data.frame.")
   } else if (is.data.frame(data)) {
     vars <- names(data)
   } else {
@@ -380,11 +379,7 @@ warn_for_aes_extract_usage_expr <- function(x, data, env = emptyenv()) {
   if (is_call(x, "[[") || is_call(x, "$")) {
     if (extract_target_is_likely_data(x, data, env)) {
       good_usage <- alternative_aes_extract_usage(x)
-      warning(
-        "Use of `", format(x), "` is discouraged. ",
-        "Use `", good_usage,  "` instead.",
-        call. = FALSE
-      )
+      warn(glue("Use of `{format(x)}` is discouraged. Use `{good_usage}` instead."))
     }
   } else if (is.call(x)) {
     lapply(x, warn_for_aes_extract_usage_expr, data, env)
@@ -398,7 +393,7 @@ alternative_aes_extract_usage <- function(x) {
   } else if (is_call(x, "$")) {
     as.character(x[[3]])
   } else {
-    stop("Don't know how to get alternative usage for `", format(x), "`", call. = FALSE)
+    abort(glue("Don't know how to get alternative usage for `{format(x)}`"))
   }
 }
 

R/annotation-custom.r

@@ -71,8 +71,7 @@ GeomCustomAnn <- ggproto("GeomCustomAnn", Geom,
   draw_panel = function(data, panel_params, coord, grob, xmin, xmax,
                         ymin, ymax) {
     if (!inherits(coord, "CoordCartesian")) {
-      stop("annotation_custom only works with Cartesian coordinates",
-        call. = FALSE)
+      abort("annotation_custom only works with Cartesian coordinates")
     }
     corners <- new_data_frame(list(x = c(xmin, xmax), y = c(ymin, ymax)), n = 2)
     data <- coord$transform(corners, panel_params)

R/annotation-map.r

@@ -31,11 +31,15 @@ NULL
 #' }
 annotation_map <- function(map, ...) {
   # Get map input into correct form
-  stopifnot(is.data.frame(map))
+  if (!is.data.frame(map)) {
+    abort("`map` must be a data.frame")
+  }
   if (!is.null(map$lat)) map$y <- map$lat
   if (!is.null(map$long)) map$x <- map$long
   if (!is.null(map$region)) map$id <- map$region
-  stopifnot(all(c("x", "y", "id") %in% names(map)))
+  if (!all(c("x", "y", "id") %in% names(map))) {
+    abort("`map`must have the columns `x`, `y`, and `id`")
+  }
 
   layer(
     data = dummy_data(),

R/annotation-raster.r

@@ -73,8 +73,7 @@ GeomRasterAnn <- ggproto("GeomRasterAnn", Geom,
   draw_panel = function(data, panel_params, coord, raster, xmin, xmax,
                         ymin, ymax, interpolate = FALSE) {
     if (!inherits(coord, "CoordCartesian")) {
-      stop("annotation_raster only works with Cartesian coordinates",
-        call. = FALSE)
+      abort("annotation_raster only works with Cartesian coordinates")
     }
     corners <- new_data_frame(list(x = c(xmin, xmax), y = c(ymin, ymax)), n = 2)
     data <- coord$transform(corners, panel_params)

R/annotation.r

@@ -58,7 +58,7 @@ annotate <- function(geom, x = NULL, y = NULL, xmin = NULL, xmax = NULL,
     bad <- lengths != 1L
     details <- paste(names(aesthetics)[bad], " (", lengths[bad], ")",
       sep = "", collapse = ", ")
-    stop("Unequal parameter lengths: ", details, call. = FALSE)
+    abort(glue("Unequal parameter lengths: {details}"))
   }
 
   data <- new_data_frame(position, n = n)

R/autolayer.r

@@ -15,6 +15,9 @@ autolayer <- function(object, ...) {
 
 #' @export
 autolayer.default <- function(object, ...) {
-  stop("Objects of type ", paste(class(object), collapse = "/"),
-    " not supported by autolayer.", call. = FALSE)
+  abort(glue(
+    "Objects of type ",
+    glue_collapse(class(object), "/"),
+    " not supported by autolayer."
+  ))
 }

R/autoplot.r

@@ -15,7 +15,10 @@ autoplot <- function(object, ...) {
 
 #' @export
 autoplot.default <- function(object, ...) {
-  stop("Objects of type ", paste(class(object), collapse = "/"),
-    " not supported by autoplot.", call. = FALSE)
+  abort(glue(
+    "Objects of type ",
+    glue_collapse(class(object), "/"),
+    " not supported by autoplot."
+  ))
 }
 

R/axis-secondary.R

@@ -110,7 +110,7 @@ is.sec_axis <- function(x) {
 set_sec_axis <- function(sec.axis, scale) {
   if (!is.waive(sec.axis)) {
     if (is.formula(sec.axis)) sec.axis <- sec_axis(sec.axis)
-    if (!is.sec_axis(sec.axis)) stop("Secondary axes must be specified using 'sec_axis()'")
+    if (!is.sec_axis(sec.axis)) abort("Secondary axes must be specified using 'sec_axis()'")
     scale$secondary.axis <- sec.axis
   }
   return(scale)
@@ -148,7 +148,7 @@ AxisSecondary <- ggproto("AxisSecondary", NULL,
   # Inherit settings from the primary axis/scale
   init = function(self, scale) {
     if (self$empty()) return()
-    if (!is.function(self$trans)) stop("transformation for secondary axes must be a function", call. = FALSE)
+    if (!is.function(self$trans)) abort("transformation for secondary axes must be a function")
     if (is.derived(self$name) && !is.waive(scale$name)) self$name <- scale$name
     if (is.derived(self$breaks)) self$breaks <- scale$breaks
     if (is.waive(self$breaks)) self$breaks <- scale$trans$breaks
@@ -170,7 +170,7 @@ AxisSecondary <- ggproto("AxisSecondary", NULL,
 
     # Test for monotonicity
     if (length(unique(sign(diff(full_range)))) != 1)
-      stop("transformation for secondary axes must be monotonic")
+      abort("transformation for secondary axes must be monotonic")
   },
 
   break_info = function(self, range, scale) {

R/bench.r

@@ -15,7 +15,9 @@
 benchplot <- function(x) {
   x <- enquo(x)
   construct <- system.time(x <- eval_tidy(x))
-  stopifnot(inherits(x, "ggplot"))
+  if (!inherits(x, "ggplot")) {
+    abort("`x` must be a ggplot object")
+  }
 
   build <- system.time(data <- ggplot_build(x))
   render <- system.time(grob <- ggplot_gtable(data))

R/bin.R

@@ -1,6 +1,6 @@
 bins <- function(breaks, closed = c("right", "left"),
                  fuzz = 1e-08 * stats::median(diff(breaks))) {
-  stopifnot(is.numeric(breaks))
+  if (!is.numeric(breaks)) abort("`breaks` must be a numeric vector")
   closed <- match.arg(closed)
 
   breaks <- sort(breaks)
@@ -50,18 +50,18 @@ bin_breaks <- function(breaks, closed = c("right", "left")) {
 
 bin_breaks_width <- function(x_range, width = NULL, center = NULL,
                              boundary = NULL, closed = c("right", "left")) {
-  stopifnot(length(x_range) == 2)
+  if (length(x_range) != 2) abort("`x_range` must have two elements")
 
   # if (length(x_range) == 0) {
   #   return(bin_params(numeric()))
   # }
-  stopifnot(is.numeric(width), length(width) == 1)
+  if (!(is.numeric(width) && length(width) == 1)) abort("`width` must be a numeric scalar")
   if (width <= 0) {
-    stop("`binwidth` must be positive", call. = FALSE)
+    abort("`binwidth` must be positive")
   }
 
   if (!is.null(boundary) && !is.null(center)) {
-    stop("Only one of 'boundary' and 'center' may be specified.")
+    abort("Only one of 'boundary' and 'center' may be specified.")
   } else if (is.null(boundary)) {
     if (is.null(center)) {
       # If neither edge nor center given, compute both using tile layer's
@@ -92,19 +92,19 @@ bin_breaks_width <- function(x_range, width = NULL, center = NULL,
     # single break (see issue #3606). We fix this by adding a second break.
     breaks <- c(breaks, breaks + width)
   } else if (length(breaks) > 1e6) {
-    stop("The number of histogram bins must be less than 1,000,000.\nDid you make `binwidth` too small?", call. = FALSE)
+    abort("The number of histogram bins must be less than 1,000,000.\nDid you make `binwidth` too small?")
   }
 
   bin_breaks(breaks, closed = closed)
 }
 
 bin_breaks_bins <- function(x_range, bins = 30, center = NULL,
                             boundary = NULL, closed = c("right", "left")) {
-  stopifnot(length(x_range) == 2)
+  if (length(x_range) != 2) abort("`x_range` must have two elements")
 
   bins <- as.integer(bins)
   if (bins < 1) {
-    stop("Need at least one bin.", call. = FALSE)
+    abort("Need at least one bin.")
   } else if (zero_range(x_range)) {
     # 0.1 is the same width as the expansion `default_expansion()` gives for 0-width data
     width <- 0.1
@@ -123,7 +123,7 @@ bin_breaks_bins <- function(x_range, bins = 30, center = NULL,
 # Compute bins ------------------------------------------------------------
 
 bin_vector <- function(x, bins, weight = NULL, pad = FALSE) {
-  stopifnot(is_bins(bins))
+  if (!is_bins(bins)) abort("`bins` must be a ggplot2_bins object")
 
   if (all(is.na(x))) {
     return(bin_out(length(x), NA, NA, xmin = NA, xmax = NA))

R/compat-plyr.R

@@ -19,7 +19,7 @@ unrowname <- function(x) {
   } else if (is.matrix(x)) {
     dimnames(x)[1] <- list(NULL)
   } else {
-    stop("Can only remove rownames from data.frame and matrix objects", call. = FALSE)
+    abort("Can only remove rownames from data.frame and matrix objects")
   }
   x
 }
@@ -193,7 +193,7 @@ revalue <- function(x, replace) {
     lev[match(names(replace), lev)] <- replace
     levels(x) <- lev
   } else if (!is.null(x)) {
-    stop("x is not a factor or character vector", call. = FALSE)
+    abort("x is not a factor or character vector")
   }
   x
 }
@@ -239,14 +239,14 @@ as.quoted <- function(x, env = parent.frame()) {
   } else if (is.call(x)) {
     as.list(x)[-1]
   } else {
-    stop("Only knows how to quote characters, calls, and formula", call. = FALSE)
+    abort("Only knows how to quote characters, calls, and formula")
   }
   attributes(x) <- list(env = env, class = 'quoted')
   x
 }
 # round a number to a given precision
 round_any <- function(x, accuracy, f = round) {
-  if (!is.numeric(x)) stop("x must be numeric", call. = FALSE)
+  if (!is.numeric(x)) abort("`x` must be numeric")
   f(x/accuracy) * accuracy
 }
 #' Bind data frames together by common column names

R/coord-.r

@@ -64,27 +64,27 @@ Coord <- ggproto("Coord",
   render_fg = function(panel_params, theme) element_render(theme, "panel.border"),
 
   render_bg = function(panel_params, theme) {
-    stop("Not implemented", call. = FALSE)
+    abort("Not implemented")
   },
 
   render_axis_h = function(panel_params, theme) {
-    stop("Not implemented", call. = FALSE)
+    abort("Not implemented")
   },
 
   render_axis_v = function(panel_params, theme) {
-    stop("Not implemented", call. = FALSE)
+    abort("Not implemented")
   },
 
   # transform range given in transformed coordinates
   # back into range in given in (possibly scale-transformed)
   # data coordinates
   backtransform_range = function(self, panel_params) {
-    stop("Not implemented", call. = FALSE)
+    abort("Not implemented")
   },
 
   # return range stored in panel_params
   range = function(panel_params) {
-    stop("Not implemented", call. = FALSE)
+    abort("Not implemented")
   },
 
   setup_panel_params = function(scale_x, scale_y, params = list()) {

R/coord-sf.R

@@ -84,7 +84,7 @@ CoordSf <- ggproto("CoordSf", CoordCartesian,
     }
 
     if (length(x_labels) != length(x_breaks)) {
-      stop("Breaks and labels along x direction are different lengths", call. = FALSE)
+      abort("Breaks and labels along x direction are different lengths")
     }
     graticule$degree_label[graticule$type == "E"] <- x_labels
 
@@ -109,7 +109,7 @@ CoordSf <- ggproto("CoordSf", CoordCartesian,
     }
 
     if (length(y_labels) != length(y_breaks)) {
-      stop("Breaks and labels along y direction are different lengths", call. = FALSE)
+      abort("Breaks and labels along y direction are different lengths")
     }
     graticule$degree_label[graticule$type == "N"] <- y_labels
 
@@ -167,10 +167,7 @@ CoordSf <- ggproto("CoordSf", CoordCartesian,
 
   backtransform_range = function(panel_params) {
     # this does not actually return backtransformed ranges in the general case, needs fixing
-    warning(
-      "range backtransformation not implemented in this coord; results may be wrong.",
-      call. = FALSE
-    )
+    warn("range backtransformation not implemented in this coord; results may be wrong.")
     list(x = panel_params$x_range, y = panel_params$y_range)
   },
 
@@ -436,20 +433,14 @@ coord_sf <- function(xlim = NULL, ylim = NULL, expand = TRUE,
   if (is.character(label_axes)) {
     label_axes <- parse_axes_labeling(label_axes)
   } else if (!is.list(label_axes)) {
-    stop(
-      "Panel labeling format not recognized.",
-      call. = FALSE
-    )
+    abort("Panel labeling format not recognized.")
     label_axes <- list(left = "N", bottom = "E")
   }
 
   if (is.character(label_graticule)) {
     label_graticule <- unlist(strsplit(label_graticule, ""))
   } else {
-    stop(
-      "Graticule labeling format not recognized.",
-      call. = FALSE
-    )
+    abort("Graticule labeling format not recognized.")
     label_graticule <- ""
   }