From f69fc70a2905a67fe090030d24cce9dcbf60f3d2 Mon Sep 17 00:00:00 2001 From: Joseph Larmarange Date: Mon, 6 Jan 2025 13:54:52 +0100 Subject: [PATCH] Systematic use of cli (#167) * replace stop() by cli_abort() * warnings * NEWS update --- NEWS.md | 4 +++ R/copy_labels.R | 27 ++++++-------- R/is_prefixed.R | 8 +++-- R/lookfor.R | 5 +-- R/na_values.R | 44 +++++++++++------------ R/recode.R | 8 ++--- R/recode_if.R | 33 ++++++++--------- R/remove_labels.R | 10 +++--- R/tagged_na.R | 12 +++---- R/to_labelled.R | 4 +-- R/val_labels.R | 91 ++++++++++++++++++++--------------------------- R/var_label.R | 15 ++++---- labelled.Rproj | 2 ++ 13 files changed, 121 insertions(+), 142 deletions(-) diff --git a/NEWS.md b/NEWS.md index 1972915..ece5d2c 100644 --- a/NEWS.md +++ b/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** diff --git a/R/copy_labels.R b/R/copy_labels.R index df130bf..71f3fdf 100644 --- a/R/copy_labels.R +++ b/R/copy_labels.R @@ -47,18 +47,10 @@ 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 } @@ -66,12 +58,13 @@ copy_labels.default <- function(from, to, .strict = TRUE) { #' @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)) { diff --git a/R/is_prefixed.R b/R/is_prefixed.R index 485362f..11ae55b 100644 --- a/R/is_prefixed.R +++ b/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)) } diff --git a/R/lookfor.R b/R/lookfor.R index 2cf0a78..d440c6c 100644 --- a/R/lookfor.R +++ b/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)) } diff --git a/R/na_values.R b/R/na_values.R index 64e2efe..f404073 100644 --- a/R/na_values.R +++ b/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))) { diff --git a/R/recode.R b/R/recode.R index d1d6ffc..14c9cf2 100644 --- a/R/recode.R +++ b/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 diff --git a/R/recode_if.R b/R/recode_if.R index 4146f61..f1a27cf 100644 --- a/R/recode_if.R +++ b/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 } diff --git a/R/remove_labels.R b/R/remove_labels.R index e03d0ef..2b44195 100644 --- a/R/remove_labels.R +++ b/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() %>% diff --git a/R/tagged_na.R b/R/tagged_na.R index 7ca7ce6..7da8070 100644 --- a/R/tagged_na.R +++ b/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 diff --git a/R/to_labelled.R b/R/to_labelled.R index 19e500d..31486ed 100644 --- a/R/to_labelled.R +++ b/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) diff --git a/R/val_labels.R b/R/val_labels.R index 74233d5..8cb0166 100644 --- a/R/val_labels.R +++ b/R/val_labels.R @@ -78,14 +78,12 @@ val_labels.data.frame <- function(x, prefixed = FALSE) { } #' @export -`val_labels<-.factor` <- function( - x, - null_action = c("unclass", "labelled"), - value) { +`val_labels<-.factor` <- function(x, + null_action = c("unclass", "labelled"), + value) { null_action <- match.arg(null_action) - if (!is.null(value) || null_action == "labelled") { - stop("Value labels cannot be applied to factors.") - } + if (!is.null(value) || null_action == "labelled") + cli::cli_abort("Value labels cannot be applied to factors.") x %>% remove_attributes("labels") } @@ -185,12 +183,11 @@ val_labels.data.frame <- function(x, prefixed = FALSE) { 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]]) } @@ -213,18 +210,16 @@ val_label <- function(x, v, prefixed = FALSE) { #' @export val_label.default <- function(x, v, prefixed = FALSE) { - if (length(v) != 1) { - stop("`v` should be a single value", call. = FALSE, domain = "R-labelled") - } + if (length(v) != 1) + cli::cli_abort("{.arg v} (length: {length(v)}) should be a single value.") # return nothing NULL } #' @export val_label.haven_labelled <- function(x, v, prefixed = FALSE) { - if (length(v) != 1) { - stop("`v` should be a single value", call. = FALSE, domain = "R-labelled") - } + if (length(v) != 1) + cli::cli_abort("{.arg v} (length: {length(v)}) should be a single value.") labels <- val_labels(x, prefixed = prefixed) if (v %in% labels) { names(labels)[labels == v] @@ -251,13 +246,13 @@ val_label.data.frame <- function(x, v, prefixed = FALSE) { null_action = c("unclass", "labelled"), value) { if (length(v) != 1) { - stop("`v` should be a single value", call. = FALSE, domain = "R-labelled") + cli::cli_abort("{.arg v} (length: {length(v)}) should be a single value.") } - if (length(value) > 1) { - stop("`value` should be a single character string or NULL", - call. = FALSE, domain = "R-labelled" + check_character(value, allow_null = TRUE) + if (length(value) > 1) + cli::cli_abort( + "{.arg value} (length: {length(value)}) should be a single value." ) - } names(value) <- v val_labels(x, null_action = null_action) <- value x @@ -270,13 +265,13 @@ val_label.data.frame <- function(x, v, prefixed = FALSE) { null_action = c("unclass", "labelled"), value) { if (length(v) != 1) { - stop("`v` should be a single value", call. = FALSE, domain = "R-labelled") + cli::cli_abort("{.arg v} (length: {length(v)}) should be a single value.") } - if (length(value) > 1) { - stop("`value` should be a single character string or NULL", - call. = FALSE, domain = "R-labelled" + check_character(value, allow_null = TRUE) + if (length(value) > 1) + cli::cli_abort( + "{.arg value} (length: {length(value)}) should be a single value." ) - } labels <- val_labels(x) @@ -402,9 +397,8 @@ set_value_labels <- function( .strict = TRUE, .null_action = c("unclass", "labelled")) { .null_action <- match.arg(.null_action) - 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)) { @@ -447,16 +441,14 @@ add_value_labels <- function( .strict = TRUE, .null_action = c("unclass", "labelled")) { .null_action <- match.arg(.null_action) - 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)) { values <- unlist(rlang::dots_list(...)) - if (is.null(names(values)) || any(names(values) == "")) { - stop("all arguments should be named") - } + if (is.null(names(values)) || any(names(values) == "")) + cli::cli_abort("All arguments should be named.") for (v in names(values)) { val_label(.data, values[[v]], null_action = .null_action) <- v } @@ -473,9 +465,8 @@ add_value_labels <- function( } for (v in values) { - if (is.null(names(v)) || any(names(v) == "")) { - stop("all arguments should be named vectors") - } + if (is.null(names(v)) || any(names(v) == "")) + cli::cli_abort("All arguments should be named vectors.") } for (v in intersect(names(values), names(.data))) { @@ -495,9 +486,8 @@ remove_value_labels <- function( .strict = TRUE, .null_action = c("unclass", "labelled")) { .null_action <- match.arg(.null_action) - 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)) { @@ -557,19 +547,16 @@ sort_val_labels.default <- function( } #' @export -sort_val_labels.haven_labelled <- function( - x, - according_to = c("values", "labels"), - decreasing = FALSE) { +sort_val_labels.haven_labelled <- function(x, + according_to = c("values", "labels"), + decreasing = FALSE) { according_to <- match.arg(according_to) labels <- val_labels(x) if (!is.null(labels)) { - if (according_to == "values") { + if (according_to == "values") labels <- sort_tagged_na(labels, decreasing = decreasing) - } - if (according_to == "labels") { + if (according_to == "labels") labels <- labels[order(names(labels), decreasing = decreasing)] - } val_labels(x) <- labels } x diff --git a/R/var_label.R b/R/var_label.R index 126c524..bdc9939 100644 --- a/R/var_label.R +++ b/R/var_label.R @@ -152,15 +152,12 @@ var_label.data.frame <- function(x, if ( (!is.character(value) && !is.null(value)) && !is.list(value) || (is.character(value) && length(value) > 1 && length(value) != ncol(x)) - ) { - stop( - paste0( - "`value` should be a named list, NULL, a single character string or a ", - "character vector of same length than the number of columns in `x`" - ), - call. = FALSE, domain = "R-labelled" - ) - } + ) + cli::cli_abort(paste( + "{.arg value} should be a named list, NULL, a single character string", + "or a character vector of same length than the number of columns", + "in {.arg x}." + )) if (is.character(value) && length(value) == 1) { value <- as.list(rep(value, ncol(x))) names(value) <- names(x) diff --git a/labelled.Rproj b/labelled.Rproj index b65df80..e4e54c5 100644 --- a/labelled.Rproj +++ b/labelled.Rproj @@ -21,3 +21,5 @@ PackageUseDevtools: Yes PackageInstallArgs: --no-multiarch --with-keep.source PackageCheckArgs: --as-cran PackageRoxygenize: rd,collate,namespace,vignette + +SpellingDictionary: en_GB