rework error messages (#14)

* add type checkers * move to cli + calls for inline functions * data to helper file * route more calls * route more calls * move tests around * rework overall desirability checks and messages * missed two input checks * Apply suggestions from code review Co-authored-by: Emil Hvitfeldt <[email protected]> * updated snapshots for 29c7d07 * Emil's suggestion with small fix * function name change * use defaults for call in helper functions --------- Co-authored-by: Emil Hvitfeldt <[email protected]>
tidymodels · Oct 19, 2024 · c57e0ad · c57e0ad
1 parent e0fbfad
commit c57e0ad
Show file tree

Hide file tree

Showing 16 changed files with 1,354 additions and 233 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -15,10 +15,10 @@ URL: https://desirability2.tidymodels.org,
 Depends: 
     R (>= 2.10)
 Imports: 
+    cli,
     dplyr,
-    glue,
     purrr,
-    rlang,
+    rlang (>= 1.1.0),
     stats,
     tibble
 Suggests: 
@@ -32,4 +32,4 @@ Encoding: UTF-8
 Language: en-US
 LazyData: true
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.2.3
+RoxygenNote: 7.3.2
diff --git a/NAMESPACE b/NAMESPACE
@@ -7,3 +7,4 @@ export(d_max)
 export(d_min)
 export(d_overall)
 export(d_target)
+import(rlang)
diff --git a/R/checks.R b/R/checks.R
@@ -1,101 +1,114 @@
-check_numeric <- function(x, input = "`x`") {
+check_numeric <- function(x, input = "`x`", call = rlang::caller_env()) {
   if (!is.vector(x) || !is.numeric(x)) {
-    rlang::abort(paste0(input, " should be a numeric vector."))
+    cli::cli_abort("{.arg {input}} should be {an} numeric vector.")
   }
   invisible(NULL)
 }
 
-check_categorical <- function(x) {
+check_categorical <- function(x, call = rlang::caller_env()) {
   if (!is.character(x) & !is.factor(x)) {
-    rlang::abort("`x` should be a character or factor vector.")
+    cli::cli_abort(
+      "{.arg x} should be a character or factor vector,
+      not {.obj_type_friendly {x}}.",
+      call = call
+     )
   }
   invisible(NULL)
 }
 
-check_unit_range <- function(x) {
-  msg <- "Desirability values should be numeric and complete in the range [0, 1]."
-  if (!is.vector(x) || !is.numeric(x)) {
-    rlang::abort(msg)
-  }
+out_of_unit_range <- function(x) {
   x <- x[!is.na(x)]
-  if (length(x) > 0 && any(x < 0 | x > 1)) {
-    rlang::abort(msg)
-  }
-  invisible(NULL)
+  any(x < 0 | x > 1)
 }
 
-check_value_order <- function(low, high, target = NULL) {
-  if (length(low) != 1 || !is.numeric(low) || is.na(low)) {
-    rlang::abort("'low' should be a single numeric value.")
+check_unit_range <- function(x, call = rlang::caller_env()) {
+
+  msg <- c(
+    "Desirability values should be numeric and complete in the range [0, 1]."
+  )
+
+  if (!is.vector(x) || !is.numeric(x)) {
+    msg <- c(msg, "i" = "Current values are {.obj_type_friendly {x}}.")
+    cli::cli_abort(msg, call = call)
   }
 
-  if (length(high) != 1 || !is.numeric(high) || is.na(high)) {
-    rlang::abort("'high' should be a single numeric value.")
+  if (out_of_unit_range(x) || length(x) > 1) {
+    offenders <- sum(x < 0 | x > 1)
+    msg <- c(msg, "i" = "{offenders} value{?s} {?is/are} outside the [0, 1] range.")
+
+    cli::cli_abort(msg, call = call)
   }
 
+  invisible(NULL)
+}
+
+check_value_order <- function(low, high, target = NULL, call = rlang::caller_env()) {
+  check_number_decimal(low, call = call)
+  check_number_decimal(high, call = call)
+  check_number_decimal(target, allow_null = TRUE, call = call)
+
   if (!is.null(target)) {
-    if (length(target) != 1 || !is.numeric(target) || is.na(target)) {
-      rlang::abort("'target' should be a single numeric value.")
-    }
     ord <- low < target & target < high
     if (!ord) {
-      rlang::abort("The values should be `low < target < high`.")
-    }
-  } else {
-    ord <- low < high
-    if (!ord) {
-      rlang::abort("The values should be `low < high`.")
+      cli::cli_abort("The values should be {.code low < target < high}  (actual
+                     are {low}, {target}, and {high}).", call = call)
     }
   }
+
+  ord <- low < high
+  if (!ord) {
+    cli::cli_abort("The values should be {.code low < high} (actual are {low}
+                   and {high}).", call = call)
+  }
+
   invisible(NULL)
 }
 
-is_vector_args <- function(values, d) {
+check_vector_args <- function(values, d, call = rlang::caller_env()) {
   if (!is.vector(values) || !is.numeric(values)) {
-    rlang::abort("'values' should be a numeric vector.")
+    cli::cli_abort("{.arg values} should be a numeric vector.", call = call)
   }
   if (!is.vector(d) || !is.numeric(d)) {
-    rlang::abort("'d' should be a numeric vector.")
+    cli::cli_abort("'d' should be a numeric vector.", call = call)
   }
   if (length(values) != length(d)) {
-    rlang::abort("'values' and 'd' should be the same length.")
+    cli::cli_abort("{.arg values} ({length(values)}) and {.arg d} ({length(d)}) should be the same length.",
+                   call = call)
   }
   invisible(TRUE)
 }
 
 
-check_args <- function(arg, x, use_data, fn, type = "low") {
+check_args <- function(arg, x, use_data, fn, type = "low", call = rlang::caller_env()) {
   if (rlang::is_missing(arg)) {
     if (use_data) {
-      type <- rlang::arg_match0(type, c("low", "high", "target"))
+      type <- rlang::arg_match0(type, c("low", "high", "target"), error_call = call)
       .fn <- switch(type, low = min, high = max, target = stats::median)
       arg <- .fn(x, na.rm = TRUE)
     } else {
-      rlang::abort(
-        glue::glue("In `{fn}()`, argument '{type}' is required when 'new_data = FALSE'.")
-      )
+      cli::cli_abort("In {.fn {fn}}, argument {.arg {type}} is required when
+                     {.code new_data = FALSE}.", call = call)
     }
   }
   arg
 }
 
-check_scale <- function(x) {
-  if (length(x) != 1 || !is.numeric(x) || is.na(x)) {
-    rlang::abort("The scale parameter should be a single numeric value.")
-  }
-  if (x <= 0) {
-    rlang::abort("The scale parameter great then zero.")
-  }
-
+check_scale <- function(x, arg, call = rlang::caller_env()) {
+  check_number_decimal(x, min = 0, arg = arg, call = call)
   invisible(NULL)
 }
 
-is_d_input <- function(x) {
-  tmp <- purrr::map(x, check_numeric, input = "desirability")
-  tmp <- purrr::map(x, check_unit_range)
+is_d_input <- function(x, call = rlang::caller_env()) {
+  tmp <- purrr::map(x, check_numeric, input = "desirability", call = call)
+  outside <- purrr::map_lgl(x, out_of_unit_range)
+  if (any(outside)) {
+    bad_cols <- names(x)[outside]
+    cli::cli_abort("{length(bad_cols)} {?of the} column{?s} {?is/are} not
+                    within {.code [0, 1]}: {.val {bad_cols}}", call = call)
+  }
   size <- purrr::map_int(x, length)
   if (length(unique(size)) != 1) {
-    rlang::abort("All desirability inputs should have the same length.")
+    cli::cli_abort("All desirability inputs should have the same length.", call = call)
   }
   invisible(TRUE)
 }

diff --git a/R/computations.R b/R/computations.R
@@ -1,7 +1,7 @@
-.comp_max <- function(x, low, high, scale, missing) {
-  check_unit_range(missing)
-  check_numeric(x)
-  check_value_order(low, high)
+.comp_max <- function(x, low, high, scale, missing, call = rlang::caller_env()) {
+  check_unit_range(missing, call = call)
+  check_numeric(x, call = call)
+  check_value_order(low, high, call = call)
 
   out <- rep(missing, length(x))
   out[x < low & !is.na(x)] <- 0
@@ -11,10 +11,10 @@
   out
 }
 
-.comp_min <- function(x, low, high, scale, missing) {
-  check_unit_range(missing)
-  check_numeric(x)
-  check_value_order(low, high)
+.comp_min <- function(x, low, high, scale, missing, call = rlang::caller_env()) {
+  check_unit_range(missing, call = call)
+  check_numeric(x, call = call)
+  check_value_order(low, high, call = call)
 
   out <- rep(missing, length(x))
   out[x < low & !is.na(x)] <- 1
@@ -25,10 +25,11 @@
 }
 
 
-.comp_target <- function(x, low, target, high, scale_low, scale_high, missing) {
-  check_unit_range(missing)
-  check_numeric(x)
-  check_value_order(low, high, target)
+.comp_target <- function(x, low, target, high, scale_low, scale_high, missing,
+                         call = rlang::caller_env()) {
+  check_unit_range(missing, call = call)
+  check_numeric(x, call = call)
+  check_value_order(low, high, target, call = call)
 
   out <- rep(missing, length(x))
 
@@ -42,11 +43,14 @@
 }
 
 
-.comp_custom <- function(x, values, d, missing) {
-  check_unit_range(missing)
-  check_unit_range(d)
-  check_numeric(x)
-  is_vector_args(values, d)
+.comp_custom <- function(x, values, d, missing, call = rlang::caller_env()) {
+  check_unit_range(missing, call = call)
+  if (!is.numeric(d) | out_of_unit_range(d)) {
+    cli::cli_abort("Desirability values should be numeric and complete in the
+                    range [0, 1].", call = call)
+  }
+  check_numeric(x, call = call)
+  check_vector_args(values, d, call = call)
 
   ord <- order(values)
   values <- values[ord]
@@ -64,10 +68,10 @@
 }
 
 
-.comp_box <- function(x, low, high, missing) {
-  check_numeric(x)
-  check_unit_range(missing)
-  check_value_order(low, high)
+.comp_box <- function(x, low, high, missing, call = rlang::caller_env()) {
+  check_numeric(x, call = call)
+  check_unit_range(missing, call = call)
+  check_value_order(low, high, call = call)
 
   out <- rep(missing, length(x))
   out[x < low | x > high & !is.na(x)] <- 0
@@ -77,10 +81,13 @@
 }
 
 
-.comp_category <- function(x, values, missing) {
-  check_categorical(x)
-  check_unit_range(missing)
-  check_unit_range(values)
+.comp_category <- function(x, values, missing, call = rlang::caller_env()) {
+  check_categorical(x, call = call)
+  check_unit_range(missing, call = call)
+  if (!is.numeric(values) | out_of_unit_range(values)) {
+    cli::cli_abort("Desirability values should be numeric and complete in the
+                    range [0, 1].", call = call)
+  }
 
   # make consistent factors when needed, check names, better missing handling
 

diff --git a/R/desirability2-package.R b/R/desirability2-package.R
@@ -12,5 +12,6 @@
 "_PACKAGE"
 
 ## usethis namespace: start
+#' @import rlang
 ## usethis namespace: end
 NULL