Systematic use of cli (#167)

* replace stop() by cli_abort()

* warnings

* NEWS update

NEWS.md

@@ -6,6 +6,10 @@
   name inside `.fn` by using `names()` (#163)
 * `var_label()` gets new options `"na"` and `"empty"` for `null_action`
 
+**Improvements**
+
+* systematic use of `{cli}` for errors, warnings and messages (#167)
+
 # labelled 2.13.0
 
 **New features**

R/copy_labels.R

@@ -47,31 +47,24 @@ copy_labels <- function(from, to, .strict = TRUE) {
 
 #' @export
 copy_labels.default <- function(from, to, .strict = TRUE) {
-  if (!is.atomic(from)) {
-    stop("`from` should be a vector or a data.frame",
-      call. = FALSE,
-      domain = "R-labelled"
-    )
-  }
-  if (!is.atomic(to)) {
-    stop("`to` should be a vector",
-      call. = FALSE,
-      domain = "R-labelled"
-    )
-  }
+  if (!is.atomic(from))
+    cli::cli_abort("{.arg from} must be a vector or a data frame.")
+  if (!is.atomic(to))
+    cli::cli_abort("{.arg to} must be a vector.")
   var_label(to) <- var_label(from)
   to
 }
 
 
 #' @export
 copy_labels.haven_labelled <- function(from, to, .strict = TRUE) {
-  if (mode(from) != mode(to) && .strict) {
-    stop("`from` and `to` should be of same type",
-      call. = FALSE,
-      domain = "R-labelled"
+  if (mode(from) != mode(to) && .strict)
+    cli::cli_abort(
+      paste(
+        "{.arg from} ({class(from)}) and {.arg to} ({class(to)})",
+        "must be of same type."
+      )
     )
-  }
   var_label(to) <- var_label(from)
 
   if (mode(from) == mode(to)) {

R/is_prefixed.R

@@ -2,9 +2,11 @@
 #' @param x a factor
 #' @export
 is_prefixed <- function(x) {
-  if (!is.factor(x)) {
-    stop("is_prefixed should be used only with a factor.")
-  }
+  if (!is.factor(x))
+    cli::cli_abort(paste(
+      "{.fn is_prefixed} should be used only with a factor",
+      "({.arg x} is {class(x)})."
+    ))
   l <- .get_prefixes.factor(x)
   all(!is.na(l$code)) && all(!is.na(l$code)) && !any(duplicated(l$code))
 }

R/lookfor.R

@@ -132,7 +132,8 @@ look_for <- function(data,
   data <- to_labelled(data)
   # search scope
   n <- names(data)
-  if (!length(n)) stop("there are no names to search in that object")
+  if (!length(n))
+    cli::cli_abort("There are no names to search in that object.")
   # search function
   keywords <- c(...)
   l <- unlist(var_label(data))
@@ -364,7 +365,7 @@ print.look_for <- function(x, ...) {
 
     print.data.frame(x, row.names = FALSE, quote = FALSE, right = FALSE)
   } else if (nrow(x) == 0) {
-    message("Nothing found. Sorry.")
+    cli::cli_alert_warning("Nothing found. Sorry.")
   } else {
     print(dplyr::as_tibble(x))
   }

R/na_values.R

@@ -111,9 +111,8 @@ na_values.data.frame <- function(x) {
 
 #' @export
 `na_values<-.factor` <- function(x, value) {
-  if (!is.null(value)) {
-    stop("`na_values()` cannot be applied to factors.")
-  }
+  if (!is.null(value))
+    cli::cli_abort("{.fn na_values}` cannot be applied to factors.")
   x %>% remove_attributes("na_values")
 }
 
@@ -155,12 +154,11 @@ na_values.data.frame <- function(x) {
 
   for (var in names(value)) {
     if (!is.null(value[[var]])) {
-      if (mode(x[[var]]) != mode(value[[var]])) {
-        stop("`x` and `value` must be same type",
-          call. = FALSE,
-          domain = "R-labelled"
-        )
-      }
+      if (mode(x[[var]]) != mode(value[[var]]))
+        cli::cli_abort(paste(
+          "{.arg x} ({class(x)}) and {.arg value} ({class(value)})",
+          "must be same type."
+        ))
       if (typeof(x[[var]]) != typeof(value[[var]])) {
         mode(value[[var]]) <- typeof(x[[var]])
       }
@@ -219,7 +217,7 @@ na_range.data.frame <- function(x) {
 #' @export
 `na_range<-.factor` <- function(x, value) {
   if (!is.null(value)) {
-    stop("`na_range()` cannot be applied to factors.")
+    cli::cli_abort("{.fn na_range} cannot be applied to factors.")
   }
   x %>% remove_attributes("na_range")
 }
@@ -263,12 +261,11 @@ na_range.data.frame <- function(x) {
 
   for (var in names(value)) {
     if (!is.null(value[[var]])) {
-      if (mode(x[[var]]) != mode(value[[var]])) {
-        stop("`x` and `value` must be same type",
-          call. = FALSE,
-          domain = "R-labelled"
-        )
-      }
+      if (mode(x[[var]]) != mode(value[[var]]))
+        cli::cli_abort(paste(
+          "{.arg x} ({class(x)}) and {.arg value} ({class(value)})",
+          "must be same type."
+        ))
       if (typeof(x[[var]]) != typeof(value[[var]])) {
         mode(value[[var]]) <- typeof(x[[var]])
       }
@@ -327,9 +324,8 @@ get_na_range <- na_range
 #' }
 #' @export
 set_na_values <- function(.data, ..., .values = NA, .strict = TRUE) {
-  if (!is.data.frame(.data) && !is.atomic(.data)) {
-    stop(".data should be a data.frame or a vector")
-  }
+  if (!is.data.frame(.data) && !is.atomic(.data))
+    cli::cli_abort("{.arg .data} should be a data frame or a vector.")
 
   # vector case
   if (is.atomic(.data)) {
@@ -366,9 +362,8 @@ set_na_values <- function(.data, ..., .values = NA, .strict = TRUE) {
 #' @rdname na_values
 #' @export
 set_na_range <- function(.data, ..., .values = NA, .strict = TRUE) {
-  if (!is.data.frame(.data) && !is.atomic(.data)) {
-    stop(".data should be a data.frame or a vector")
-  }
+  if (!is.data.frame(.data) && !is.atomic(.data))
+    cli::cli_abort("{.arg .data} should be a data frame or a vector.")
 
   # vector case
   if (is.atomic(.data)) {
@@ -389,7 +384,10 @@ set_na_range <- function(.data, ..., .values = NA, .strict = TRUE) {
   }
   values <- rlang::dots_list(...)
   if (.strict && !all(names(values) %in% names(.data))) {
-    stop("some variables not found in .data")
+    missing_names <- setdiff(names(value), names(.data))
+    cli::cli_abort(c(
+      "Can't find variables {.var {missing_names}} in {.arg .data}."
+    ))
   }
 
   for (v in intersect(names(values), names(.data))) {

R/recode.R

@@ -117,10 +117,10 @@ recode.haven_labelled <- function(
   } else {
     var_label(ret) <- var_label(.x)
     if (.keep_value_labels || .combine_value_labels) {
-      warning(
-        "The type of .x has been changed and value labels attributes",
-        "have been lost."
-      )
+      cli::cli_warn(paste(
+        "The type of {.arg .x} ({mode(ret)}) has been changed",
+        "and value labels have been lost."
+      ))
     }
   }
   ret

R/recode_if.R

@@ -28,15 +28,16 @@
 #'   df %>% look_for()
 #' }
 recode_if <- function(x, condition, true) {
-  if (!is.logical(condition)) {
-    stop("'condition' should be logical.")
-  }
-  if (length(x) != length(condition)) {
-    stop("'condition' and 'x' should have the same length.")
-  }
-  if (length(true) > 1 && length(true) != length(x)) {
-    stop("'true' should be unique or of same length as 'x'.")
-  }
+  check_logical(condition)
+  if (length(x) != length(condition))
+    cli::cli_abort(paste(
+      "{.arg condition} (length: {length(condition)}) and",
+      "{.arg x} (length: {length(x)}) should have the same length."
+    ))
+  if (length(true) > 1 && length(true) != length(x))
+    cli::cli_abort(
+      "{.arg true} should be unique or of same length as {.arg x}."
+    )
 
   original_class <- class(x)
 
@@ -48,15 +49,11 @@ recode_if <- function(x, condition, true) {
     x[condition] <- true[condition]
   }
 
-  if (!identical(class(x), original_class)) {
-    warning(
-      "Class of 'x' has changed and is now equal to \"",
-      paste(class(x), collapse = ", "),
-      "\".\n",
-      "This is usually the case when class of 'value' is different from `x`\n.",
-      "and forced R to coerce 'x' to the class of 'value'."
-    )
-  }
+  if (!identical(class(x), original_class))
+    cli::cli_warn(paste(
+      "Class of {.arg x} (originally {.field {original_class}}) has changed",
+      "and was coerced to {.field {class(x)}}."
+    ))
 
   x
 }

R/remove_labels.R

@@ -139,11 +139,11 @@ remove_user_na.haven_labelled_spss <- function(x,
                                                user_na_to_na = FALSE,
                                                user_na_to_tagged_na = FALSE) {
   if (user_na_to_tagged_na) {
-    if (typeof(x) == "character") {
-      stop(
-        "'user_na_to_tagged_na' cannot be used with character labelled vectors."
-      )
-    }
+    if (typeof(x) == "character")
+      cli::cli_abort(paste(
+        "{.fn user_na_to_tagged_na} cannot be used with",
+        "character labelled vectors."
+      ))
 
     val_to_tag <- x[is.na(x) & !is.na(unclass(x))] %>%
       unclass() %>%

R/tagged_na.R

@@ -186,13 +186,11 @@ tagged_na_to_user_na.double <- function(x, user_na_start = NULL) {
   labels <- val_labels(x)
   for (i in seq_along(tn)) {
     new_val <- user_na_start + i - 1
-    if (any(x == new_val, na.rm = TRUE)) {
-      stop(
-        "Value ",
-        new_val,
-        " is already used in 'x'. Please change 'user_na_start'."
-      )
-    }
+    if (any(x == new_val, na.rm = TRUE))
+      cli::cli_abort(paste(
+        "Value {new_val} is already used in {.arg x}.",
+        "Please change {.arg user_na_start}."
+      ))
     x[is_tagged_na(x, na_tag(tn[i]))] <- new_val
     if (any(is_tagged_na(labels, na_tag(tn[i])), na.rm = TRUE)) {
       labels[is_tagged_na(labels, na_tag(tn[i]))] <- new_val

R/to_labelled.R

@@ -249,7 +249,7 @@ to_labelled.factor <- function(x, labels = NULL, .quiet = FALSE, ...) {
           all(!is.na(l$code)) &&
           all(!is.na(l$code))
       ) {
-        warning("'x' looks prefixed, but duplicated codes found.")
+        cli::cli_warn("{.arg x} looks prefixed, but duplicated codes found.")
       }
       # normal case
       labs <- seq_along(levels(x))
@@ -259,7 +259,7 @@ to_labelled.factor <- function(x, labels = NULL, .quiet = FALSE, ...) {
       # "[code] label" case
       num_l <- suppressWarnings(as.numeric(l$code))
       if (!.quiet && all(!is.na(num_l)) && any(duplicated(num_l))) {
-        warning("All codes seem numeric but some duplicates found.")
+        cli::cli_warn("All codes seem numeric but some duplicates found.")
       }
       if (all(!is.na(num_l)) && !any(duplicated(num_l))) {
         l$code <- as.numeric(l$code)