diff --git a/DESCRIPTION b/DESCRIPTION index 9f6a7d37..feb6453e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -23,8 +23,7 @@ Imports: R6, RColorBrewer, rlang (>= 1.0.0), - viridisLite, - withr + viridisLite Suggests: bit64, covr, diff --git a/R/bounds.r b/R/bounds.r index e10f799f..b66059db 100644 --- a/R/bounds.r +++ b/R/bounds.r @@ -351,7 +351,7 @@ zero_range <- function(x, tol = 1000 * .Machine$double.eps) { if (length(x) == 1) { return(TRUE) } - if (length(x) != 2) stop("x must be length 1 or 2") + if (length(x) != 2) cli::cli_abort("{.arg x} must be length 1 or 2") if (any(is.na(x))) { return(NA) } diff --git a/R/breaks-retired.R b/R/breaks-retired.R index bd6bea03..31b864fe 100644 --- a/R/breaks-retired.R +++ b/R/breaks-retired.R @@ -92,9 +92,7 @@ cbreaks <- function(range, breaks = extended_breaks(), labels = scientific_forma breaks <- breaks(range) if (!is.function(labels)) { - stop("Labels can only be manually specified in conjunction with breaks", - call. = FALSE - ) + cli::cli_abort("{.arg labels} can only be manually specified in conjunction with {.arg breaks}") } } @@ -102,7 +100,7 @@ cbreaks <- function(range, breaks = extended_breaks(), labels = scientific_forma labels <- labels(breaks) } else { if (length(labels) != length(breaks)) { - stop("Labels and breaks must be same length") + cli::cli_abort("{.arg labels} and {.arg breaks} must be same length") } if (is.expression(labels)) { labels <- as.list(labels) diff --git a/R/colour-manip.r b/R/colour-manip.r index 7cb569c3..3ea479e9 100644 --- a/R/colour-manip.r +++ b/R/colour-manip.r @@ -53,7 +53,7 @@ muted <- function(colour, l = 30, c = 70) col2hcl(colour, l = l, c = c) alpha <- function(colour, alpha = NA) { if (length(colour) != length(alpha)) { if (length(colour) > 1 && length(alpha) > 1) { - stop("Only one of colour and alpha can be vectorised") + cli::cli_abort("Only one of {.arg colour} and {.arg alpha} can be vectorised") } if (length(colour) > 1) { diff --git a/R/colour-mapping.r b/R/colour-mapping.r index ac6c6bad..76b82066 100644 --- a/R/colour-mapping.r +++ b/R/colour-mapping.r @@ -38,7 +38,7 @@ col_numeric <- function(palette, domain, na.color = "#808080", alpha = FALSE, re if (length(domain) > 0) { rng <- range(domain, na.rm = TRUE) if (!all(is.finite(rng))) { - stop("Wasn't able to determine range of domain") + cli::cli_abort("Wasn't able to determine range of {.arg domain}") } } @@ -53,7 +53,7 @@ col_numeric <- function(palette, domain, na.color = "#808080", alpha = FALSE, re rescaled <- rescale(x, from = rng) if (any(rescaled < 0 | rescaled > 1, na.rm = TRUE)) { - warning("Some values were outside the color scale and will be treated as NA", call. = FALSE) + cli::cli_warn("Some values were outside the color scale and will be treated as NA") } if (reverse) { @@ -74,7 +74,7 @@ withColorAttr <- function(type, args = list(), fun) { # bins is non-NULL. It may be a scalar value (# of breaks) or a set of breaks. getBins <- function(domain, x, bins, pretty) { if (is.null(domain) && is.null(x)) { - stop("Assertion failed: domain and x can't both be NULL") + cli::cli_abort("{.arg domain} and {.arg x} can't both be NULL") } # Hard-coded bins @@ -83,7 +83,10 @@ getBins <- function(domain, x, bins, pretty) { } if (bins < 2) { - stop("Invalid bins value of ", bins, "; bin count must be at least 2") + cli::cli_abort(c( + "Invalid {.arg bins} value ({bins})", + i = "bin count must be at least 2" + )) } if (pretty) { base::pretty(domain %||% x, n = bins) @@ -134,7 +137,7 @@ col_bin <- function(palette, domain, bins = 7, pretty = TRUE, binsToUse <- getBins(domain, x, bins, pretty) ints <- cut(x, binsToUse, labels = FALSE, include.lowest = TRUE, right = right) if (any(is.na(x) != is.na(ints))) { - warning("Some values were outside the color scale and will be treated as NA", call. = FALSE) + cli::cli_warn("Some values were outside the color scale and will be treated as NA") } colorFunc(ints) }) @@ -174,7 +177,7 @@ col_quantile <- function(palette, domain, n = 4, binsToUse <- safe_quantile(x, probs) ints <- cut(x, binsToUse, labels = FALSE, include.lowest = TRUE, right = right) if (any(is.na(x) != is.na(ints))) { - warning("Some values were outside the color scale and will be treated as NA", call. = FALSE) + cli::cli_warn("Some values were outside the color scale and will be treated as NA") } colorFunc(ints) }) @@ -184,11 +187,7 @@ safe_quantile <- function(x, probs) { bins <- stats::quantile(x, probs, na.rm = TRUE, names = FALSE) if (anyDuplicated(bins)) { bins <- unique(bins) - warning( - "Skewed data means we can only allocate ", length(bins), " unique colours ", - "not the " , length(probs) - 1, " requested", - call. = FALSE - ) + cli::cli_warn("Skewed data means we can only allocate {length(bins)} unique colours not the {length(probs) - 1} requested") } bins } @@ -240,7 +239,7 @@ col_factor <- function(palette, domain, levels = NULL, ordered = FALSE, } if (!is.null(levels) && anyDuplicated(levels)) { - warning("Duplicate levels detected", call. = FALSE) + cli::cli_warn("Duplicate levels detected") levels <- unique(levels) } lvls <- getLevels(domain, NULL, levels, ordered) @@ -257,12 +256,12 @@ col_factor <- function(palette, domain, levels = NULL, ordered = FALSE, origNa <- is.na(x) x <- match(as.character(x), lvls) if (any(is.na(x) != origNa)) { - warning("Some values were outside the color scale and will be treated as NA", call. = FALSE) + cli::cli_warn("Some values were outside the color scale and will be treated as NA") } scaled <- rescale(as.integer(x), from = c(1, length(lvls))) if (any(scaled < 0 | scaled > 1, na.rm = TRUE)) { - warning("Some values were outside the color scale and will be treated as NA", call. = FALSE) + cli::cli_warn("Some values were outside the color scale and will be treated as NA") } if (reverse) { scaled <- 1 - scaled @@ -383,7 +382,7 @@ filterRGB <- function(f) { } else if (is.matrix(results)) { farver::encode_colour(results, from = "rgb") } else { - stop("Unexpected result type ", class(x)[[1]]) + cli::cli_abort("Unexpected result type {.cls {class(x)}}") } } } diff --git a/R/colour-ramp.R b/R/colour-ramp.R index fa10a985..aa8decf8 100644 --- a/R/colour-ramp.R +++ b/R/colour-ramp.R @@ -34,7 +34,7 @@ #' show_col(ramp(seq(0, 1, length = 12))) colour_ramp <- function(colors, na.color = NA, alpha = TRUE) { if (length(colors) == 0) { - stop("Must provide at least one colour to create a colour ramp") + cli::cli_abort("Must provide at least one colour to create a colour ramp") } if (length(colors) == 1) { diff --git a/R/label-bytes.R b/R/label-bytes.R index 7dd1818a..261b365c 100644 --- a/R/label-bytes.R +++ b/R/label-bytes.R @@ -37,7 +37,9 @@ #' labels = label_bytes("auto_binary") #' ) label_bytes <- function(units = "auto_si", accuracy = 1, scale = 1, ...) { - stopifnot(is.character(units), length(units) == 1) + if (!(is.character(units) && length(units) == 1)) { + cli::cli_abort("{.arg units} must be a scalar string") + } force_all(accuracy, ...) function(x) { @@ -56,7 +58,7 @@ label_bytes <- function(units = "auto_si", accuracy = 1, scale = 1, ...) { base <- 1024 power <- powers[[match(units, bin_units)]] } else { - stop("'", units, "' is not a valid unit", call. = FALSE) + cli::cli_abort("{.val {units}} is not a valid unit") } suffix <- paste0(" ", units) diff --git a/R/label-date.R b/R/label-date.R index e7db2cc6..af89dc20 100644 --- a/R/label-date.R +++ b/R/label-date.R @@ -109,11 +109,7 @@ label_time <- function(format = "%H:%M:%S", tz = "UTC", locale = NULL) { } else if (inherits(x, "difftime")) { format(as.POSIXct(x), format = format, tz = tz) } else { - stop( - "time_format can't be used with objects of class ", paste(class(x), collapse = "/"), - ".", - call. = FALSE - ) + cli::cli_abort("{.fun label_time} can't be used with an object of class {.cls {class(x)}}") } } } diff --git a/R/label-number.r b/R/label-number.r index 0d347a14..0e8e1a2e 100644 --- a/R/label-number.r +++ b/R/label-number.r @@ -321,14 +321,14 @@ precision <- function(x) { scale_cut <- function(x, breaks, scale = 1, accuracy = NULL, suffix = "") { if (!is.numeric(breaks) || is.null(names(breaks))) { - abort("`scale_cut` must be a named numeric vector") + cli::cli_abort("{.arg scale_cut} must be a named numeric vector") } breaks <- sort(breaks, na.last = TRUE) if (any(is.na(breaks))) { - abort("`scale_cut` values must not be missing") + cli::cli_abort("{.arg scale_cut} values must not be missing") } if (!identical(breaks[[1]], 0) && !identical(breaks[[1]], 0L)) { - abort("Smallest value of `scales_cut` must be zero") + cli::cli_abort("Smallest value of {.arg scales_cut} must be zero") } break_suffix <- as.character(cut( diff --git a/R/label-pvalue.R b/R/label-pvalue.R index 8de008b7..2564daf0 100644 --- a/R/label-pvalue.R +++ b/R/label-pvalue.R @@ -64,7 +64,7 @@ pvalue <- function(x, } } else { if (!is.character(prefix) || length(prefix) != 3) { - stop("`prefix` must be a length 3 character vector", call. = FALSE) + cli::cli_abort("{.arg prefix} must be a length 3 character vector") } } diff --git a/R/labels-retired.R b/R/labels-retired.R index 41d37036..be1e2fe6 100644 --- a/R/labels-retired.R +++ b/R/labels-retired.R @@ -51,18 +51,15 @@ number_bytes <- function(x, symbol = "auto", units = c("binary", "si"), accuracy validate_byte_symbol <- function(symbol, symbols, default = "auto") { if (length(symbol) != 1) { - n <- length(symbol) - stop("`symbol` must have length 1, not length ", n, ".", call. = FALSE) + cli::cli_abort("{.arg symbol} must have length 1, not length {length(symbol)}") } valid_symbols <- c(default, symbols) if (!(symbol %in% valid_symbols)) { - warning( - "`symbol` must be one of: '", paste0(valid_symbols, collapse = "', '"), - "'; not '", symbol, "'.\n", - "Defaulting to '", default, "'.", - call. = FALSE - ) + cli::cli_warn(c( + "{.arg symbol} must be one of {.or {.or {valid_symbols}}}", + i = "The provided value ({.val {symbol}}) will be changed to the default ({.val {default}})" + )) symbol <- default } diff --git a/R/pal-brewer.r b/R/pal-brewer.r index d62a5e21..72c5b358 100644 --- a/R/pal-brewer.r +++ b/R/pal-brewer.r @@ -45,7 +45,7 @@ brewer_pal <- function(type = "seq", palette = 1, direction = 1) { pal_name <- function(palette, type) { if (is.character(palette)) { if (!palette %in% unlist(brewer)) { - warning("Unknown palette ", palette) + cli::cli_warn("Unknown palette: {.val {palette}}") palette <- "Greens" } return(palette) diff --git a/R/pal-dichromat.r b/R/pal-dichromat.r index e28c8591..65ebe98b 100644 --- a/R/pal-dichromat.r +++ b/R/pal-dichromat.r @@ -13,17 +13,10 @@ #' show_col(gradient_n_pal(cols)(seq(0, 1, length.out = 30))) #' } dichromat_pal <- function(name) { - if (!requireNamespace("dichromat", quietly = TRUE)) { - stop("Package dichromat must be installed for this function to work. Please install it.", - call. = FALSE - ) - } + check_installed("dichromat") if (!any(name == names(dichromat::colorschemes))) { - stop("Palette name must be one of ", - paste0(names(dichromat::colorschemes), collapse = ", "), - call. = FALSE - ) + cli::cli_abort("Palette name must be one of {.or {.val {names(dichromat::colorschemes)}}}") } pal <- dichromat::colorschemes[[name]] diff --git a/R/pal-hue.r b/R/pal-hue.r index 84265faf..5dcdb5aa 100644 --- a/R/pal-hue.r +++ b/R/pal-hue.r @@ -25,13 +25,13 @@ #' show_col(hue_pal(h = c(180, 270))(9)) #' show_col(hue_pal(h = c(270, 360))(9)) hue_pal <- function(h = c(0, 360) + 15, c = 100, l = 65, h.start = 0, direction = 1) { - stopifnot(length(h) == 2) - stopifnot(length(c) == 1) - stopifnot(length(l) == 1) + if (length(h) != 2) cli::cli_abort("{.arg h} must have length 2") + if (length(l) != 1) cli::cli_abort("{.arg l} must have length 1") + if (length(c) != 1) cli::cli_abort("{.arg c} must have length 1") force_all(h, c, l, h.start, direction) function(n) { if (n == 0) { - stop("Must request at least one colour from a hue palette.", call. = FALSE) + cli::cli_abort("Must request at least one colour from a hue palette.") } if ((diff(h) %% 360) < 1) { diff --git a/R/pal-manual.r b/R/pal-manual.r index 7a0a9aee..8a4bef85 100644 --- a/R/pal-manual.r +++ b/R/pal-manual.r @@ -7,10 +7,7 @@ manual_pal <- function(values) { function(n) { n_values <- length(values) if (n > n_values) { - warning("This manual palette can handle a maximum of ", n_values, - " values. You have supplied ", n, ".", - call. = FALSE - ) + cli::cli_warn("This manual palette can handle a maximum of {n_values} values. You have supplied {n}") } unname(values[seq_len(n)]) } diff --git a/R/pal-shape.r b/R/pal-shape.r index 4215a6b0..b0d9d76f 100644 --- a/R/pal-shape.r +++ b/R/pal-shape.r @@ -6,13 +6,10 @@ shape_pal <- function(solid = TRUE) { force(solid) function(n) { if (n > 6) { - msg <- paste("The shape palette can deal with a maximum of 6 discrete ", - "values because more than 6 becomes difficult to discriminate; ", - "you have ", n, ". Consider specifying shapes manually if you ", - "must have them.", - sep = "" - ) - warning(paste(strwrap(msg), collapse = "\n"), call. = FALSE) + cli::cli_warn(c( + "The shape palette can deal with a maximum of 6 discrete values because more than 6 becomes difficult to discriminate", + i = "you have requested {n} values. Consider specifying shapes manually if you need that many have them." + )) } if (solid) { diff --git a/R/scale-continuous.r b/R/scale-continuous.r index 5ba6eb1a..8ad1cfb1 100644 --- a/R/scale-continuous.r +++ b/R/scale-continuous.r @@ -24,7 +24,7 @@ #' col = cscale(hp, seq_gradient_pal("grey80", "black")) #' )) cscale <- function(x, palette, na.value = NA_real_, trans = identity_trans()) { - stopifnot(is.trans(trans)) + if (!is.trans(trans)) cli::cli_abort("{.arg trans} must be a {.cls trans} object") x <- trans$transform(x) limits <- train_continuous(x) @@ -43,7 +43,7 @@ train_continuous <- function(new, existing = NULL) { } if (is.factor(new) || !typeof(new) %in% c("integer", "double")) { - stop("Discrete value supplied to continuous scale", call. = FALSE) + cli::cli_abort("Discrete value supplied to a continuous scale") } suppressWarnings(range(existing, new, na.rm = TRUE, finite = TRUE)) diff --git a/R/scale-discrete.r b/R/scale-discrete.r index 147c537a..9c949e7b 100644 --- a/R/scale-discrete.r +++ b/R/scale-discrete.r @@ -31,7 +31,7 @@ train_discrete <- function(new, existing = NULL, drop = FALSE, na.rm = FALSE) { } if (!is.discrete(new)) { - stop("Continuous value supplied to discrete scale", call. = FALSE) + cli::cli_abort("Continuous value supplied to a discrete scale") } discrete_range(existing, new, drop = drop, na.rm = na.rm) } diff --git a/R/trans-compose.R b/R/trans-compose.R index c2596da5..26b85da2 100644 --- a/R/trans-compose.R +++ b/R/trans-compose.R @@ -13,7 +13,7 @@ compose_trans <- function(...) { trans_list <- lapply(list2(...), as.trans) if (length(trans_list) == 0) { - abort("Must include at least 1 transformer to compose") + cli::cli_abort("{.fun compose_trans} must include at least 1 transformer to compose") } # Resolve domains @@ -21,7 +21,7 @@ compose_trans <- function(...) { domain <- compose_fwd(trans_list[[1]]$domain, trans_list[-1]) ) if (any(is.na(domain))) { - abort("Sequence of transformations yields invalid domain") + cli::cli_abort("Sequence of transformations yields invalid domain") } domain <- range(domain) diff --git a/R/trans-date.r b/R/trans-date.r index 904bdefd..51424b36 100644 --- a/R/trans-date.r +++ b/R/trans-date.r @@ -19,9 +19,7 @@ date_trans <- function() { to_date <- function(x) structure(x, class = "Date") from_date <- function(x) { if (!inherits(x, "Date")) { - stop("Invalid input: date_trans works with objects of class Date only", - call. = FALSE - ) + cli::cli_abort("{.fun date_trans} works with objects of class {.cls Date} only") } structure(as.numeric(x), names = names(x)) } @@ -45,10 +43,7 @@ time_trans <- function(tz = NULL) { from_time <- function(x) { if (!inherits(x, "POSIXct")) { - stop("Invalid input: time_trans works with objects of class ", - "POSIXct only", - call. = FALSE - ) + cli::cli_abort("{.fun time_trans} works with objects of class {.cls POSIXct} only") } if (is.null(tz)) { tz <<- attr(as.POSIXlt(x), "tzone")[[1]] diff --git a/R/trans-numeric.r b/R/trans-numeric.r index a05e4397..7279acf4 100644 --- a/R/trans-numeric.r +++ b/R/trans-numeric.r @@ -68,9 +68,10 @@ atanh_trans <- function() { boxcox_trans <- function(p, offset = 0) { trans <- function(x) { if (any((x + offset) < 0, na.rm = TRUE)) { - stop("boxcox_trans must be given only positive values. Consider using modulus_trans instead?", - call. = F - ) + cli::cli_abort(c( + "{.fun boxcox_trans} must be given only positive values", + i = "Consider using {.fun modulus_trans} instead?" + )) } if (abs(p) < 1e-07) { log(x + offset) diff --git a/R/trans.r b/R/trans.r index 93849a3b..65047db0 100644 --- a/R/trans.r +++ b/R/trans.r @@ -93,7 +93,7 @@ as.trans <- function(x, arg = deparse(substitute(x))) { compose_trans(!!!x) } } else { - abort(sprintf("`%s` must be a character vector or a transformer object", arg)) + cli::cli_abort(sprintf("{.arg %s} must be a character vector or a transformer object", arg)) } } diff --git a/R/utils.r b/R/utils.r index 82b65ee9..e1928597 100644 --- a/R/utils.r +++ b/R/utils.r @@ -7,7 +7,7 @@ demo_ggplot <- function(x, scale_name, ...) { cat(paste0(deparse(call), "\n", collapse = "")) if (!requireNamespace("ggplot2", quietly = TRUE)) { - message("Skipping; ggplot2 not installed") + cli::cli_inform("Skipping; {.pkg ggplot2} not installed") return(invisible()) } diff --git a/tests/testthat/_snaps/trans-compose.md b/tests/testthat/_snaps/trans-compose.md index 4d362c7b..1023d08b 100644 --- a/tests/testthat/_snaps/trans-compose.md +++ b/tests/testthat/_snaps/trans-compose.md @@ -4,7 +4,7 @@ compose_trans() Condition Error in `compose_trans()`: - ! Must include at least 1 transformer to compose + ! `compose_trans()` must include at least 1 transformer to compose Code compose_trans("reverse", "log10") Condition diff --git a/tests/testthat/_snaps/trans-date.md b/tests/testthat/_snaps/trans-date.md new file mode 100644 index 00000000..ff41bec3 --- /dev/null +++ b/tests/testthat/_snaps/trans-date.md @@ -0,0 +1,8 @@ +# date/time scales raise error on incorrect inputs + + `time_trans()` works with objects of class only + +--- + + `date_trans()` works with objects of class only + diff --git a/tests/testthat/test-trans-date.r b/tests/testthat/test-trans-date.r index 52957836..38092367 100644 --- a/tests/testthat/test-trans-date.r +++ b/tests/testthat/test-trans-date.r @@ -10,10 +10,10 @@ with_tz <- function(x, value) { test_that("date/time scales raise error on incorrect inputs", { time <- time_trans() - expect_error(time$transform(a_date), "Invalid input") + expect_snapshot_error(time$transform(a_date)) date <- date_trans() - expect_error(date$transform(a_time), "Invalid input") + expect_snapshot_error(date$transform(a_time)) }) test_that("time scales learn timezones", {