diff --git a/DESCRIPTION b/DESCRIPTION index 3d1491076c..422b47222d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -21,6 +21,7 @@ Depends: R (>= 3.2) Imports: digest, + glue, grDevices, grid, gtable (>= 0.1.1), diff --git a/NAMESPACE b/NAMESPACE index e7e825fe80..d2ebb2588e 100644 --- a/NAMESPACE +++ b/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) diff --git a/R/aes-evaluation.r b/R/aes-evaluation.r index 75569b96d5..aefca541df 100644 --- a/R/aes-evaluation.r +++ b/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]}")) } } diff --git a/R/aes.r b/R/aes.r index 3d796c9983..4dc61f4fc3 100644 --- a/R/aes.r +++ b/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)}`")) } } diff --git a/R/annotation-custom.r b/R/annotation-custom.r index c27f7c7d61..2f8a0f0098 100644 --- a/R/annotation-custom.r +++ b/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) diff --git a/R/annotation-map.r b/R/annotation-map.r index 85a3e3e5bd..7df95283b7 100644 --- a/R/annotation-map.r +++ b/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(), diff --git a/R/annotation-raster.r b/R/annotation-raster.r index 1851831299..dcc057c90d 100644 --- a/R/annotation-raster.r +++ b/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) diff --git a/R/annotation.r b/R/annotation.r index 59c241ab4e..5571e6d12f 100644 --- a/R/annotation.r +++ b/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) diff --git a/R/autolayer.r b/R/autolayer.r index 0f32c8f3c3..db371f4d4a 100644 --- a/R/autolayer.r +++ b/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." + )) } diff --git a/R/autoplot.r b/R/autoplot.r index c2e13a606f..fb5f8665a5 100644 --- a/R/autoplot.r +++ b/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." + )) } diff --git a/R/axis-secondary.R b/R/axis-secondary.R index 27b0554bd0..9c9d71476e 100644 --- a/R/axis-secondary.R +++ b/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) { diff --git a/R/bench.r b/R/bench.r index 60ab4ccb32..2ee31050e0 100644 --- a/R/bench.r +++ b/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)) diff --git a/R/bin.R b/R/bin.R index cea2f1faa6..19dace7cae 100644 --- a/R/bin.R +++ b/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,7 +92,7 @@ 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) @@ -100,11 +100,11 @@ bin_breaks_width <- function(x_range, width = NULL, center = NULL, 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)) diff --git a/R/compat-plyr.R b/R/compat-plyr.R index 6ec0ae6b06..f6e3d4d6ae 100644 --- a/R/compat-plyr.R +++ b/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 diff --git a/R/coord-.r b/R/coord-.r index 26f45c9c17..1170341e19 100644 --- a/R/coord-.r +++ b/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()) { diff --git a/R/coord-sf.R b/R/coord-sf.R index ed41ce4c94..67037d5449 100644 --- a/R/coord-sf.R +++ b/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 <- "" } diff --git a/R/coord-transform.r b/R/coord-transform.r index 7b61c82094..358b8ecb91 100644 --- a/R/coord-transform.r +++ b/R/coord-transform.r @@ -77,11 +77,11 @@ coord_trans <- function(x = "identity", y = "identity", xlim = NULL, ylim = NULL, limx = "DEPRECATED", limy = "DEPRECATED", clip = "on", expand = TRUE) { if (!missing(limx)) { - warning("`limx` argument is deprecated; please use `xlim` instead.", call. = FALSE) + warn("`limx` argument is deprecated; please use `xlim` instead.") xlim <- limx } if (!missing(limy)) { - warning("`limy` argument is deprecated; please use `ylim` instead.", call. = FALSE) + warn("`limy` argument is deprecated; please use `ylim` instead.") ylim <- limy } @@ -235,6 +235,6 @@ train_trans <- function(scale, coord_limits, trans, name, expand = TRUE) { #' @noRd warn_new_infinites <- function(old_values, new_values, axis) { if (any(is.finite(old_values) & !is.finite(new_values))) { - warning("Transformation introduced infinite values in ", axis, "-axis", call. = FALSE) + warn(glue("Transformation introduced infinite values in {axis}-axis")) } } diff --git a/R/facet-.r b/R/facet-.r index 2096b5f2cd..7e2b0eed66 100644 --- a/R/facet-.r +++ b/R/facet-.r @@ -83,10 +83,10 @@ Facet <- ggproto("Facet", NULL, params = list(), compute_layout = function(data, params) { - stop("Not implemented", call. = FALSE) + abort("Not implemented") }, map_data = function(data, layout, params) { - stop("Not implemented", call. = FALSE) + abort("Not implemented") }, init_scales = function(layout, x_scale = NULL, y_scale = NULL, params) { scales <- list() @@ -125,7 +125,7 @@ Facet <- ggproto("Facet", NULL, rep(list(zeroGrob()), length(unique(layout$PANEL))) }, draw_panels = function(panels, layout, x_scales, y_scales, ranges, coord, data, theme, params) { - stop("Not implemented", call. = FALSE) + abort("Not implemented") }, draw_labels = function(panels, layout, x_scales, y_scales, ranges, coord, data, theme, labels, params) { panel_dim <- find_panel(panels) @@ -276,7 +276,7 @@ df.grid <- function(a, b) { as_facets_list <- function(x) { if (inherits(x, "uneval")) { - stop("Please use `vars()` to supply facet variables", call. = FALSE) + abort("Please use `vars()` to supply facet variables") } if (is_quosures(x)) { x <- quos_auto_name(x) @@ -446,11 +446,7 @@ check_layout <- function(x) { return() } - stop( - "Facet layout has bad format. ", - "It must contain columns 'PANEL', 'SCALE_X', and 'SCALE_Y'", - call. = FALSE - ) + abort("Facet layout has bad format. It must contain columns 'PANEL', 'SCALE_X', and 'SCALE_Y'") } @@ -541,12 +537,10 @@ combine_vars <- function(data, env = emptyenv(), vars = NULL, drop = TRUE) { missing_txt <- vapply(missing, var_list, character(1)) name <- c("Plot", paste0("Layer ", seq_len(length(data) - 1))) - stop( - "At least one layer must contain all faceting variables: ", - var_list(names(vars)), ".\n", - paste0("* ", name, " is missing ", missing_txt, collapse = "\n"), - call. = FALSE - ) + abort(glue( + "At least one layer must contain all faceting variables: {var_list(names(vars))}.\n", + glue_collapse(glue("* {name} is missing {missing_txt}"), "\n", last = "\n") + )) } base <- unique(rbind_dfs(values[has_all])) @@ -567,7 +561,7 @@ combine_vars <- function(data, env = emptyenv(), vars = NULL, drop = TRUE) { } if (empty(base)) { - stop("Faceting variables must have at least one value", call. = FALSE) + abort("Faceting variables must have at least one value") } base diff --git a/R/facet-grid-.r b/R/facet-grid-.r index 0bce18755d..1a6bd430bb 100644 --- a/R/facet-grid-.r +++ b/R/facet-grid-.r @@ -136,7 +136,7 @@ facet_grid <- function(rows = NULL, cols = NULL, scales = "fixed", ) if (!is.null(switch) && !switch %in% c("both", "x", "y")) { - stop("switch must be either 'both', 'x', or 'y'", call. = FALSE) + abort("switch must be either 'both', 'x', or 'y'") } facets_list <- grid_as_facets_list(rows, cols) @@ -157,12 +157,12 @@ grid_as_facets_list <- function(rows, cols) { is_rows_vars <- is.null(rows) || is_quosures(rows) if (!is_rows_vars) { if (!is.null(cols)) { - stop("`rows` must be `NULL` or a `vars()` list if `cols` is a `vars()` list", call. = FALSE) + abort("`rows` must be `NULL` or a `vars()` list if `cols` is a `vars()` list") } # For backward-compatibility facets_list <- as_facets_list(rows) if (length(facets_list) > 2L) { - stop("A grid facet specification can't have more than two dimensions", call. = FALSE) + abort("A grid facet specification can't have more than two dimensions") } # Fill with empty quosures facets <- list(rows = quos(), cols = quos()) @@ -173,7 +173,7 @@ grid_as_facets_list <- function(rows, cols) { is_cols_vars <- is.null(cols) || is_quosures(cols) if (!is_cols_vars) { - stop("`cols` must be `NULL` or a `vars()` specification", call. = FALSE) + abort("`cols` must be `NULL` or a `vars()` specification") } list( @@ -195,11 +195,10 @@ FacetGrid <- ggproto("FacetGrid", Facet, dups <- intersect(names(rows), names(cols)) if (length(dups) > 0) { - stop( + abort(glue( "Faceting variables can only appear in row or cols, not both.\n", - "Problems: ", paste0(dups, collapse = "'"), - call. = FALSE - ) + "Problems: ", paste0(dups, collapse = "'") + )) } base_rows <- combine_vars(data, params$plot_env, rows, drop = params$drop) @@ -286,7 +285,7 @@ FacetGrid <- ggproto("FacetGrid", Facet, }, draw_panels = function(panels, layout, x_scales, y_scales, ranges, coord, data, theme, params) { if ((params$free$x || params$free$y) && !coord$is_free()) { - stop(snake_class(coord), " doesn't support free scales", call. = FALSE) + abort(glue("{snake_class(coord)} doesn't support free scales")) } cols <- which(layout$ROW == 1) diff --git a/R/facet-wrap.r b/R/facet-wrap.r index 6ab5904de5..926322c420 100644 --- a/R/facet-wrap.r +++ b/R/facet-wrap.r @@ -211,7 +211,7 @@ FacetWrap <- ggproto("FacetWrap", Facet, }, draw_panels = function(panels, layout, x_scales, y_scales, ranges, coord, data, theme, params) { if ((params$free$x || params$free$y) && !coord$is_free()) { - stop(snake_class(coord), " doesn't support free scales", call. = FALSE) + abort(glue("{snake_class(coord)} doesn't support free scales")) } if (inherits(coord, "CoordFlip")) { @@ -325,7 +325,7 @@ FacetWrap <- ggproto("FacetWrap", Facet, !inside && any(!vapply(row_axes, is.zero, logical(1))) && !params$free$x) { - warning("Suppressing axis rendering when strip.position = 'bottom' and strip.placement == 'outside'", call. = FALSE) + warn("Suppressing axis rendering when strip.position = 'bottom' and strip.placement == 'outside'") } else { axis_mat_x_bottom[row_pos] <- row_axes } @@ -333,7 +333,7 @@ FacetWrap <- ggproto("FacetWrap", Facet, !inside && any(!vapply(col_axes, is.zero, logical(1))) && !params$free$y) { - warning("Suppressing axis rendering when strip.position = 'right' and strip.placement == 'outside'", call. = FALSE) + warn("Suppressing axis rendering when strip.position = 'right' and strip.placement == 'outside'") } else { axis_mat_y_right[col_pos] <- col_axes } @@ -422,22 +422,20 @@ sanitise_dim <- function(n) { xname <- paste0("`", deparse(substitute(n)), "`") if (length(n) == 0) { if (!is.null(n)) { - warning(xname, " has length zero and will be treated as NULL.", - call. = FALSE) + warn(glue("{xname} has length zero and will be treated as NULL.")) } return(NULL) } if (length(n) > 1) { - warning("Only the first value of ", xname, " will be used.", call. = FALSE) + warn(glue("Only the first value of {xname} will be used.")) n <- n[1] } if (!is.numeric(n) || (!is.na(n) && n != round(n))) { - warning("Coercing ", xname, " to be an integer.", call. = FALSE) + warn(glue("Coercing {xname} to be an integer.")) n <- as.integer(n) } if (is.na(n) || n < 1) { - warning(xname, " is missing or less than 1 and will be treated as NULL.", - call. = FALSE) + warn(glue("{xname} is missing or less than 1 and will be treated as NULL.")) return(NULL) } n @@ -462,7 +460,9 @@ wrap_dims <- function(n, nrow = NULL, ncol = NULL) { } else if (is.null(nrow)) { nrow <- ceiling(n / ncol) } - stopifnot(nrow * ncol >= n) + if (nrow * ncol < n) { + abort("The given dimensions cannot hold all panels. Please increase `ncol` or `nrow`") + } c(nrow, ncol) } diff --git a/R/fortify.r b/R/fortify.r index cf35a403bf..779b2dc552 100644 --- a/R/fortify.r +++ b/R/fortify.r @@ -18,7 +18,7 @@ fortify.tbl_df <- function(model, data, ...) model #' @export fortify.tbl <- function(model, data, ...) { if (!requireNamespace("dplyr", quietly = TRUE)) { - stop("dplyr must be installed to work with tbl objects", call. = FALSE) + abort("dplyr must be installed to work with tbl objects") } dplyr::collect(model) } @@ -32,7 +32,7 @@ fortify.formula <- function(model, data, ...) as_function(model) #' @export fortify.grouped_df <- function(model, data, ...) { if (!requireNamespace("dplyr", quietly = TRUE)) { - stop("dplyr must be installed to work with grouped_df objects", call. = FALSE) + abort("dplyr must be installed to work with grouped_df objects") } model$.group <- dplyr::group_indices(model) model @@ -49,5 +49,5 @@ fortify.default <- function(model, data, ...) { "Did you accidentally pass `aes()` to the `data` argument?" ) } - stop(msg, call. = FALSE) + abort(msg) } diff --git a/R/geom-.r b/R/geom-.r index bbf499e65e..5a84dcc4dc 100644 --- a/R/geom-.r +++ b/R/geom-.r @@ -101,7 +101,7 @@ Geom <- ggproto("Geom", }, draw_group = function(self, data, panel_params, coord) { - stop("Not implemented") + abort("Not implemented") }, setup_params = function(data, params) params, @@ -137,12 +137,12 @@ Geom <- ggproto("Geom", # Check that all output are valid data nondata_modified <- check_nondata_cols(modified_aes) if (length(nondata_modified) > 0) { - msg <- paste0( + msg <- glue( "Modifiers must return valid values. Problematic aesthetic(s): ", - paste0(vapply(nondata_modified, function(x) {paste0(x, " = ", as_label(modifiers[[x]]))}, character(1)), collapse = ", "), + glue_collapse(vapply(nondata_modified, function(x) glue("{x} = {as_label(modifiers[[x]])}"), character(1)), ", ", last = " and "), ". \nDid you map your mod in the wrong layer?" ) - stop(msg, call. = FALSE) + abort(msg) } names(modified_aes) <- rename_aes(names(modifiers)) @@ -217,9 +217,8 @@ check_aesthetics <- function(x, n) { return() } - stop( - "Aesthetics must be either length 1 or the same as the data (", n, "): ", - paste(names(which(!good)), collapse = ", "), - call. = FALSE - ) + abort(glue( + "Aesthetics must be either length 1 or the same as the data ({n}): ", + glue_collapse(names(which(!good)), ", ", last = " and ") + )) } diff --git a/R/geom-abline.r b/R/geom-abline.r index a0ef5058b5..60161c1fc1 100644 --- a/R/geom-abline.r +++ b/R/geom-abline.r @@ -160,14 +160,5 @@ warn_overwritten_args <- function(fun_name, overwritten_arg, provided_args, plur verb <- "were" } - warning( - sprintf( - "%s: Ignoring %s because %s %s provided.", - fun_name, - overwritten_arg_text, - provided_arg_text, - verb - ), - call. = FALSE - ) + warn(glue("{fun_name}: Ignoring {overwritten_arg_text} because {provided_arg_text} {verb} provided.")) } diff --git a/R/geom-bar.r b/R/geom-bar.r index cff012f926..e678f3dec1 100644 --- a/R/geom-bar.r +++ b/R/geom-bar.r @@ -89,8 +89,7 @@ geom_bar <- function(mapping = NULL, data = NULL, inherit.aes = TRUE) { if (!is.null(binwidth)) { - warning("`geom_bar()` no longer has a `binwidth` parameter. ", - "Please use `geom_histogram()` instead.", call. = "FALSE") + warn("`geom_bar()` no longer has a `binwidth` parameter. Please use `geom_histogram()` instead.") return(geom_histogram(mapping = mapping, data = data, position = position, width = width, binwidth = binwidth, ..., na.rm = na.rm, show.legend = show.legend, inherit.aes = inherit.aes)) diff --git a/R/geom-boxplot.r b/R/geom-boxplot.r index 8273a854f8..bd3d5ed9a5 100644 --- a/R/geom-boxplot.r +++ b/R/geom-boxplot.r @@ -128,7 +128,7 @@ geom_boxplot <- function(mapping = NULL, data = NULL, if (varwidth == TRUE) position <- position_dodge2(preserve = "single") } else { if (identical(position$preserve, "total") & varwidth == TRUE) { - warning("Can't preserve total widths when varwidth = TRUE.", call. = FALSE) + warn("Can't preserve total widths when varwidth = TRUE.") position$preserve <- "single" } } @@ -214,10 +214,7 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom, data <- flip_data(data, flipped_aes) # this may occur when using geom_boxplot(stat = "identity") if (nrow(data) != 1) { - stop( - "Can't draw more than one boxplot per group. Did you forget aes(group = ...)?", - call. = FALSE - ) + abort("Can't draw more than one boxplot per group. Did you forget aes(group = ...)?") } common <- list( diff --git a/R/geom-curve.r b/R/geom-curve.r index e9faa3730b..9a44a85be3 100644 --- a/R/geom-curve.r +++ b/R/geom-curve.r @@ -45,8 +45,7 @@ GeomCurve <- ggproto("GeomCurve", GeomSegment, ncp = 5, arrow = NULL, arrow.fill = NULL, lineend = "butt", na.rm = FALSE) { if (!coord$is_linear()) { - warning("geom_curve is not implemented for non-linear coordinates", - call. = FALSE) + warn("geom_curve is not implemented for non-linear coordinates") } trans <- coord$transform(data, panel_params) diff --git a/R/geom-dotplot.r b/R/geom-dotplot.r index 0c2f371caf..d227ef22a1 100644 --- a/R/geom-dotplot.r +++ b/R/geom-dotplot.r @@ -256,7 +256,7 @@ GeomDotplot <- ggproto("GeomDotplot", Geom, binaxis = "x", stackdir = "up", stackratio = 1, dotsize = 1, stackgroups = FALSE) { if (!coord$is_linear()) { - warning("geom_dotplot does not work properly with non-linear coordinates.") + warn("geom_dotplot does not work properly with non-linear coordinates.") } tdata <- coord$transform(data, panel_params) diff --git a/R/geom-hex.r b/R/geom-hex.r index e669914264..683109eab2 100644 --- a/R/geom-hex.r +++ b/R/geom-hex.r @@ -56,7 +56,7 @@ geom_hex <- function(mapping = NULL, data = NULL, GeomHex <- ggproto("GeomHex", Geom, draw_group = function(data, panel_params, coord) { if (!inherits(coord, "CoordCartesian")) { - stop("geom_hex() only works with Cartesian coordinates", call. = FALSE) + abort("geom_hex() only works with Cartesian coordinates") } coords <- coord$transform(data, panel_params) @@ -94,7 +94,7 @@ GeomHex <- ggproto("GeomHex", Geom, # @param gp graphical parameters # @keyword internal hexGrob <- function(x, y, size = rep(1, length(x)), gp = gpar()) { - stopifnot(length(y) == length(x)) + if (length(y) != length(x)) abort("`x` and `y` must have the same length") dx <- resolution(x, FALSE) dy <- resolution(y, FALSE) / sqrt(3) / 2 * 1.15 diff --git a/R/geom-jitter.r b/R/geom-jitter.r index 3864090fdb..60343aee3c 100644 --- a/R/geom-jitter.r +++ b/R/geom-jitter.r @@ -39,7 +39,7 @@ geom_jitter <- function(mapping = NULL, data = NULL, inherit.aes = TRUE) { if (!missing(width) || !missing(height)) { if (!missing(position)) { - stop("You must specify either `position` or `width`/`height`.", call. = FALSE) + abort("You must specify either `position` or `width`/`height`.") } position <- position_jitter(width = width, height = height) diff --git a/R/geom-label.R b/R/geom-label.R index 4987e4b420..826d16a72b 100644 --- a/R/geom-label.R +++ b/R/geom-label.R @@ -17,7 +17,7 @@ geom_label <- function(mapping = NULL, data = NULL, inherit.aes = TRUE) { if (!missing(nudge_x) || !missing(nudge_y)) { if (!missing(position)) { - stop("You must specify either `position` or `nudge_x`/`nudge_y`.", call. = FALSE) + abort("You must specify either `position` or `nudge_x`/`nudge_y`.") } position <- position_nudge(nudge_x, nudge_y) @@ -109,7 +109,9 @@ labelGrob <- function(label, x = unit(0.5, "npc"), y = unit(0.5, "npc"), default.units = "npc", name = NULL, text.gp = gpar(), rect.gp = gpar(fill = "white"), vp = NULL) { - stopifnot(length(label) == 1) + if (length(label) != 1) { + abort("label must be of length 1") + } if (!is.unit(x)) x <- unit(x, default.units) diff --git a/R/geom-linerange.r b/R/geom-linerange.r index f6307062af..005f93de3a 100644 --- a/R/geom-linerange.r +++ b/R/geom-linerange.r @@ -101,7 +101,7 @@ GeomLinerange <- ggproto("GeomLinerange", Geom, params$flipped_aes <- has_flipped_aes(data, params, range_is_orthogonal = TRUE) # if flipped_aes == TRUE then y, xmin, xmax is present if (!(params$flipped_aes || all(c("x", "ymin", "ymax") %in% c(names(data), names(params))))) { - stop("Either, `x`, `ymin`, and `ymax` or `y`, `xmin`, and `xmax` must be supplied", call. = FALSE) + abort("Either, `x`, `ymin`, and `ymax` or `y`, `xmin`, and `xmax` must be supplied") } params }, diff --git a/R/geom-map.r b/R/geom-map.r index 06339c2dc5..031e0c5b91 100644 --- a/R/geom-map.r +++ b/R/geom-map.r @@ -74,11 +74,15 @@ geom_map <- function(mapping = NULL, data = NULL, show.legend = NA, inherit.aes = TRUE) { # 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 = data, diff --git a/R/geom-path.r b/R/geom-path.r index 0f02f2f045..b8539d9d3f 100644 --- a/R/geom-path.r +++ b/R/geom-path.r @@ -140,8 +140,7 @@ GeomPath <- ggproto("GeomPath", Geom, data <- data[kept, ] if (!all(kept) && !params$na.rm) { - warning("Removed ", sum(!kept), " rows containing missing values", - " (geom_path).", call. = FALSE) + warn(glue("Removed {sum(!kept)} row(s) containing missing values (geom_path).")) } data @@ -175,9 +174,7 @@ GeomPath <- ggproto("GeomPath", Geom, solid_lines <- all(attr$solid) constant <- all(attr$constant) if (!solid_lines && !constant) { - stop("geom_path: If you are using dotted or dashed lines", - ", colour, size and linetype must be constant over the line", - call. = FALSE) + abort("geom_path: If you are using dotted or dashed lines, colour, size and linetype must be constant over the line") } # Work out grouping variables for grobs @@ -340,7 +337,7 @@ stairstep <- function(data, direction = "hv") { xs <- rep(1:(n-1), each = 2) ys <- rep(1:n, each = 2) } else { - stop("Parameter `direction` is invalid.") + abort("Parameter `direction` is invalid.") } if (direction == "mid") { diff --git a/R/geom-point.r b/R/geom-point.r index 922b19170a..88e1e6655f 100644 --- a/R/geom-point.r +++ b/R/geom-point.r @@ -185,14 +185,11 @@ translate_shape_string <- function(shape_string) { more_problems <- if (n_bad > 5) { sprintf("\n* ... and %d more problem%s", n_bad - 5, ifelse(n_bad > 6, "s", "")) + } else { + "" } - stop( - "Can't find shape name:", - collapsed_names, - more_problems, - call. = FALSE - ) + abort(glue("Can't find shape name:", collapsed_names, more_problems)) } if (any(nonunique_strings)) { @@ -212,14 +209,11 @@ translate_shape_string <- function(shape_string) { more_problems <- if (n_bad > 5) { sprintf("\n* ... and %d more problem%s", n_bad - 5, ifelse(n_bad > 6, "s", "")) + } else { + "" } - stop( - "Shape names must be unambiguous:", - collapsed_names, - more_problems, - call. = FALSE - ) + abort(glue("Shape names must be unambiguous:", collapsed_names, more_problems)) } unname(pch_table[shape_match]) diff --git a/R/geom-polygon.r b/R/geom-polygon.r index f8ed81bae9..9b5f1bb291 100644 --- a/R/geom-polygon.r +++ b/R/geom-polygon.r @@ -137,7 +137,7 @@ GeomPolygon <- ggproto("GeomPolygon", Geom, ) } else { if (utils::packageVersion('grid') < "3.6") { - stop("Polygons with holes requires R 3.6 or above", call. = FALSE) + abort("Polygons with holes requires R 3.6 or above") } # Sort by group to make sure that colors, fill, etc. come in same order munched <- munched[order(munched$group, munched$subgroup), ] diff --git a/R/geom-raster.r b/R/geom-raster.r index 53f0e05207..a9f4b61a8d 100644 --- a/R/geom-raster.r +++ b/R/geom-raster.r @@ -18,8 +18,8 @@ geom_raster <- function(mapping = NULL, data = NULL, show.legend = NA, inherit.aes = TRUE) { - stopifnot(is.numeric(hjust), length(hjust) == 1) - stopifnot(is.numeric(vjust), length(vjust) == 1) + if (!(is.numeric(hjust) && length(hjust) == 1)) abort("`hjust` must be a numeric scalar") + if (!(is.numeric(vjust) && length(vjust) == 1)) abort("`vjust` must be a numeric scalar") layer( data = data, @@ -57,7 +57,7 @@ GeomRaster <- ggproto("GeomRaster", Geom, if (length(x_diff) == 0) { w <- 1 } else if (any(abs(diff(x_diff)) > precision)) { - warning("Raster pixels are placed at uneven horizontal intervals and will be shifted. Consider using geom_tile() instead.") + warn("Raster pixels are placed at uneven horizontal intervals and will be shifted. Consider using geom_tile() instead.") w <- min(x_diff) } else { w <- x_diff[1] @@ -66,7 +66,7 @@ GeomRaster <- ggproto("GeomRaster", Geom, if (length(y_diff) == 0) { h <- 1 } else if (any(abs(diff(y_diff)) > precision)) { - warning("Raster pixels are placed at uneven vertical intervals and will be shifted. Consider using geom_tile() instead.") + warn("Raster pixels are placed at uneven vertical intervals and will be shifted. Consider using geom_tile() instead.") h <- min(y_diff) } else { h <- y_diff[1] @@ -82,7 +82,7 @@ GeomRaster <- ggproto("GeomRaster", Geom, draw_panel = function(data, panel_params, coord, interpolate = FALSE, hjust = 0.5, vjust = 0.5) { if (!inherits(coord, "CoordCartesian")) { - stop("geom_raster only works with Cartesian coordinates", call. = FALSE) + abort("geom_raster only works with Cartesian coordinates") } data <- coord$transform(data, panel_params) diff --git a/R/geom-ribbon.r b/R/geom-ribbon.r index cff9e1dbb1..07dfbc882a 100644 --- a/R/geom-ribbon.r +++ b/R/geom-ribbon.r @@ -83,8 +83,8 @@ GeomRibbon <- ggproto("GeomRibbon", Geom, data <- flip_data(data, params$flipped_aes) if (is.null(data$ymin) && is.null(data$ymax)) { - stop("Either ", flipped_names(params$flipped_aes)$ymin, " or ", - flipped_names(params$flipped_aes)$ymax, " must be given as an aesthetic.", call. = FALSE) + abort(glue("Either ", flipped_names(params$flipped_aes)$ymin, " or ", + flipped_names(params$flipped_aes)$ymax, " must be given as an aesthetic.")) } data <- data[order(data$PANEL, data$group, data$x), , drop = FALSE] data$y <- data$ymin %||% data$ymax @@ -105,7 +105,7 @@ GeomRibbon <- ggproto("GeomRibbon", Geom, # Check that aesthetics are constant aes <- unique(data[c("colour", "fill", "size", "linetype", "alpha")]) if (nrow(aes) > 1) { - stop("Aesthetics can not vary with a ribbon") + abort("Aesthetics can not vary with a ribbon") } aes <- as.list(aes) diff --git a/R/geom-rug.r b/R/geom-rug.r index cbf7cbfe65..b64b530bec 100644 --- a/R/geom-rug.r +++ b/R/geom-rug.r @@ -87,7 +87,7 @@ GeomRug <- ggproto("GeomRug", Geom, draw_panel = function(data, panel_params, coord, sides = "bl", outside = FALSE, length = unit(0.03, "npc")) { if (!inherits(length, "unit")) { - stop("'length' must be a 'unit' object.", call. = FALSE) + abort("'length' must be a 'unit' object.") } rugs <- list() data <- coord$transform(data, panel_params) diff --git a/R/geom-sf.R b/R/geom-sf.R index 546b31a15c..1dcf5d7095 100644 --- a/R/geom-sf.R +++ b/R/geom-sf.R @@ -101,7 +101,7 @@ GeomSf <- ggproto("GeomSf", Geom, lineend = "butt", linejoin = "round", linemitre = 10, na.rm = TRUE) { if (!inherits(coord, "CoordSf")) { - stop("geom_sf() must be used with coord_sf()", call. = FALSE) + abort("geom_sf() must be used with coord_sf()") } # Need to refactor this to generate one grob per geometry type @@ -228,7 +228,7 @@ geom_sf_label <- function(mapping = aes(), data = NULL, if (!missing(nudge_x) || !missing(nudge_y)) { if (!missing(position)) { - stop("Specify either `position` or `nudge_x`/`nudge_y`", call. = FALSE) + abort("Specify either `position` or `nudge_x`/`nudge_y`") } position <- position_nudge(nudge_x, nudge_y) @@ -272,7 +272,7 @@ geom_sf_text <- function(mapping = aes(), data = NULL, if (!missing(nudge_x) || !missing(nudge_y)) { if (!missing(position)) { - stop("You must specify either `position` or `nudge_x`/`nudge_y`.", call. = FALSE) + abort("You must specify either `position` or `nudge_x`/`nudge_y`.") } position <- position_nudge(nudge_x, nudge_y) diff --git a/R/geom-text.r b/R/geom-text.r index 404a6f2aec..48721cf64d 100644 --- a/R/geom-text.r +++ b/R/geom-text.r @@ -136,7 +136,7 @@ geom_text <- function(mapping = NULL, data = NULL, { if (!missing(nudge_x) || !missing(nudge_y)) { if (!missing(position)) { - stop("You must specify either `position` or `nudge_x`/`nudge_y`.", call. = FALSE) + abort("You must specify either `position` or `nudge_x`/`nudge_y`.") } position <- position_nudge(nudge_x, nudge_y) diff --git a/R/geom-violin.r b/R/geom-violin.r index 9a56f34639..9afc3d4d5e 100644 --- a/R/geom-violin.r +++ b/R/geom-violin.r @@ -149,7 +149,9 @@ GeomViolin <- ggproto("GeomViolin", Geom, # Draw quantiles if requested, so long as there is non-zero y range if (length(draw_quantiles) > 0 & !scales::zero_range(range(data$y))) { - stopifnot(all(draw_quantiles >= 0), all(draw_quantiles <= 1)) + if (!(all(draw_quantiles >= 0) && all(draw_quantiles <= 1))) { + abort("`draw_quantiles must be between 0 and 1") + } # Compute the quantile segments and combine with existing aesthetics quantiles <- create_quantile_segment_frame(data, draw_quantiles) diff --git a/R/ggplot2.r b/R/ggplot2.r index 8c44df5540..0cdacd84cd 100644 --- a/R/ggplot2.r +++ b/R/ggplot2.r @@ -3,4 +3,5 @@ #' @import scales grid gtable rlang #' @importFrom stats setNames +#' @importFrom glue glue glue_collapse NULL diff --git a/R/ggproto.r b/R/ggproto.r index 9e2180f684..d279ec3ce4 100644 --- a/R/ggproto.r +++ b/R/ggproto.r @@ -59,7 +59,7 @@ ggproto <- function(`_class` = NULL, `_inherit` = NULL, ...) { members <- list(...) if (length(members) != sum(nzchar(names(members)))) { - stop("All members of a ggproto object must be named.") + abort("All members of a ggproto object must be named.") } # R <3.1.2 will error when list2env() is given an empty list, so we need to @@ -79,7 +79,7 @@ ggproto <- function(`_class` = NULL, `_inherit` = NULL, ...) { super <- find_super() if (!is.null(super)) { if (!is.ggproto(super)) { - stop("`_inherit` must be a ggproto object.") + abort("`_inherit` must be a ggproto object.") } e$super <- find_super class(e) <- c(`_class`, class(super)) @@ -119,11 +119,10 @@ fetch_ggproto <- function(x, name) { } else if (is.function(super)) { res <- fetch_ggproto(super(), name) } else { - stop( - class(x)[[1]], " was built with an incompatible version of ggproto.\n", - "Please reinstall the package that provides this extension.", - call. = FALSE - ) + abort(glue(" + {class(x)[[1]]} was built with an incompatible version of ggproto. + Please reinstall the package that provides this extension. + ")) } } diff --git a/R/grob-dotstack.r b/R/grob-dotstack.r index 48362a6976..dc25dc24eb 100644 --- a/R/grob-dotstack.r +++ b/R/grob-dotstack.r @@ -14,7 +14,7 @@ dotstackGrob <- function( if (!is.unit(dotdia)) dotdia <- unit(dotdia, default.units) if (!is_npc(dotdia)) - warning("Unit type of dotdia should be 'npc'") + warn("Unit type of dotdia should be 'npc'") grob(x = x, y = y, stackaxis = stackaxis, dotdia = dotdia, stackposition = stackposition, stackratio = stackratio, diff --git a/R/guide-bins.R b/R/guide-bins.R index 2e5b25cf79..5f243bb216 100644 --- a/R/guide-bins.R +++ b/R/guide-bins.R @@ -149,7 +149,7 @@ guide_merge.bins <- function(guide, new_guide) { guide$key <- merge(guide$key, new_guide$key, sort = FALSE) guide$override.aes <- c(guide$override.aes, new_guide$override.aes) if (any(duplicated(names(guide$override.aes)))) { - warning("Duplicated override.aes is ignored.") + warn("Duplicated override.aes is ignored.") } guide$override.aes <- guide$override.aes[!duplicated(names(guide$override.aes))] guide @@ -206,13 +206,13 @@ guide_gengrob.bins <- function(guide, theme) { if (guide$direction == "horizontal") { label.position <- guide$label.position %||% "bottom" if (!label.position %in% c("top", "bottom")) { - warning("Ignoring invalid label.position", call. = FALSE) + warn("Ignoring invalid label.position") label.position <- "bottom" } } else { label.position <- guide$label.position %||% "right" if (!label.position %in% c("left", "right")) { - warning("Ignoring invalid label.position", call. = FALSE) + warn("Ignoring invalid label.position") label.position <- "right" } } diff --git a/R/guide-colorbar.r b/R/guide-colorbar.r index 5f51a22d69..92412e12ae 100644 --- a/R/guide-colorbar.r +++ b/R/guide-colorbar.r @@ -196,12 +196,14 @@ guide_train.colorbar <- function(guide, scale, aesthetic = NULL) { # do nothing if scale are inappropriate if (length(intersect(scale$aesthetics, guide$available_aes)) == 0) { - warning("colourbar guide needs appropriate scales: ", - paste(guide$available_aes, collapse = ", ")) + warn(glue( + "colourbar guide needs appropriate scales: ", + glue_collapse(guide$available_aes, ", ", last = " or ") + )) return(NULL) } if (scale$is_discrete()) { - warning("colourbar guide needs continuous scales.") + warn("colourbar guide needs continuous scales.") return(NULL) } @@ -270,13 +272,17 @@ guide_gengrob.colorbar <- function(guide, theme) { # settings of location and size if (guide$direction == "horizontal") { label.position <- guide$label.position %||% "bottom" - if (!label.position %in% c("top", "bottom")) stop("label position \"", label.position, "\" is invalid") + if (!label.position %in% c("top", "bottom")) { + abort(glue("label position '{label.position}' is invalid")) + } barwidth <- width_cm(guide$barwidth %||% (theme$legend.key.width * 5)) barheight <- height_cm(guide$barheight %||% theme$legend.key.height) } else { # guide$direction == "vertical" label.position <- guide$label.position %||% "right" - if (!label.position %in% c("left", "right")) stop("label position \"", label.position, "\" is invalid") + if (!label.position %in% c("left", "right")) { + abort(glue("label position '{label.position}' is invalid")) + } barwidth <- width_cm(guide$barwidth %||% theme$legend.key.width) barheight <- height_cm(guide$barheight %||% (theme$legend.key.height * 5)) diff --git a/R/guide-legend.r b/R/guide-legend.r index e546ba0527..86d2286729 100644 --- a/R/guide-legend.r +++ b/R/guide-legend.r @@ -235,7 +235,7 @@ guide_merge.legend <- function(guide, new_guide) { guide$key <- cbind(guide$key, new_guide$key) guide$override.aes <- c(guide$override.aes, new_guide$override.aes) if (any(duplicated(names(guide$override.aes)))) { - warning("Duplicated override.aes is ignored.") + warn("Duplicated override.aes is ignored.") } guide$override.aes <- guide$override.aes[!duplicated(names(guide$override.aes))] guide @@ -291,7 +291,7 @@ guide_gengrob.legend <- function(guide, theme) { # default setting label.position <- guide$label.position %||% "right" if (!label.position %in% c("top", "bottom", "left", "right")) - stop("label position \"", label.position, "\" is invalid") + abort(glue("label position `{label.position}` is invalid")) nbreak <- nrow(guide$key) @@ -382,10 +382,7 @@ guide_gengrob.legend <- function(guide, theme) { if (!is.null(guide$nrow) && !is.null(guide$ncol) && guide$nrow * guide$ncol < nbreak) { - stop( - "`nrow` * `ncol` needs to be larger than the number of breaks", - call. = FALSE - ) + abort("`nrow` * `ncol` needs to be larger than the number of breaks") } # If neither nrow/ncol specified, guess with "reasonable" values diff --git a/R/guides-.r b/R/guides-.r index 061317227b..38b5708e0a 100644 --- a/R/guides-.r +++ b/R/guides-.r @@ -168,7 +168,7 @@ validate_guide <- function(guide) { else if (inherits(guide, "guide")) guide else - stop("Unknown guide: ", guide) + abort(glue("Unknown guide: {guide}")) } # train each scale in scales and generate the definition of guide @@ -194,8 +194,9 @@ guides_train <- function(scales, theme, guides, labels) { guide <- validate_guide(guide) # check the consistency of the guide and scale. - if (!identical(guide$available_aes, "any") && !any(scale$aesthetics %in% guide$available_aes)) - stop("Guide '", guide$name, "' cannot be used for '", scale$aesthetics, "'.") + if (!identical(guide$available_aes, "any") && !any(scale$aesthetics %in% guide$available_aes)) { + abort(glue("Guide '{guide$name}' cannot be used for '{scale$aesthetics}'.")) + } guide$title <- scale$make_title(guide$title %|W|% scale$name %|W|% labels[[output]]) @@ -238,8 +239,9 @@ guides_gengrob <- function(gdefs, theme) { gdefs <- lapply(gdefs, function(g) { g$title.position <- g$title.position %||% switch(g$direction, vertical = "top", horizontal = "left") - if (!g$title.position %in% c("top", "bottom", "left", "right")) - stop("title position \"", g$title.position, "\" is invalid") + if (!g$title.position %in% c("top", "bottom", "left", "right")) { + abort(glue("title position '{g$title.position}' is invalid")) + } g }) @@ -340,13 +342,12 @@ guide_transform <- function(guide, coord, panel_params) UseMethod("guide_transfo #' @export guide_transform.default <- function(guide, coord, panel_params) { - stop( + abort(glue( "Guide with class ", - paste(class(guide), collapse = " / "), + glue_collapse(class(guide), " / "), " does not implement guide_transform(). ", - "Did you mean to use guide_axis()?", - call. = FALSE - ) + "Did you mean to use guide_axis()?" + )) } #' @export @@ -369,7 +370,7 @@ matched_aes <- function(layer, guide, defaults) { # `matched` is the set of aesthetics that match between the layer and the guide include_layer_in_guide <- function(layer, matched) { if (!is.logical(layer$show.legend)) { - warning("`show.legend` must be a logical vector.", call. = FALSE) + warn("`show.legend` must be a logical vector.") layer$show.legend <- FALSE # save back to layer so we don't issue this warning more than once return(FALSE) } diff --git a/R/guides-axis.r b/R/guides-axis.r index b0f9b7edbf..b00ffb3d37 100644 --- a/R/guides-axis.r +++ b/R/guides-axis.r @@ -72,11 +72,10 @@ guide_train.axis <- function(guide, scale, aesthetic = NULL) { names(empty_ticks) <- c(aesthetic, ".value", ".label") if (length(intersect(scale$aesthetics, guide$available_aes)) == 0) { - warning( + warn(glue( "axis guide needs appropriate scales: ", - paste(guide$available_aes, collapse = ", "), - call. = FALSE - ) + glue_collapse(guide$available_aes, ", ", last = " or ") + )) guide$key <- empty_ticks } else if (length(breaks) == 0) { guide$key <- empty_ticks @@ -128,11 +127,7 @@ guide_transform.axis <- function(guide, coord, panel_params) { #' @export guide_merge.axis <- function(guide, new_guide) { if (!inherits(guide, "guide_none")) { - warning( - "guide_axis(): Discarding guide on merge. ", - "Do you have more than one guide with the same position?", - call. = FALSE - ) + warn("guide_axis(): Discarding guide on merge. Do you have more than one guide with the same position?") } guide @@ -386,7 +381,7 @@ axis_label_element_overrides <- function(axis_position, angle = NULL) { # it is not worth the effort to align upside-down labels properly if (angle > 90 || angle < -90) { - stop("`angle` must be between 90 and -90", call. = FALSE) + abort("`angle` must be between 90 and -90") } if (axis_position == "bottom") { @@ -414,7 +409,7 @@ axis_label_element_overrides <- function(axis_position, angle = NULL) { vjust = if (angle > 0) 1 else if (angle < 0) 0 else 0.5, ) } else { - stop("Unrecognized position: '", axis_position, "'", call. = FALSE) + abort(glue("Unrecognized position: '{axis_position}'")) } } @@ -435,10 +430,6 @@ warn_for_guide_position <- function(guide) { } if (length(unique(guide$key[[position_aes]])) == 1) { - warning( - "Position guide is perpendicular to the intended axis. ", - "Did you mean to specify a different guide `position`?", - call. = FALSE - ) + warn("Position guide is perpendicular to the intended axis. Did you mean to specify a different guide `position`?") } } diff --git a/R/labeller.r b/R/labeller.r index ef5565437e..46e38ae884 100644 --- a/R/labeller.r +++ b/R/labeller.r @@ -213,8 +213,7 @@ label_bquote <- function(rows = NULL, cols = NULL, # but only if there is no facetted variable also named `x` if ("x" %in% find_names(quoted) && !"x" %in% names(params)) { if (!has_warned) { - warning("Referring to `x` is deprecated, use variable name instead", - call. = FALSE) + warn("Referring to `x` is deprecated, use variable name instead") # The function is called for each facet so this avoids # multiple warnings has_warned <<- TRUE @@ -248,12 +247,12 @@ is_labeller <- function(x) inherits(x, "labeller") resolve_labeller <- function(rows, cols, labels) { if (is.null(cols) && is.null(rows)) { - stop("Supply one of rows or cols", call. = FALSE) + abort("Supply one of rows or cols") } if (attr(labels, "facet") == "wrap") { # Return either rows or cols for facet_wrap() if (!is.null(cols) && !is.null(rows)) { - stop("Cannot supply both rows and cols to facet_wrap()", call. = FALSE) + abort("Cannot supply both rows and cols to facet_wrap()") } cols %||% rows } else { @@ -446,8 +445,10 @@ labeller <- function(..., .rows = NULL, .cols = NULL, # Check that variable-specific labellers do not overlap with # margin-wide labeller if (any(names(dots) %in% names(labels))) { - stop("Conflict between .", attr(labels, "type"), " and ", - paste(names(dots), collapse = ", "), call. = FALSE) + abort(glue( + "Conflict between .{attr(labels, 'type')} and ", + glue_collapse(names(dots), ", ", last = " and ") + )) } } @@ -697,9 +698,9 @@ check_labeller <- function(labeller) { labeller <- function(labels) { Map(old_labeller, names(labels), labels) } - warning("The labeller API has been updated. Labellers taking `variable`", - "and `value` arguments are now deprecated. See labellers documentation.", - call. = FALSE) + warn(glue( + "The labeller API has been updated. Labellers taking `variable` ", + "and `value` arguments are now deprecated. See labellers documentation.")) } labeller diff --git a/R/layer-sf.R b/R/layer-sf.R index 13790ac9e8..b96075f500 100644 --- a/R/layer-sf.R +++ b/R/layer-sf.R @@ -64,7 +64,7 @@ geom_column <- function(data) { } else { # this may not be best in case more than one geometry list-column is present: if (length(w) > 1) - warning("more than one geometry column present: taking the first") + warn("more than one geometry column present: taking the first") w[[1]] } } diff --git a/R/layer.r b/R/layer.r index bf2cb510bf..1448762db0 100644 --- a/R/layer.r +++ b/R/layer.r @@ -67,16 +67,15 @@ layer <- function(geom = NULL, stat = NULL, inherit.aes = TRUE, check.aes = TRUE, check.param = TRUE, show.legend = NA, key_glyph = NULL, layer_class = Layer) { if (is.null(geom)) - stop("Attempted to create layer with no geom.", call. = FALSE) + abort("Attempted to create layer with no geom.") if (is.null(stat)) - stop("Attempted to create layer with no stat.", call. = FALSE) + abort("Attempted to create layer with no stat.") if (is.null(position)) - stop("Attempted to create layer with no position.", call. = FALSE) + abort("Attempted to create layer with no position.") # Handle show_guide/show.legend if (!is.null(params$show_guide)) { - warning("`show_guide` has been deprecated. Please use `show.legend` instead.", - call. = FALSE) + warn("`show_guide` has been deprecated. Please use `show.legend` instead.") show.legend <- params$show_guide params$show_guide <- NULL } @@ -118,11 +117,7 @@ layer <- function(geom = NULL, stat = NULL, # Warn about extra params and aesthetics extra_param <- setdiff(names(params), all) if (check.param && length(extra_param) > 0) { - warning( - "Ignoring unknown parameters: ", paste(extra_param, collapse = ", "), - call. = FALSE, - immediate. = TRUE - ) + warn(glue("Ignoring unknown parameters: ", paste(extra_param, collapse = ", "))) } extra_aes <- setdiff( @@ -130,11 +125,7 @@ layer <- function(geom = NULL, stat = NULL, c(geom$aesthetics(), stat$aesthetics()) ) if (check.aes && length(extra_aes) > 0) { - warning( - "Ignoring unknown aesthetics: ", paste(extra_aes, collapse = ", "), - call. = FALSE, - immediate. = TRUE - ) + warn(glue("Ignoring unknown aesthetics: ", paste(extra_aes, collapse = ", "))) } # adjust the legend draw key if requested @@ -164,7 +155,7 @@ validate_mapping <- function(mapping) { ) } - stop(msg, call. = FALSE) + abort(msg) } # For backward compatibility with pre-tidy-eval layers @@ -199,7 +190,7 @@ Layer <- ggproto("Layer", NULL, } else if (is.function(self$data)) { data <- self$data(plot_data) if (!is.data.frame(data)) { - stop("Data function must return a data.frame", call. = FALSE) + abort("Data function must return a data.frame") } data } else { @@ -251,7 +242,7 @@ Layer <- ggproto("Layer", NULL, paste0(vapply(nondata_cols, function(x) {paste0(x, " = ", as_label(aesthetics[[x]]))}, character(1)), collapse = ", "), ". \nDid you mistype the name of a data column or forget to add after_stat()?" ) - stop(msg, call. = FALSE) + abort(msg) } n <- nrow(data) @@ -316,7 +307,7 @@ Layer <- ggproto("Layer", NULL, paste0(vapply(nondata_stat_cols, function(x) {paste0(x, " = ", as_label(aesthetics[[x]]))}, character(1)), collapse = ", "), ". \nDid you map your stat in the wrong layer?" ) - stop(msg, call. = FALSE) + abort(msg) } names(stat_data) <- names(new) @@ -393,16 +384,14 @@ check_subclass <- function(x, subclass, obj <- find_global(name, env = env) if (is.null(obj) || !inherits(obj, subclass)) { - stop("Can't find `", argname, "` called \"", x, "\"", call. = FALSE) + abort(glue("Can't find `{argname}` called '{x}'")) } else { obj } } else { - stop( - "`", argname, "` must be either a string or a ", subclass, " object, ", - "not ", obj_desc(x), - call. = FALSE - ) + abort(glue( + "`{argname}` must be either a string or a {subclass} object, not {obj_desc(x)}" + )) } } diff --git a/R/layout.R b/R/layout.R index b1f9bb2a89..563485b9e7 100644 --- a/R/layout.R +++ b/R/layout.R @@ -292,7 +292,9 @@ scale_apply <- function(data, vars, method, scale_id, scales) { if (length(vars) == 0) return() if (nrow(data) == 0) return() - if (any(is.na(scale_id))) stop() + if (any(is.na(scale_id))) { + abort("`scale_id` must not be `NA`") + } scale_index <- unname(split( seq_along(scale_id), diff --git a/R/limits.r b/R/limits.r index 7d989b4e42..b03670ce00 100644 --- a/R/limits.r +++ b/R/limits.r @@ -76,7 +76,7 @@ lims <- function(...) { args <- list(...) if (any(!has_name(args))) { - stop("All arguments must be named", call. = FALSE) + abort("All arguments must be named") } Map(limits, args, names(args)) @@ -108,7 +108,9 @@ ylim <- function(...) { limits <- function(lims, var) UseMethod("limits") #' @export limits.numeric <- function(lims, var) { - stopifnot(length(lims) == 2) + if (length(lims) != 2) { + abort("`lims` must be a two-element vector") + } if (!any(is.na(lims)) && lims[1] > lims[2]) { trans <- "reverse" } else { @@ -133,17 +135,23 @@ limits.factor <- function(lims, var) { } #' @export limits.Date <- function(lims, var) { - stopifnot(length(lims) == 2) + if (length(lims) != 2) { + abort("`lims` must be a two-element vector") + } make_scale("date", var, limits = lims) } #' @export limits.POSIXct <- function(lims, var) { - stopifnot(length(lims) == 2) + if (length(lims) != 2) { + abort("`lims` must be a two-element vector") + } make_scale("datetime", var, limits = lims) } #' @export limits.POSIXlt <- function(lims, var) { - stopifnot(length(lims) == 2) + if (length(lims) != 2) { + abort("`lims` must be a two-element vector") + } make_scale("datetime", var, limits = as.POSIXct(lims)) } diff --git a/R/margins.R b/R/margins.R index e3382a1601..4d05457eef 100644 --- a/R/margins.R +++ b/R/margins.R @@ -240,7 +240,7 @@ justify_grobs <- function(grobs, x = NULL, y = NULL, hjust = 0.5, vjust = 0.5, return(lapply(grobs, justify_grobs, x, y, hjust, vjust, int_angle, debug)) } else { - stop("need individual grob or list of grobs as argument.") + abort("need individual grob or list of grobs as argument.") } } diff --git a/R/performance.R b/R/performance.R index 4f51f0d1f6..8ed0e53da3 100644 --- a/R/performance.R +++ b/R/performance.R @@ -1,14 +1,18 @@ # Fast data.frame constructor and indexing # No checking, recycling etc. unless asked for new_data_frame <- function(x = list(), n = NULL) { - if (length(x) != 0 && is.null(names(x))) stop("Elements must be named", call. = FALSE) + if (length(x) != 0 && is.null(names(x))) { + abort("Elements must be named") + } lengths <- vapply(x, length, integer(1)) if (is.null(n)) { n <- if (length(x) == 0 || min(lengths) == 0) 0 else max(lengths) } for (i in seq_along(x)) { if (lengths[i] == n) next - if (lengths[i] != 1) stop("Elements must equal the number of rows or 1", call. = FALSE) + if (lengths[i] != 1) { + abort("Elements must equal the number of rows or 1") + } x[[i]] <- rep(x[[i]], n) } @@ -23,7 +27,10 @@ data_frame <- function(...) { } data.frame <- function(...) { - stop('Please use `data_frame()` or `new_data_frame()` instead of `data.frame()` for better performance. See the vignette "ggplot2 internal programming guidelines" for details.', call. = FALSE) + abort(glue(" + Please use `data_frame()` or `new_data_frame()` instead of `data.frame()` for better performance. + See the vignette 'ggplot2 internal programming guidelines' for details. + ")) } split_matrix <- function(x, col_names = colnames(x)) { @@ -49,5 +56,8 @@ modify_list <- function(old, new) { old } modifyList <- function(...) { - stop('Please use `modify_list()` instead of `modifyList()` for better performance. See the vignette "ggplot2 internal programming guidelines" for details.', call. = FALSE) + abort(glue(" + Please use `modify_list()` instead of `modifyList()` for better performance. + See the vignette 'ggplot2 internal programming guidelines' for details. + ")) } diff --git a/R/plot-build.r b/R/plot-build.r index 714d200307..dcac060141 100644 --- a/R/plot-build.r +++ b/R/plot-build.r @@ -268,11 +268,11 @@ ggplot_gtable.ggplot_built <- function(data) { # "plot" means align to the entire plot (except margins and tag) title_pos <- theme$plot.title.position %||% "panel" if (!(title_pos %in% c("panel", "plot"))) { - stop('plot.title.position should be either "panel" or "plot".', call. = FALSE) + abort('plot.title.position should be either "panel" or "plot".') } caption_pos <- theme$plot.caption.position %||% "panel" if (!(caption_pos %in% c("panel", "plot"))) { - stop('plot.caption.position should be either "panel" or "plot".', call. = FALSE) + abort('plot.caption.position should be either "panel" or "plot".') } pans <- plot_table$layout[grepl("^panel", plot_table$layout$name), , drop = FALSE] @@ -314,8 +314,8 @@ ggplot_gtable.ggplot_built <- function(data) { "bottom", "bottomright") if (!(tag_pos == "manual" || tag_pos %in% valid_pos)) { - stop("plot.tag.position should be a coordinate or one of ", - paste(valid_pos, collapse = ', '), call. = FALSE) + abort(glue("plot.tag.position should be a coordinate or one of ", + glue_collapse(valid_pos, ', ', last = " or "))) } if (tag_pos == "manual") { diff --git a/R/plot-construction.r b/R/plot-construction.r index 7ef9f79ba5..7da90300b8 100644 --- a/R/plot-construction.r +++ b/R/plot-construction.r @@ -39,9 +39,7 @@ #' base + list(subset(mpg, fl == "p"), geom_smooth()) "+.gg" <- function(e1, e2) { if (missing(e2)) { - stop("Cannot use `+.gg()` with a single argument. ", - "Did you accidentally put + on a new line?", - call. = FALSE) + abort("Cannot use `+.gg()` with a single argument. Did you accidentally put + on a new line?") } # Get the name of what was passed in as e2, and pass along so that it @@ -51,9 +49,7 @@ if (is.theme(e1)) add_theme(e1, e2, e2name) else if (is.ggplot(e1)) add_ggplot(e1, e2, e2name) else if (is.ggproto(e1)) { - stop("Cannot add ggproto objects together.", - " Did you forget to add this object to a ggplot object?", - call. = FALSE) + abort("Cannot add ggproto objects together. Did you forget to add this object to a ggplot object?") } } @@ -88,7 +84,7 @@ ggplot_add <- function(object, plot, object_name) { } #' @export ggplot_add.default <- function(object, plot, object_name) { - stop("Can't add `", object_name, "` to a ggplot object.", call. = FALSE) + abort(glue("Can't add `{object_name}` to a ggplot object.")) } #' @export ggplot_add.NULL <- function(object, plot, object_name) { @@ -101,11 +97,10 @@ ggplot_add.data.frame <- function(object, plot, object_name) { } #' @export ggplot_add.function <- function(object, plot, object_name) { - stop( - "Can't add `", object_name, "` to a ggplot object.\n", - "Did you forget to add parentheses, as in `", - object_name, "()`?", call. = FALSE - ) + abort(glue( + "Can't add `{object_name}` to a ggplot object.\n", + "Did you forget to add parentheses, as in `{object_name}()`?" + )) } #' @export ggplot_add.theme <- function(object, plot, object_name) { diff --git a/R/plot.r b/R/plot.r index fc7cfe1bc8..0290b6e5c9 100644 --- a/R/plot.r +++ b/R/plot.r @@ -80,7 +80,7 @@ ggplot <- function(data = NULL, mapping = aes(), ..., ggplot.default <- function(data = NULL, mapping = aes(), ..., environment = parent.frame()) { if (!missing(mapping) && !inherits(mapping, "uneval")) { - stop("Mapping should be created with `aes() or `aes_()`.", call. = FALSE) + abort("Mapping should be created with `aes() or `aes_()`.") } data <- fortify(data, ...) @@ -106,7 +106,10 @@ ggplot.default <- function(data = NULL, mapping = aes(), ..., ggplot.function <- function(data = NULL, mapping = aes(), ..., environment = parent.frame()) { # Added to avoid functions end in ggplot.default - stop("You're passing a function as global data.\nHave you misspelled the `data` argument in `ggplot()`", call. = FALSE) + abort(glue(" + You're passing a function as global data. + Have you misspelled the `data` argument in `ggplot()` + ")) } plot_clone <- function(plot) { diff --git a/R/position-.r b/R/position-.r index 1df4d2c9e7..1b4224d3ca 100644 --- a/R/position-.r +++ b/R/position-.r @@ -63,7 +63,7 @@ Position <- ggproto("Position", }, compute_panel = function(self, data, params, scales) { - stop("Not implemented", call. = FALSE) + abort("Not implemented") } ) diff --git a/R/position-collide.r b/R/position-collide.r index cc4aa0e2df..5a02f53aad 100644 --- a/R/position-collide.r +++ b/R/position-collide.r @@ -21,8 +21,7 @@ collide_setup <- function(data, width = NULL, name, strategy, # # Suppress warning message since it's not reliable # if (!zero_range(range(widths))) { -# warning(name, " requires constant width: output may be incorrect", -# call. = FALSE) +# warn(name, " requires constant width: output may be incorrect") # } width <- widths[1] } @@ -49,7 +48,7 @@ collide <- function(data, width = NULL, name, strategy, intervals <- intervals[!is.na(intervals)] if (length(unique(intervals)) > 1 & any(diff(scale(intervals)) < -1e-6)) { - warning(name, " requires non-overlapping x intervals", call. = FALSE) + warn(glue("{name} requires non-overlapping x intervals")) # This is where the algorithm from [L. Wilkinson. Dot plots. # The American Statistician, 1999.] should be used } @@ -62,7 +61,7 @@ collide <- function(data, width = NULL, name, strategy, data$y <- data$ymax data } else { - stop("Neither y nor ymax defined") + abort("Neither y nor ymax defined") } } diff --git a/R/position-dodge.r b/R/position-dodge.r index e7895c1d56..b3ccfc1103 100644 --- a/R/position-dodge.r +++ b/R/position-dodge.r @@ -91,8 +91,7 @@ PositionDodge <- ggproto("PositionDodge", Position, flipped_aes <- has_flipped_aes(data) data <- flip_data(data, flipped_aes) if (is.null(data$xmin) && is.null(data$xmax) && is.null(self$width)) { - warning("Width not defined. Set with `position_dodge(width = ?)`", - call. = FALSE) + warn("Width not defined. Set with `position_dodge(width = ?)`") } if (identical(self$preserve, "total")) { diff --git a/R/position-dodge2.r b/R/position-dodge2.r index 8cb6cb6d77..2423bb396b 100644 --- a/R/position-dodge2.r +++ b/R/position-dodge2.r @@ -27,8 +27,7 @@ PositionDodge2 <- ggproto("PositionDodge2", PositionDodge, flipped_aes <- has_flipped_aes(data) data <- flip_data(data, flipped_aes) if (is.null(data$xmin) && is.null(data$xmax) && is.null(self$width)) { - warning("Width not defined. Set with `position_dodge2(width = ?)`", - call. = FALSE) + warn("Width not defined. Set with `position_dodge2(width = ?)`") } if (identical(self$preserve, "total")) { diff --git a/R/position-jitterdodge.R b/R/position-jitterdodge.R index 30685b12ec..0e078e6cf9 100644 --- a/R/position-jitterdodge.R +++ b/R/position-jitterdodge.R @@ -49,7 +49,7 @@ PositionJitterdodge <- ggproto("PositionJitterdodge", Position, # Adjust the x transformation based on the number of 'dodge' variables dodgecols <- intersect(c("fill", "colour", "linetype", "shape", "size", "alpha"), colnames(data)) if (length(dodgecols) == 0) { - stop("`position_jitterdodge()` requires at least one aesthetic to dodge by", call. = FALSE) + abort("`position_jitterdodge()` requires at least one aesthetic to dodge by") } ndodge <- lapply(data[dodgecols], levels) # returns NULL for numeric, i.e. non-dodge layers ndodge <- length(unique(unlist(ndodge))) diff --git a/R/position-stack.r b/R/position-stack.r index ab0f028c98..98ad6e5db1 100644 --- a/R/position-stack.r +++ b/R/position-stack.r @@ -242,17 +242,13 @@ PositionFill <- ggproto("PositionFill", PositionStack, stack_var <- function(data) { if (!is.null(data$ymax)) { if (any(data$ymin != 0 & data$ymax != 0, na.rm = TRUE)) { - warning("Stacking not well defined when not anchored on the axis", call. = FALSE) + warn("Stacking not well defined when not anchored on the axis") } "ymax" } else if (!is.null(data$y)) { "y" } else { - warning( - "Stacking requires either ymin & ymin or y aesthetics.\n", - "Maybe you want position = 'identity'?", - call. = FALSE - ) + warn("Stacking requires either ymin & ymin or y aesthetics.\nMaybe you want position = 'identity'?") NULL } } diff --git a/R/quick-plot.r b/R/quick-plot.r index 81188e9474..12038693ad 100644 --- a/R/quick-plot.r +++ b/R/quick-plot.r @@ -67,9 +67,11 @@ qplot <- function(x, y, ..., data, facets = NULL, margins = FALSE, caller_env <- parent.frame() - if (!missing(stat)) warning("`stat` is deprecated", call. = FALSE) - if (!missing(position)) warning("`position` is deprecated", call. = FALSE) - if (!is.character(geom)) stop("`geom` must be a character vector", call. = FALSE) + if (!missing(stat)) warn("`stat` is deprecated") + if (!missing(position)) warn("`position` is deprecated") + if (!is.character(geom)) { + abort("`geom` must be a character vector") + } exprs <- enquos(x = x, y = y, ...) is_missing <- vapply(exprs, quo_is_missing, logical(1)) diff --git a/R/save.r b/R/save.r index 965d9c115e..19cad7ab0f 100644 --- a/R/save.r +++ b/R/save.r @@ -89,12 +89,12 @@ parse_dpi <- function(dpi) { screen = 72, print = 300, retina = 320, - stop("Unknown DPI string", call. = FALSE) + abort("Unknown DPI string") ) } else if (is.numeric(dpi) && length(dpi) == 1) { dpi } else { - stop("DPI must be a single number or string", call. = FALSE) + abort("DPI must be a single number or string") } } @@ -120,9 +120,10 @@ plot_dim <- function(dim = c(NA, NA), scale = 1, units = c("in", "cm", "mm"), } if (limitsize && any(dim >= 50)) { - stop("Dimensions exceed 50 inches (height and width are specified in '", - units, "' not pixels). If you're sure you want a plot that big, use ", - "`limitsize = FALSE`.", call. = FALSE) + abort(glue(" + Dimensions exceed 50 inches (height and width are specified in '{units}' not pixels). + If you're sure you want a plot that big, use `limitsize = FALSE`. + ")) } dim @@ -159,12 +160,12 @@ plot_dev <- function(device, filename = NULL, dpi = 300) { } if (!is.character(device) || length(device) != 1) { - stop("`device` must be NULL, a string or a function.", call. = FALSE) + abort("`device` must be NULL, a string or a function.") } dev <- devices[[device]] if (is.null(dev)) { - stop("Unknown graphics device '", device, "'", call. = FALSE) + abort(glue("Unknown graphics device '{device}'")) } dev } diff --git a/R/scale-.r b/R/scale-.r index 1a79a640ea..b8f279ab89 100644 --- a/R/scale-.r +++ b/R/scale-.r @@ -359,7 +359,7 @@ Scale <- ggproto("Scale", NULL, aesthetics = aes(), scale_name = NULL, palette = function() { - stop("Not implemented", call. = FALSE) + abort("Not implemented") }, range = ggproto(NULL, Range), @@ -375,7 +375,7 @@ Scale <- ggproto("Scale", NULL, is_discrete = function() { - stop("Not implemented", call. = FALSE) + abort("Not implemented") }, train_df = function(self, df) { @@ -389,7 +389,7 @@ Scale <- ggproto("Scale", NULL, }, train = function(self, x) { - stop("Not implemented", call. = FALSE) + abort("Not implemented") }, reset = function(self) { @@ -414,7 +414,7 @@ Scale <- ggproto("Scale", NULL, }, transform = function(self, x) { - stop("Not implemented", call. = FALSE) + abort("Not implemented") }, map_df = function(self, df, i = NULL) { @@ -436,11 +436,11 @@ Scale <- ggproto("Scale", NULL, }, map = function(self, x, limits = self$get_limits()) { - stop("Not implemented", call. = FALSE) + abort("Not implemented") }, rescale = function(self, x, limits = self$get_limits(), range = self$dimension()) { - stop("Not implemented", call. = FALSE) + abort("Not implemented") }, get_limits = function(self) { @@ -458,11 +458,11 @@ Scale <- ggproto("Scale", NULL, }, dimension = function(self, expand = expansion(0, 0), limits = self$get_limits()) { - stop("Not implemented", call. = FALSE) + abort("Not implemented") }, get_breaks = function(self, limits = self$get_limits()) { - stop("Not implemented", call. = FALSE) + abort("Not implemented") }, break_positions = function(self, range = self$get_limits()) { @@ -470,19 +470,19 @@ Scale <- ggproto("Scale", NULL, }, get_breaks_minor = function(self, n = 2, b = self$break_positions(), limits = self$get_limits()) { - stop("Not implemented", call. = FALSE) + abort("Not implemented") }, get_labels = function(self, breaks = self$get_breaks()) { - stop("Not implemented", call. = FALSE) + abort("Not implemented") }, clone = function(self) { - stop("Not implemented", call. = FALSE) + abort("Not implemented") }, break_info = function(self, range = NULL) { - stop("Not implemented", call. = FALSE) + abort("Not implemented") }, axis_order = function(self) { @@ -513,7 +513,7 @@ check_breaks_labels <- function(breaks, labels) { bad_labels <- is.atomic(breaks) && is.atomic(labels) && length(breaks) != length(labels) if (bad_labels) { - stop("`breaks` and `labels` must have the same length", call. = FALSE) + abort("`breaks` and `labels` must have the same length") } TRUE @@ -602,7 +602,7 @@ ScaleContinuous <- ggproto("ScaleContinuous", Scale, } if (identical(self$breaks, NA)) { - stop("Invalid breaks specification. Use NULL, not NA", call. = FALSE) + abort("Invalid breaks specification. Use NULL, not NA") } if (zero_range(as.numeric(limits))) { @@ -612,7 +612,7 @@ ScaleContinuous <- ggproto("ScaleContinuous", Scale, breaks <- self$trans$breaks(limits, self$n.breaks) } else { if (!is.null(self$n.breaks)) { - warning("Ignoring n.breaks. Use a trans object that supports setting number of breaks", call. = FALSE) + warn("Ignoring n.breaks. Use a trans object that supports setting number of breaks") } breaks <- self$trans$breaks(limits) } @@ -640,7 +640,7 @@ ScaleContinuous <- ggproto("ScaleContinuous", Scale, } if (identical(self$minor_breaks, NA)) { - stop("Invalid minor_breaks specification. Use NULL, not NA", call. = FALSE) + abort("Invalid minor_breaks specification. Use NULL, not NA") } if (is.waive(self$minor_breaks)) { @@ -673,7 +673,7 @@ ScaleContinuous <- ggproto("ScaleContinuous", Scale, } if (identical(self$labels, NA)) { - stop("Invalid labels specification. Use NULL, not NA", call. = FALSE) + abort("Invalid labels specification. Use NULL, not NA") } if (is.waive(self$labels)) { @@ -685,7 +685,7 @@ ScaleContinuous <- ggproto("ScaleContinuous", Scale, } if (length(labels) != length(breaks)) { - stop("Breaks and labels are different lengths", call. = FALSE) + abort("Breaks and labels are different lengths") } labels @@ -768,7 +768,7 @@ ScaleDiscrete <- ggproto("ScaleDiscrete", Scale, pal <- self$palette.cache } else { if (!is.null(self$n.breaks.cache)) { - warning("Cached palette does not match requested", call. = FALSE) + warn("Cached palette does not match requested") } pal <- self$palette(n) self$palette.cache <- pal @@ -807,7 +807,7 @@ ScaleDiscrete <- ggproto("ScaleDiscrete", Scale, } if (identical(self$breaks, NA)) { - stop("Invalid breaks specification. Use NULL, not NA", call. = FALSE) + abort("Invalid breaks specification. Use NULL, not NA") } if (is.waive(self$breaks)) { @@ -839,7 +839,7 @@ ScaleDiscrete <- ggproto("ScaleDiscrete", Scale, } if (identical(self$labels, NA)) { - stop("Invalid labels specification. Use NULL, not NA", call. = FALSE) + abort("Invalid labels specification. Use NULL, not NA") } if (is.waive(self$labels)) { @@ -927,7 +927,7 @@ ScaleBinned <- ggproto("ScaleBinned", Scale, train = function(self, x) { if (!is.numeric(x)) { - stop("Binned scales only support continuous data", call. = FALSE) + abort("Binned scales only support continuous data") } if (length(x) == 0) { @@ -986,14 +986,14 @@ ScaleBinned <- ggproto("ScaleBinned", Scale, if (is.null(self$breaks)) { return(NULL) } else if (identical(self$breaks, NA)) { - stop("Invalid breaks specification. Use NULL, not NA", call. = FALSE) + abort("Invalid breaks specification. Use NULL, not NA") } else if (is.waive(self$breaks)) { if (self$nice.breaks) { if (!is.null(self$n.breaks) && trans_support_nbreaks(self$trans)) { breaks <- self$trans$breaks(limits, n = self$n.breaks) } else { if (!is.null(self$n.breaks)) { - warning("Ignoring n.breaks. Use a trans object that supports setting number of breaks", call. = FALSE) + warn("Ignoring n.breaks. Use a trans object that supports setting number of breaks") } breaks <- self$trans$breaks(limits) } @@ -1031,7 +1031,7 @@ ScaleBinned <- ggproto("ScaleBinned", Scale, breaks <- self$breaks(limits, n.breaks = n.breaks) } else { if (!is.null(self$n.breaks)) { - warning("Ignoring n.breaks. Use a breaks function that supports setting number of breaks", call. = FALSE) + warn("Ignoring n.breaks. Use a breaks function that supports setting number of breaks") } breaks <- self$breaks(limits) } @@ -1056,7 +1056,7 @@ ScaleBinned <- ggproto("ScaleBinned", Scale, if (is.null(self$labels)) { return(NULL) } else if (identical(self$labels, NA)) { - stop("Invalid labels specification. Use NULL, not NA", call. = FALSE) + abort("Invalid labels specification. Use NULL, not NA") } else if (is.waive(self$labels)) { labels <- self$trans$format(breaks) } else if (is.function(self$labels)) { @@ -1065,7 +1065,7 @@ ScaleBinned <- ggproto("ScaleBinned", Scale, labels <- self$labels } if (length(labels) != length(breaks)) { - stop("Breaks and labels are different lengths") + abort("Breaks and labels are different lengths") } labels }, @@ -1124,7 +1124,7 @@ check_transformation <- function(x, transformed, name, axis) { } else { "discrete" } - warning("Transformation introduced infinite values in ", type, " ", axis, "-axis", call. = FALSE) + warn(glue("Transformation introduced infinite values in {type} {axis}-axis")) } } diff --git a/R/scale-alpha.r b/R/scale-alpha.r index 9c59f09d20..71dcf264c0 100644 --- a/R/scale-alpha.r +++ b/R/scale-alpha.r @@ -34,7 +34,7 @@ scale_alpha_binned <- function(..., range = c(0.1, 1)) { #' @rdname scale_alpha #' @export scale_alpha_discrete <- function(...) { - warning("Using alpha for a discrete variable is not advised.", call. = FALSE) + warn("Using alpha for a discrete variable is not advised.") scale_alpha_ordinal(...) } diff --git a/R/scale-binned.R b/R/scale-binned.R index 4a869bc726..719d228a93 100644 --- a/R/scale-binned.R +++ b/R/scale-binned.R @@ -61,7 +61,7 @@ ScaleBinnedPosition <- ggproto("ScaleBinnedPosition", ScaleBinned, train = function(self, x) { if (!is.numeric(x)) { - stop("Binned scales only support continuous data", call. = FALSE) + abort("Binned scales only support continuous data") } if (length(x) == 0 || self$after.stat) return() diff --git a/R/scale-brewer.r b/R/scale-brewer.r index aa5d95d11d..3975328ebc 100644 --- a/R/scale-brewer.r +++ b/R/scale-brewer.r @@ -90,7 +90,7 @@ scale_colour_distiller <- function(..., type = "seq", palette = 1, direction = - # warn about using a qualitative brewer palette to generate the gradient type <- match.arg(type, c("seq", "div", "qual")) if (type == "qual") { - warning("Using a discrete colour palette in a continuous scale.\n Consider using type = \"seq\" or type = \"div\" instead", call. = FALSE) + warn("Using a discrete colour palette in a continuous scale.\n Consider using type = \"seq\" or type = \"div\" instead") } continuous_scale(aesthetics, "distiller", gradient_n_pal(brewer_pal(type, palette, direction)(7), values, space), na.value = na.value, guide = guide, ...) @@ -103,7 +103,7 @@ scale_colour_distiller <- function(..., type = "seq", palette = 1, direction = - scale_fill_distiller <- function(..., type = "seq", palette = 1, direction = -1, values = NULL, space = "Lab", na.value = "grey50", guide = "colourbar", aesthetics = "fill") { type <- match.arg(type, c("seq", "div", "qual")) if (type == "qual") { - warning("Using a discrete colour palette in a continuous scale.\n Consider using type = \"seq\" or type = \"div\" instead", call. = FALSE) + warn("Using a discrete colour palette in a continuous scale.\n Consider using type = \"seq\" or type = \"div\" instead") } continuous_scale(aesthetics, "distiller", gradient_n_pal(brewer_pal(type, palette, direction)(7), values, space), na.value = na.value, guide = guide, ...) @@ -115,7 +115,7 @@ scale_colour_fermenter <- function(..., type = "seq", palette = 1, direction = - # warn about using a qualitative brewer palette to generate the gradient type <- match.arg(type, c("seq", "div", "qual")) if (type == "qual") { - warning("Using a discrete colour palette in a binned scale.\n Consider using type = \"seq\" or type = \"div\" instead", call. = FALSE) + warn("Using a discrete colour palette in a binned scale.\n Consider using type = \"seq\" or type = \"div\" instead") } binned_scale(aesthetics, "fermenter", binned_pal(brewer_pal(type, palette, direction)), na.value = na.value, guide = guide, ...) } @@ -125,7 +125,7 @@ scale_colour_fermenter <- function(..., type = "seq", palette = 1, direction = - scale_fill_fermenter <- function(..., type = "seq", palette = 1, direction = -1, na.value = "grey50", guide = "coloursteps", aesthetics = "fill") { type <- match.arg(type, c("seq", "div", "qual")) if (type == "qual") { - warning("Using a discrete colour palette in a binned scale.\n Consider using type = \"seq\" or type = \"div\" instead", call. = FALSE) + warn("Using a discrete colour palette in a binned scale.\n Consider using type = \"seq\" or type = \"div\" instead") } binned_scale(aesthetics, "fermenter", binned_pal(brewer_pal(type, palette, direction)), na.value = na.value, guide = guide, ...) } diff --git a/R/scale-colour.r b/R/scale-colour.r index e9637a9120..fd9cc2f1f4 100644 --- a/R/scale-colour.r +++ b/R/scale-colour.r @@ -44,7 +44,7 @@ scale_colour_continuous <- function(..., type, gradient = scale_colour_gradient(...), viridis = scale_colour_viridis_c(...), - stop("Unknown scale type", call. = FALSE) + abort("Unknown scale type") ) } @@ -56,7 +56,7 @@ scale_fill_continuous <- function(..., type, gradient = scale_fill_gradient(...), viridis = scale_fill_viridis_c(...), - stop("Unknown scale type", call. = FALSE) + abort("Unknown scale type") ) } @@ -69,7 +69,7 @@ scale_colour_binned <- function(..., type, gradient = scale_colour_steps(...), viridis = scale_colour_viridis_b(...), - stop("Unknown scale type", call. = FALSE) + abort("Unknown scale type") ) } @@ -82,6 +82,6 @@ scale_fill_binned <- function(..., type, gradient = scale_fill_steps(...), viridis = scale_fill_viridis_b(...), - stop("Unknown scale type", call. = FALSE) + abort("Unknown scale type") ) } diff --git a/R/scale-expansion.r b/R/scale-expansion.r index ee0e6952b4..d733460046 100644 --- a/R/scale-expansion.r +++ b/R/scale-expansion.r @@ -36,10 +36,9 @@ #' scale_y_continuous(expand = expansion(mult = .05)) #' expansion <- function(mult = 0, add = 0) { - stopifnot( - is.numeric(mult), (length(mult) %in% 1:2), - is.numeric(add), (length(add) %in% 1:2) - ) + if (!(is.numeric(mult) && (length(mult) %in% 1:2) && is.numeric(add) && (length(add) %in% 1:2))) { + abort("`mult` and `add` must be numeric vectors with 1 or 2 elements") + } mult <- rep(mult, length.out = 2) add <- rep(add, length.out = 2) @@ -66,10 +65,9 @@ expand_scale <- function(mult = 0, add = 0) { #' @noRd #' expand_range4 <- function(limits, expand) { - stopifnot( - is.numeric(expand), - length(expand) %in% c(2,4) - ) + if (!(is.numeric(expand) && length(expand) %in% c(2,4))) { + abort("`expand` must be a numeric vector with 1 or 2 elements") + } if (all(!is.finite(limits))) { return(c(-Inf, Inf)) diff --git a/R/scale-linetype.r b/R/scale-linetype.r index e7c7ac7d6e..0287f57e51 100644 --- a/R/scale-linetype.r +++ b/R/scale-linetype.r @@ -43,7 +43,7 @@ scale_linetype_binned <- function(..., na.value = "blank") { #' @rdname scale_linetype #' @export scale_linetype_continuous <- function(...) { - stop("A continuous variable can not be mapped to linetype", call. = FALSE) + abort("A continuous variable can not be mapped to linetype") } #' @rdname scale_linetype #' @export diff --git a/R/scale-manual.r b/R/scale-manual.r index 21a0e62451..190fdf9bb0 100644 --- a/R/scale-manual.r +++ b/R/scale-manual.r @@ -134,17 +134,17 @@ manual_scale <- function(aesthetic, values = NULL, breaks = waiver(), ...) { if (is.vector(values) && is.null(names(values)) && !is.waive(breaks) && !is.null(breaks)) { if (length(breaks) != length(values)) { - stop("Differing number of values and breaks in manual scale. ", - length(values), " values provided compared to ", length(breaks), - " breaks.", call. = FALSE) + abort(glue(" + Differing number of values and breaks in manual scale. + {length(values)} values provided compared to {length(breaks)} breaks. + ")) } names(values) <- breaks } pal <- function(n) { if (n > length(values)) { - stop("Insufficient values in manual scale. ", n, " needed but only ", - length(values), " provided.", call. = FALSE) + abort(glue("Insufficient values in manual scale. {n} needed but only {length(values)} provided.")) } values } diff --git a/R/scale-shape.r b/R/scale-shape.r index 8c496f1d92..257de3d028 100644 --- a/R/scale-shape.r +++ b/R/scale-shape.r @@ -54,7 +54,7 @@ scale_shape_discrete <- scale_shape #' @export #' @usage NULL scale_shape_ordinal <- function(...) { - warning("Using shapes for an ordinal variable is not advised", call. = FALSE) + warn("Using shapes for an ordinal variable is not advised") scale_shape(...) } @@ -62,5 +62,5 @@ scale_shape_ordinal <- function(...) { #' @export #' @usage NULL scale_shape_continuous <- function(...) { - stop("A continuous variable can not be mapped to shape", call. = FALSE) + abort("A continuous variable can not be mapped to shape") } diff --git a/R/scale-size.r b/R/scale-size.r index ea6f81003a..bb5caf1479 100644 --- a/R/scale-size.r +++ b/R/scale-size.r @@ -76,7 +76,7 @@ scale_size_binned <- function(name = waiver(), breaks = waiver(), labels = waive #' @export #' @usage NULL scale_size_discrete <- function(...) { - warning("Using size for a discrete variable is not advised.", call. = FALSE) + warn("Using size for a discrete variable is not advised.") scale_size_ordinal(...) } diff --git a/R/scale-view.r b/R/scale-view.r index e7a77ff6cf..689daa97ca 100644 --- a/R/scale-view.r +++ b/R/scale-view.r @@ -95,8 +95,8 @@ view_scale_empty <- function() { get_breaks = function() NULL, get_breaks_minor = function() NULL, get_labels = function(breaks = NULL) breaks, - rescale = function(x) stop("Not implemented", call. = FALSE), - map = function(x) stop("Not implemented", call. = FALSE), + rescale = function(x) abort("Not implemented"), + map = function(x) abort("Not implemented"), make_title = function(title) title, break_positions = function() NULL, break_positions_minor = function() NULL diff --git a/R/stat-.r b/R/stat-.r index d7ff5983f6..f3d3bc4492 100644 --- a/R/stat-.r +++ b/R/stat-.r @@ -96,8 +96,7 @@ Stat <- ggproto("Stat", dapply(data, "PANEL", function(data) { scales <- layout$get_scales(data$PANEL[1]) tryCatch(do.call(self$compute_panel, args), error = function(e) { - warning("Computation failed in `", snake_class(self), "()`:\n", - e$message, call. = FALSE) + warn(glue("Computation failed in `{snake_class(self)}()`:\n{e$message}")) new_data_frame() }) }) @@ -125,7 +124,7 @@ Stat <- ggproto("Stat", }, compute_group = function(self, data, scales) { - stop("Not implemented", call. = FALSE) + abort("Not implemented") }, finish_layer = function(self, data, params) { diff --git a/R/stat-bin.r b/R/stat-bin.r index b3093fd9ea..c81ff537ee 100644 --- a/R/stat-bin.r +++ b/R/stat-bin.r @@ -89,38 +89,37 @@ StatBin <- ggproto("StatBin", Stat, has_x <- !(is.null(data$x) && is.null(params$x)) has_y <- !(is.null(data$y) && is.null(params$y)) if (!has_x && !has_y) { - stop("stat_bin() requires an x or y aesthetic.", call. = FALSE) + abort("stat_bin() requires an x or y aesthetic.") } if (has_x && has_y) { - stop("stat_bin() can only have an x or y aesthetic.", call. = FALSE) + abort("stat_bin() can only have an x or y aesthetic.") } x <- flipped_names(params$flipped_aes)$x if (is.integer(data[[x]])) { - stop('StatBin requires a continuous ', x, ' variable: the ', - x, ' variable is discrete. Perhaps you want stat="count"?', - call. = FALSE) + abort(glue("StatBin requires a continuous {x} variable: the {x} variable is discrete.", + "Perhaps you want stat=\"count\"?")) } if (!is.null(params$drop)) { - warning("`drop` is deprecated. Please use `pad` instead.", call. = FALSE) + warn("`drop` is deprecated. Please use `pad` instead.") params$drop <- NULL } if (!is.null(params$origin)) { - warning("`origin` is deprecated. Please use `boundary` instead.", call. = FALSE) + warn("`origin` is deprecated. Please use `boundary` instead.") params$boundary <- params$origin params$origin <- NULL } if (!is.null(params$right)) { - warning("`right` is deprecated. Please use `closed` instead.", call. = FALSE) + warn("`right` is deprecated. Please use `closed` instead.") params$closed <- if (params$right) "right" else "left" params$right <- NULL } if (!is.null(params$width)) { - stop("`width` is deprecated. Do you want `geom_bar()`?", call. = FALSE) + abort("`width` is deprecated. Do you want `geom_bar()`?") } if (!is.null(params$boundary) && !is.null(params$center)) { - stop("Only one of `boundary` and `center` may be specified.", call. = FALSE) + abort("Only one of `boundary` and `center` may be specified.") } if (is.null(params$breaks) && is.null(params$binwidth) && is.null(params$bins)) { diff --git a/R/stat-bin2d.r b/R/stat-bin2d.r index dabc3e1b62..f6fc9dbb5e 100644 --- a/R/stat-bin2d.r +++ b/R/stat-bin2d.r @@ -124,12 +124,12 @@ bin2d_breaks <- function(scale, breaks = NULL, origin = NULL, binwidth = NULL, if (is.null(binwidth) || identical(binwidth, NA)) { binwidth <- diff(range) / bins } - stopifnot(is.numeric(binwidth), length(binwidth) == 1) + if (!(is.numeric(binwidth) && length(binwidth) == 1)) abort("`binwidth` must be a numeric scalar") if (is.null(origin) || identical(origin, NA)) { origin <- round_any(range[1], binwidth, floor) } - stopifnot(is.numeric(origin), length(origin) == 1) + if (!(is.numeric(origin) && length(origin) == 1)) abort("`origin` must be a numeric scalar") breaks <- seq(origin, range[2] + binwidth, binwidth) adjust_breaks(breaks, right) diff --git a/R/stat-bindot.r b/R/stat-bindot.r index 2386a46665..4dbb738895 100644 --- a/R/stat-bindot.r +++ b/R/stat-bindot.r @@ -73,7 +73,7 @@ StatBindot <- ggproto("StatBindot", Stat, # Check that weights are whole numbers (for dots, weights must be whole) if (!is.null(data$weight) && any(!is.wholenumber(data$weight)) && any(data$weight < 0)) { - stop("Weights for stat_bindot must be nonnegative integers.") + abort("Weights for stat_bindot must be nonnegative integers.") } if (binaxis == "x") { diff --git a/R/stat-boxplot.r b/R/stat-boxplot.r index 8802a0ae36..972c0813f7 100644 --- a/R/stat-boxplot.r +++ b/R/stat-boxplot.r @@ -65,15 +65,13 @@ StatBoxplot <- ggproto("StatBoxplot", Stat, has_x <- !(is.null(data$x) && is.null(params$x)) has_y <- !(is.null(data$y) && is.null(params$y)) if (!has_x && !has_y) { - stop("stat_boxplot() requires an x or y aesthetic.", call. = FALSE) + abort("stat_boxplot() requires an x or y aesthetic.") } params$width <- params$width %||% (resolution(data$x %||% 0) * 0.75) if (is.double(data$x) && !has_groups(data) && any(data$x != data$x[1L])) { - warning( - "Continuous ", flipped_names(params$flipped_aes)$x, " aesthetic -- did you forget aes(group=...)?", - call. = FALSE) + warn(glue("Continuous {flipped_names(params$flipped_aes)$x} aesthetic -- did you forget aes(group=...)?")) } params diff --git a/R/stat-contour.r b/R/stat-contour.r index 45b6cfae7c..37c95cb582 100644 --- a/R/stat-contour.r +++ b/R/stat-contour.r @@ -209,7 +209,7 @@ iso_to_path <- function(iso, group = 1) { lengths <- vapply(iso, function(x) length(x$x), integer(1)) if (all(lengths == 0)) { - warning("stat_contour(): Zero contours were generated", call. = FALSE) + warn("stat_contour(): Zero contours were generated") return(new_data_frame()) } diff --git a/R/stat-count.r b/R/stat-count.r index 0ec138d94b..cce23f237a 100644 --- a/R/stat-count.r +++ b/R/stat-count.r @@ -27,7 +27,7 @@ stat_count <- function(mapping = NULL, data = NULL, ... ) if (!is.null(params$y)) { - stop("stat_count() must not be used with a y aesthetic.", call. = FALSE) + abort("stat_count() must not be used with a y aesthetic.") } layer( @@ -58,10 +58,10 @@ StatCount <- ggproto("StatCount", Stat, has_x <- !(is.null(data$x) && is.null(params$x)) has_y <- !(is.null(data$y) && is.null(params$y)) if (!has_x && !has_y) { - stop("stat_count() requires an x or y aesthetic.", call. = FALSE) + abort("stat_count() requires an x or y aesthetic.") } if (has_x && has_y) { - stop("stat_count() can only have an x or y aesthetic.", call. = FALSE) + abort("stat_count() can only have an x or y aesthetic.") } params diff --git a/R/stat-density.r b/R/stat-density.r index 5690747126..02e2fe209c 100644 --- a/R/stat-density.r +++ b/R/stat-density.r @@ -75,7 +75,7 @@ StatDensity <- ggproto("StatDensity", Stat, has_x <- !(is.null(data$x) && is.null(params$x)) has_y <- !(is.null(data$y) && is.null(params$y)) if (!has_x && !has_y) { - stop("stat_density() requires an x or y aesthetic.", call. = FALSE) + abort("stat_density() requires an x or y aesthetic.") } params @@ -111,7 +111,7 @@ compute_density <- function(x, w, from, to, bw = "nrd0", adjust = 1, # if less than 2 points return data frame of NAs and a warning if (nx < 2) { - warning("Groups with fewer than two data points have been dropped.", call. = FALSE) + warn("Groups with fewer than two data points have been dropped.") return(new_data_frame(list( x = NA_real_, density = NA_real_, diff --git a/R/stat-function.r b/R/stat-function.r index 3ac7538986..50d1a672db 100644 --- a/R/stat-function.r +++ b/R/stat-function.r @@ -67,10 +67,10 @@ stat_function <- function(mapping = NULL, data = NULL, # Warn if supplied mapping and/or data is going to be overwritten if (!is.null(mapping)) { - warning("`mapping` is not used by stat_function()", call. = FALSE) + warn("`mapping` is not used by stat_function()") } if (!is.null(data)) { - warning("`data` is not used by stat_function()", call. = FALSE) + warn("`data` is not used by stat_function()") } layer( diff --git a/R/stat-qq-line.R b/R/stat-qq-line.R index 9dc7f9a305..83d3a25b4f 100644 --- a/R/stat-qq-line.R +++ b/R/stat-qq-line.R @@ -64,7 +64,7 @@ StatQqLine <- ggproto("StatQqLine", Stat, if (is.null(quantiles)) { quantiles <- stats::ppoints(n) } else { - stopifnot(length(quantiles) == n) + if (length(quantiles) != n) abort("`quantiles` must have the same length as the data") } theoretical <- do.call( @@ -73,10 +73,7 @@ StatQqLine <- ggproto("StatQqLine", Stat, ) if (length(line.p) != 2) { - stop( - "Cannot fit line quantiles ", line.p, - ". Parameter line.p must have length 2.", - call. = FALSE) + abort(glue("Cannot fit line quantiles {line.p}. Parameter line.p must have length 2.")) } x_coords <- do.call(distribution, c(list(p = line.p), dparams)) diff --git a/R/stat-qq.r b/R/stat-qq.r index edbcc117fa..5d3d305996 100644 --- a/R/stat-qq.r +++ b/R/stat-qq.r @@ -93,8 +93,8 @@ StatQq <- ggproto("StatQq", Stat, # Compute theoretical quantiles if (is.null(quantiles)) { quantiles <- stats::ppoints(n) - } else { - stopifnot(length(quantiles) == n) + } else if (length(quantiles) != n) { + abort("length of quantiles must match length of data") } theoretical <- do.call(distribution, c(list(p = quote(quantiles)), dparams)) diff --git a/R/stat-summary.r b/R/stat-summary.r index b4a43ebb8d..ba3b0cb11b 100644 --- a/R/stat-summary.r +++ b/R/stat-summary.r @@ -237,7 +237,7 @@ wrap_hmisc <- function(fun) { function(x, ...) { if (!requireNamespace("Hmisc", quietly = TRUE)) - stop("Hmisc package required for this function", call. = FALSE) + abort("Hmisc package required for this function") fun <- getExportedValue("Hmisc", fun) result <- do.call(fun, list(x = quote(x), ...)) diff --git a/R/stat-ydensity.r b/R/stat-ydensity.r index b246c477fa..d53a243c2d 100644 --- a/R/stat-ydensity.r +++ b/R/stat-ydensity.r @@ -119,7 +119,7 @@ StatYdensity <- ggproto("StatYdensity", Stat, calc_bw <- function(x, bw) { if (is.character(bw)) { if (length(x) < 2) - stop("need at least 2 points to select a bandwidth automatically", call. = FALSE) + abort("need at least 2 points to select a bandwidth automatically") bw <- switch( to_lower_ascii(bw), nrd0 = stats::bw.nrd0(x), @@ -129,7 +129,7 @@ calc_bw <- function(x, bw) { sj = , `sj-ste` = stats::bw.SJ(x, method = "ste"), `sj-dpi` = stats::bw.SJ(x, method = "dpi"), - stop("unknown bandwidth rule") + abort("unknown bandwidth rule") ) } bw diff --git a/R/summarise-plot.R b/R/summarise-plot.R index 6083089ac5..edbbaf9711 100644 --- a/R/summarise-plot.R +++ b/R/summarise-plot.R @@ -59,7 +59,7 @@ NULL #' @rdname summarise_plot #' @export summarise_layout = function(p) { - stopifnot(inherits(p, "ggplot_built")) + if (!inherits(p, "ggplot_built")) abort("`p` must be a ggplot_build object") l <- p$layout layout <- l$layout @@ -96,7 +96,7 @@ summarise_layout = function(p) { #' @rdname summarise_plot #' @export summarise_coord = function(p) { - stopifnot(inherits(p, "ggplot_built")) + if (!inherits(p, "ggplot_built")) abort("`p` must be a ggplot_build object") # Given a transform object, find the log base; if the transform object is # NULL, or if it's not a log transform, return NA. @@ -119,7 +119,7 @@ summarise_coord = function(p) { #' @rdname summarise_plot #' @export summarise_layers <- function(p) { - stopifnot(inherits(p, "ggplot_built")) + if (!inherits(p, "ggplot_built")) abort("`p` must be a ggplot_build object") # Default mappings. Make sure it's a regular list instead of an uneval # object. diff --git a/R/theme-current.R b/R/theme-current.R index 58adaf49fc..7e74c56990 100644 --- a/R/theme-current.R +++ b/R/theme-current.R @@ -74,8 +74,10 @@ theme_get <- function() { theme_set <- function(new) { missing <- setdiff(names(ggplot_global$theme_grey), names(new)) if (length(missing) > 0) { - warning("New theme missing the following elements: ", - paste(missing, collapse = ", "), call. = FALSE) + warn(glue( + "New theme missing the following elements: ", + glue_collapse(missing, ", ", last = " and ") + )) } old <- ggplot_global$theme_current @@ -99,7 +101,7 @@ theme_replace <- function(...) { #' @export "%+replace%" <- function(e1, e2) { if (!is.theme(e1) || !is.theme(e2)) { - stop("%+replace% requires two theme objects", call. = FALSE) + abort("%+replace% requires two theme objects") } # Can't use modifyList here since it works recursively and drops NULLs diff --git a/R/theme-elements.r b/R/theme-elements.r index 29f8b708df..366d599639 100644 --- a/R/theme-elements.r +++ b/R/theme-elements.r @@ -118,11 +118,7 @@ element_text <- function(family = NULL, face = NULL, colour = NULL, length(hjust), length(vjust), length(angle), length(lineheight) ) if (n > 1) { - warning( - "Vectorized input to `element_text()` is not officially supported.\n", - "Results may be unexpected or may change in future versions of ggplot2.", - call. = FALSE - ) + warn("Vectorized input to `element_text()` is not officially supported.\nResults may be unexpected or may change in future versions of ggplot2.") } @@ -445,7 +441,7 @@ validate_element <- function(el, elname, element_tree) { eldef <- element_tree[[elname]] if (is.null(eldef)) { - stop("Theme element `", elname, "` is not defined in the element hierarchy.", call. = FALSE) + abort(glue("Theme element `{elname}` is not defined in the element hierarchy.")) } # NULL values for elements are OK @@ -455,12 +451,12 @@ validate_element <- function(el, elname, element_tree) { # Need to be a bit looser here since sometimes it's a string like "top" # but sometimes its a vector like c(0,0) if (!is.character(el) && !is.numeric(el)) - stop("Theme element `", elname, "` must be a string or numeric vector.", call. = FALSE) + abort(glue("Theme element `{elname}` must be a string or numeric vector.")) } else if (eldef$class == "margin") { if (!is.unit(el) && length(el) == 4) - stop("Theme element `", elname, "` must be a unit vector of length 4.", call. = FALSE) + abort(glue("Theme element `{elname}` must be a unit vector of length 4.")) } else if (!inherits(el, eldef$class) && !inherits(el, "element_blank")) { - stop("Theme element `", elname, "` must be an `", eldef$class, "` object.", call. = FALSE) + abort(glue("Theme element `{elname}` must be an `{eldef$class}` object.")) } invisible() } diff --git a/R/theme.r b/R/theme.r index 31ce4827ec..4441a213cb 100644 --- a/R/theme.r +++ b/R/theme.r @@ -368,31 +368,26 @@ theme <- function(line, elements <- find_args(..., complete = NULL, validate = NULL, element_tree = NULL) if (!is.null(elements$axis.ticks.margin)) { - warning("`axis.ticks.margin` is deprecated. Please set `margin` property ", - " of `axis.text` instead", call. = FALSE) + warn("`axis.ticks.margin` is deprecated. Please set `margin` property of `axis.text` instead") elements$axis.ticks.margin <- NULL } if (!is.null(elements$panel.margin)) { - warning("`panel.margin` is deprecated. Please use `panel.spacing` property ", - "instead", call. = FALSE) + warn("`panel.margin` is deprecated. Please use `panel.spacing` property instead") elements$panel.spacing <- elements$panel.margin elements$panel.margin <- NULL } if (!is.null(elements$panel.margin.x)) { - warning("`panel.margin.x` is deprecated. Please use `panel.spacing.x` property ", - "instead", call. = FALSE) + warn("`panel.margin.x` is deprecated. Please use `panel.spacing.x` property instead") elements$panel.spacing.x <- elements$panel.margin.x elements$panel.margin.x <- NULL } if (!is.null(elements$panel.margin.y)) { - warning("`panel.margin` is deprecated. Please use `panel.spacing` property ", - "instead", call. = FALSE) + warn("`panel.margin` is deprecated. Please use `panel.spacing` property instead") elements$panel.spacing.y <- elements$panel.margin.y elements$panel.margin.y <- NULL } if (is.unit(elements$legend.margin) && !is.margin(elements$legend.margin)) { - warning("`legend.margin` must be specified using `margin()`. For the old ", - "behavior use legend.spacing", call. = FALSE) + warn("`legend.margin` must be specified using `margin()`. For the old behavior use legend.spacing") elements$legend.spacing <- elements$legend.margin elements$legend.margin <- margin() } @@ -484,8 +479,7 @@ plot_theme <- function(x, default = theme_get()) { #' @keywords internal add_theme <- function(t1, t2, t2name) { if (!is.list(t2)) { # in various places in the code base, simple lists are used as themes - stop("Can't add `", t2name, "` to a theme object.", - call. = FALSE) + abort(glue("Can't add `{t2name}` to a theme object.")) } # If t2 is a complete theme or t1 is NULL, just return t2 @@ -570,7 +564,7 @@ calc_element <- function(element, theme, verbose = FALSE, skip_blank = FALSE) { # it is of the class specified in element_tree if (!is.null(el_out) && !inherits(el_out, element_tree[[element]]$class)) { - stop(element, " should have class ", element_tree[[element]]$class) + abort(glue("{element} should have class {ggplot_global$element_tree[[element]]$class}")) } # Get the names of parents from the inheritance tree @@ -593,8 +587,8 @@ calc_element <- function(element, theme, verbose = FALSE, skip_blank = FALSE) { return(el_out) # no null properties remaining, return element } - stop("Theme element '", element, "' has NULL property without default: ", - paste(names(nullprops)[nullprops], collapse = ", ")) + abort(glue("Theme element `{element}` has NULL property without default: ", + glue_collapse(names(nullprops)[nullprops], ", ", last = " and "))) } # Calculate the parent objects' inheritance @@ -649,7 +643,7 @@ merge_element.default <- function(new, old) { } # otherwise we can't merge - stop("No method for merging ", class(new)[1], " into ", class(old)[1], call. = FALSE) + abort(glue("No method for merging {class(new)[1]} into {class(old)[1]}")) } #' @rdname merge_element @@ -669,7 +663,7 @@ merge_element.element <- function(new, old) { # actual merging can only happen if classes match if (!inherits(new, class(old)[1])) { - stop("Only elements of the same class can be merged", call. = FALSE) + abort("Only elements of the same class can be merged") } # Override NULL properties of new with the values in old diff --git a/R/utilities-break.r b/R/utilities-break.r index b6606e1c95..e9e90e22af 100644 --- a/R/utilities-break.r +++ b/R/utilities-break.r @@ -30,7 +30,7 @@ cut_interval <- function(x, n = NULL, length = NULL, ...) { cut_number <- function(x, n = NULL, ...) { brk <- breaks(x, "n", n) if (anyDuplicated(brk)) - stop("Insufficient data values to produce ", n, " bins.", call. = FALSE) + abort(glue("Insufficient data values to produce {n} bins.")) cut(x, brk , include.lowest = TRUE, ...) } @@ -60,7 +60,7 @@ cut_width <- function(x, width, center = NULL, boundary = NULL, closed = c("righ # Determine boundary 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.") } if (is.null(boundary)) { if (is.null(center)) { @@ -93,7 +93,7 @@ find_origin <- function(x_range, width, boundary) { breaks <- function(x, equal, nbins = NULL, binwidth = NULL) { equal <- match.arg(equal, c("numbers", "width")) if ((!is.null(nbins) && !is.null(binwidth)) || (is.null(nbins) && is.null(binwidth))) { - stop("Specify exactly one of n and width") + abort("Specify exactly one of n and width") } rng <- range(x, na.rm = TRUE, finite = TRUE) diff --git a/R/utilities-grid.r b/R/utilities-grid.r index 811e1ab79f..7cc4d3e279 100644 --- a/R/utilities-grid.r +++ b/R/utilities-grid.r @@ -21,7 +21,7 @@ width_cm <- function(x) { } else if (is.list(x)) { vapply(x, width_cm, numeric(1)) } else { - stop("Unknown input") + abort("Unknown input") } } height_cm <- function(x) { @@ -32,6 +32,6 @@ height_cm <- function(x) { } else if (is.list(x)) { vapply(x, height_cm, numeric(1)) } else { - stop("Unknown input") + abort("Unknown input") } } diff --git a/R/utilities-matrix.r b/R/utilities-matrix.r index d0e9ed0d5d..694fc94f6f 100644 --- a/R/utilities-matrix.r +++ b/R/utilities-matrix.r @@ -24,7 +24,7 @@ interleave.default <- function(...) { # Check lengths lengths <- unique(setdiff(vapply(vectors, length, integer(1)), 1L)) if (length(lengths) == 0) lengths <- 1 - stopifnot(length(lengths) <= 1) + if (length(lengths) > 1) abort("`lengths` must be below 1") # Replicate elements of length one up to correct length singletons <- vapply(vectors, length, integer(1)) == 1L diff --git a/R/utilities.r b/R/utilities.r index 2c65e94a97..460d99636d 100644 --- a/R/utilities.r +++ b/R/utilities.r @@ -39,8 +39,10 @@ check_required_aesthetics <- function(required, present, name) { missing_aes <- lapply(required, setdiff, present) if (any(vapply(missing_aes, length, integer(1)) == 0)) return() - stop(name, " requires the following missing aesthetics: ", - paste(lapply(missing_aes, paste, collapse = ", "), collapse = " or "), call. = FALSE) + abort(glue( + "{name} requires the following missing aesthetics: ", + glue_collapse(lapply(missing_aes, glue_collapse, sep = ", ", last = " and "), sep = " or ") + )) } # Concatenate a named list for output @@ -64,8 +66,10 @@ try_require <- function(package, fun) { return(invisible()) } - stop("Package `", package, "` required for `", fun , "`.\n", - "Please install and try again.", call. = FALSE) + abort(glue(" + Package `{package}` required for `{fun}`. + Please install and try again. + ")) } # Return unique columns @@ -95,7 +99,9 @@ uniquecols <- function(df) { #' @export remove_missing <- function(df, na.rm = FALSE, vars = names(df), name = "", finite = FALSE) { - stopifnot(is.logical(na.rm)) + if (!is.logical(na.rm)) { + abort("`na.rm` must be logical") + } missing <- detect_missing(df, vars, finite) @@ -161,7 +167,9 @@ is_complete <- function(x) { #' should_stop(should_stop("Hi!")) should_stop <- function(expr) { res <- try(print(force(expr)), TRUE) - if (!inherits(res, "try-error")) stop("No error!", call. = FALSE) + if (!inherits(res, "try-error")) { + abort("No error!") + } invisible() } @@ -204,22 +212,21 @@ gg_dep <- function(version, msg) { .Deprecated() v <- as.package_version(version) cv <- utils::packageVersion("ggplot2") + text <- "{msg} (Defunct; last used in version {version})" # If current major number is greater than last-good major number, or if # current minor number is more than 1 greater than last-good minor number, # give error. if (cv[[1,1]] > v[[1,1]] || cv[[1,2]] > v[[1,2]] + 1) { - stop(msg, " (Defunct; last used in version ", version, ")", - call. = FALSE) + abort(glue(text)) # If minor number differs by one, give warning } else if (cv[[1,2]] > v[[1,2]]) { - warning(msg, " (Deprecated; last used in version ", version, ")", - call. = FALSE) + warn(glue(text)) # If only subminor number is greater, give message } else if (cv[[1,3]] > v[[1,3]]) { - message(msg, " (Deprecated; last used in version ", version, ")") + message(glue(text)) } invisible() @@ -241,11 +248,11 @@ to_lower_ascii <- function(x) chartr(upper_ascii, lower_ascii, x) to_upper_ascii <- function(x) chartr(lower_ascii, upper_ascii, x) tolower <- function(x) { - stop('Please use `to_lower_ascii()`, which works fine in all locales.', call. = FALSE) + abort("Please use `to_lower_ascii()`, which works fine in all locales.") } toupper <- function(x) { - stop('Please use `to_upper_ascii()`, which works fine in all locales.', call. = FALSE) + abort("Please use `to_upper_ascii()`, which works fine in all locales.") } # Convert a snake_case string to camelCase @@ -311,7 +318,7 @@ message_wrap <- function(...) { warning_wrap <- function(...) { msg <- paste(..., collapse = "", sep = "") wrapped <- strwrap(msg, width = getOption("width") - 2) - warning(paste0(wrapped, collapse = "\n"), call. = FALSE) + warn(glue_collapse(wrapped, "\n", last = "\n")) } var_list <- function(x) { @@ -395,7 +402,9 @@ is_column_vec <- function(x) { # #> expression(alpha, NA, gamma) # parse_safe <- function(text) { - stopifnot(is.character(text)) + if (!is.character(text)) { + abort("`text` must be a character vector") + } out <- vector("expression", length(text)) for (i in seq_along(text)) { expr <- parse(text = text[[i]]) diff --git a/tests/testthat/stops.rds b/tests/testthat/stops.rds new file mode 100644 index 0000000000..c1b02fad8d Binary files /dev/null and b/tests/testthat/stops.rds differ diff --git a/tests/testthat/test-conditions.R b/tests/testthat/test-conditions.R new file mode 100644 index 0000000000..ed3933a6d7 --- /dev/null +++ b/tests/testthat/test-conditions.R @@ -0,0 +1,21 @@ +context("rlang conditions") + +get_n_stop <- function(f) { + d <- getParseData(parse(f, keep.source = TRUE)) + sum(d$token == "SYMBOL_FUNCTION_CALL" & d$text == "stop") +} + +get_n_warning <- function(f) { + d <- getParseData(parse(f, keep.source = TRUE)) + sum(d$token == "SYMBOL_FUNCTION_CALL" & d$text == "warning") +} + +test_that("do not use stop()", { + stops <- vapply(list.files("../../R", full.names = TRUE), get_n_stop, integer(1)) + expect_equal(sum(stops), 0) +}) + +test_that("do not use warning()", { + warnings <- vapply(list.files("../../R", full.names = TRUE), get_n_warning, integer(1)) + expect_equal(sum(warnings), 0) +}) diff --git a/tests/testthat/test-stats.r b/tests/testthat/test-stats.r index 019d752fde..a4be7921df 100644 --- a/tests/testthat/test-stats.r +++ b/tests/testthat/test-stats.r @@ -14,5 +14,5 @@ test_that("plot succeeds even if some computation fails", { test_that("error message is thrown when aesthetics are missing", { p <- ggplot(mtcars) + stat_sum() - expect_error(ggplot_build(p), "x, y$") + expect_error(ggplot_build(p), "x and y$") })