move error/warning handling to rlang/cli

DESCRIPTION

@@ -23,8 +23,7 @@ Imports:
     R6,
     RColorBrewer,
     rlang (>= 1.0.0),
-    viridisLite,
-    withr
+    viridisLite
 Suggests: 
     bit64,
     covr,

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)
   }

R/breaks-retired.R

@@ -92,17 +92,15 @@ 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}")
     }
   }
 
   if (is.function(labels)) {
     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)

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) {

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)}}")
     }
   }
 }

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) {

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)

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)}}")
     }
   }
 }

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(

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")
     }
   }
 

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
   }
 

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)

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]]

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) {

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)])
   }

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) {

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))

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)
 }

R/trans-compose.R

@@ -13,15 +13,15 @@
 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
   suppressWarnings(
     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)
 

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]]