Improve validate option messages (#219)

* simplify errorValueNotAllowed string building

* strip function name prefix from aggregated error messages

* update tests to match refactored error messages

* update NEWS

* address review comments

Author: rengelke

NEWS.md

@@ -2,6 +2,7 @@
 
 ## Minor improvements and bug fixes
 
+- `validateIsOption()` aggregated error messages no longer include internal function name prefixes (#219).
 - Validation errors in R6 active bindings now show a readable caller name instead of the anonymous function body (#218).
 - `validateIsOption()` no longer emits a warning when auto-converting whole-number `numeric` to `integer` (#218).
 

R/messages.R

@@ -285,26 +285,14 @@ messages <- list(
     ))
   },
   errorValueNotAllowed = function(values, parentValues) {
-    callingFunction <- .getCallingFunctionName()
-    notIncludedValues <- values[!values %in% parentValues]
-    notIncludedValuesStr <- paste(head(notIncludedValues, 5), collapse = ", ")
-    notIncludedValuesStr <- ifelse(
-      length(notIncludedValues) > 5,
-      paste(notIncludedValuesStr, "..."),
-      notIncludedValuesStr
-    )
-    parentValuesStr <- paste(
-      head(parentValues, 5),
-      collapse = ", "
-    )
-    parentValuesStr <- ifelse(
-      length(parentValues) > 5,
-      paste(parentValuesStr, "..."),
-      parentValuesStr
-    )
-    cliFormat(
-      "{length(notIncludedValues)} value{?s} ({.val {notIncludedValuesStr}}) not included in allowed values.",
-      "Allowed values: {.val {parentValuesStr}}"
+    notIncludedValues <- unique(values[!values %in% parentValues])
+    notIncludedVec <- head(notIncludedValues, 5)
+    parentVec <- head(unique(parentValues), 5)
+    notIncludedSuffix <- if (length(notIncludedValues) > 5) " ..." else ""
+    parentSuffix <- if (length(unique(parentValues)) > 5) " ..." else ""
+    cliFormat(
+      "{.val {notIncludedVec}}{notIncludedSuffix} not allowed.",
+      "Allowed values: {.val {parentVec}}{parentSuffix}."
     )
   },
   errorTypeNotSupported = function(objectName, type, expectedType) {

R/validation-options.R

@@ -360,7 +360,7 @@ validateIsOption <- function(options, validOptions) {
         .validateValue(options[[name]], validOptions[[name]], name)
         TRUE
       },
-      error = function(e) e$message
+      error = function(e) sub("^[^`]*`\\: ", "", e$message)
     )
 
     if (!isTRUE(result)) {

tests/testthat/test-validation-options.R

@@ -435,12 +435,7 @@ test_that("validateIsOption() errors when option values exceed expected length",
   )
   expect_error(
     validateIsOption(testOptions, validOptions),
-    regexp = messages$errorWrongLength(
-      c(TRUE, FALSE),
-      1,
-      "includeInteractions"
-    ),
-    fixed = TRUE
+    "(includeInteractions).*(should be of length).*(1)"
   )
 })
 
@@ -495,7 +490,11 @@ test_that("validateIsOption() flags out-of-range and invalid values", {
   )
   expect_error(
     validateIsOption(invalidOptions, validOptions),
-    "(optimizationMethod).*(1 value).*(none).*(not included in allowed values)"
+    regexp = messages$errorValueNotAllowed(
+      "none",
+      c("gradientDescent", "geneticAlgorithm")
+    ),
+    fixed = TRUE
   )
 })
 
@@ -544,8 +543,7 @@ test_that("validateIsOption() validates expectedLength", {
   optionsWrongLength <- list(methods = "a")
   expect_error(
     validateIsOption(optionsWrongLength, validOptionsWithLength),
-    regexp = messages$errorWrongLength("a", 2, "methods"),
-    fixed = TRUE
+    "(methods).*(should be of length).*(2)"
   )
 })
 
@@ -710,7 +708,11 @@ test_that("validateIsOption() detects values not in allowed values for data fram
   )
 
   expect_true(grepl("gender", err))
-  expect_true(grepl("not included in allowed values", err))
+  expect_true(grepl(
+    messages$errorValueNotAllowed(c("Other"), c("M", "F")),
+    err,
+    fixed = TRUE
+  ))
 })
 
 test_that("validateIsOption() rejects NA when not allowed in data frame columns", {

tests/testthat/test-validation-vector.R

@@ -210,35 +210,40 @@ test_that("validateVectorValues() correctly identifies unpermitted values", {
       type = "numeric",
       allowedValues = c(1, 2)
     ),
-    "(1 value).*(3).*(not included in allowed values).*(Allowed values:).*(1, 2)"
+    regexp = messages$errorValueNotAllowed(3, c(1, 2)),
+    fixed = TRUE
   )
   expect_error(
     validateVectorValues(
       x = c("a", "b", "z"),
       type = "character",
       allowedValues = c("a", "b")
     ),
-    "(1 value).*(z).*(not included in allowed values).*(Allowed values:).*(a, b)"
+    regexp = messages$errorValueNotAllowed("z", c("a", "b")),
+    fixed = TRUE
   )
   expect_error(
     validateVectorValues(
       x = LETTERS[1:25],
       type = "character",
       allowedValues = LETTERS[1:10]
     ),
-    "(15 values).*(K, L, M, N, O \\.\\.\\.).*(not included in allowed values).*(Allowed values:).*(A, B, C, D, E \\.\\.\\.)"
+    regexp = messages$errorValueNotAllowed(LETTERS[1:25], LETTERS[1:10]),
+    fixed = TRUE
   )
   expect_error(
     validateVectorValues(x = TRUE, type = "logical", allowedValues = FALSE),
-    "(1 value).*(TRUE).*(not included in allowed values).*(Allowed values:).*(FALSE)"
+    regexp = messages$errorValueNotAllowed(TRUE, FALSE),
+    fixed = TRUE
   )
   expect_error(
     validateVectorValues(
       x = as.factor(c(1, 2, 3)),
       type = "factor",
       allowedValues = as.factor(c(1, 2))
     ),
-    "(1 value).*(3).*(not included in allowed values).*(Allowed values:).*(1, 2)"
+    regexp = messages$errorValueNotAllowed(as.factor(3), as.factor(c(1, 2))),
+    fixed = TRUE
   )
   expect_error(
     validateVectorValues(
@@ -247,7 +252,8 @@ test_that("validateVectorValues() correctly identifies unpermitted values", {
       allowedValues = c(1, 2),
       naAllowed = FALSE
     ),
-    "(1 value).*(NA).*(not included in allowed values).*(Allowed values:).*(1, 2)"
+    regexp = messages$errorValueNotAllowed(NA, c(1, 2)),
+    fixed = TRUE
   )
   expect_error(
     validateVectorValues(
@@ -256,7 +262,8 @@ test_that("validateVectorValues() correctly identifies unpermitted values", {
       allowedValues = c(1, 2, NA),
       naAllowed = FALSE
     ),
-    "(1 value).*(NA).*(not included in allowed values).*(Allowed values:).*(1, 2)"
+    regexp = messages$errorValueNotAllowed(NA, c(1, 2)),
+    fixed = TRUE
   )
 })