diff --git a/R/misc.R b/R/misc.R index e052301a..9c3ba6f2 100644 --- a/R/misc.R +++ b/R/misc.R @@ -297,3 +297,21 @@ check_frac_range <- function(x, ..., arg = caller_arg(x), call = caller_env()) { call = call ) } + +check_unique <- function(x, ..., arg = caller_arg(x), call = caller_env()) { + check_dots_empty() + x2 <- x[!is.na(x)] + is_dup <- duplicated(x2) + if (!any(is_dup)) { + return(invisible(NULL)) + } + + dup_list <- x2[is_dup] + cli::cli_abort( + c( + x = "{.arg {arg}} must have unique values.", + i = "Duplicates: {.val {dup_list}}" + ), + call = call + ) +} diff --git a/R/parameters.R b/R/parameters.R index 52706aea..6cca62e7 100644 --- a/R/parameters.R +++ b/R/parameters.R @@ -66,25 +66,6 @@ parameters.list <- function(x, ...) { ) } -unique_check <- function(x, ..., call = caller_env()) { - check_dots_empty() - x2 <- x[!is.na(x)] - is_dup <- duplicated(x2) - if (any(is_dup)) { - dup_list <- x2[is_dup] - cl <- match.call() - - cli::cli_abort( - c( - x = "Element {.field {deparse(cl$x)}} should have unique values.", - i = "Duplicates exist for {cli::qty(dup_list)} item{?s}: {dup_list}" - ), - call = call - ) - } - invisible(TRUE) -} - param_or_na <- function(x) { inherits(x, "param") | all(is.na(x)) } @@ -135,7 +116,7 @@ parameters_constr <- function( check_character(name, call = call) check_character(id, call = call) - unique_check(id, call = call) + check_unique(id, call = call) check_character(source, call = call) check_character(component, call = call) check_character(component_id, call = call) diff --git a/tests/testthat/_snaps/misc.md b/tests/testthat/_snaps/misc.md index 60ff5a19..ee938fab 100644 --- a/tests/testthat/_snaps/misc.md +++ b/tests/testthat/_snaps/misc.md @@ -174,6 +174,34 @@ Error: ! `c(0.1, NA)` must be a numeric vector of length 2 with values between 0 and 1, not a double vector. +# check_unique() errors on duplicates + + Code + check_unique(c("a", "a")) + Condition + Error: + x `c("a", "a")` must have unique values. + i Duplicates: "a" + +--- + + Code + check_unique(c("a", "b", "a", "b")) + Condition + Error: + x `c("a", "b", "a", "b")` must have unique values. + i Duplicates: "a" and "b" + +--- + + Code + my_ids <- c("x", "x") + check_unique(my_ids) + Condition + Error: + x `my_ids` must have unique values. + i Duplicates: "x" + # vctrs-helpers-parameters Code diff --git a/tests/testthat/_snaps/parameters.md b/tests/testthat/_snaps/parameters.md index f17be9f5..1765dcf8 100644 --- a/tests/testthat/_snaps/parameters.md +++ b/tests/testthat/_snaps/parameters.md @@ -13,8 +13,8 @@ parameters_constr(ab, id = c("a", "a"), ab, ab, ab) Condition Error: - x Element id should have unique values. - i Duplicates exist for item: a + x `id` must have unique values. + i Duplicates: "a" --- @@ -58,8 +58,8 @@ parameters(list(a = mtry(), a = penalty())) Condition Error in `parameters()`: - x Element id should have unique values. - i Duplicates exist for item: a + x `id` must have unique values. + i Duplicates: "a" --- diff --git a/tests/testthat/test-misc.R b/tests/testthat/test-misc.R index 66013c95..18cec59c 100644 --- a/tests/testthat/test-misc.R +++ b/tests/testthat/test-misc.R @@ -91,6 +91,27 @@ test_that("check_frac_range()", { expect_snapshot(error = TRUE, check_frac_range(c(0.1, NA))) }) +test_that("check_unique() passes with unique values", { + expect_null(check_unique(c("a", "b", "c"))) + expect_null(check_unique(c(1, 2, 3))) + expect_null(check_unique(character())) +}) + +test_that("check_unique() ignores NA values", { + expect_null(check_unique(c("a", NA, "b"))) + expect_null(check_unique(c(NA, NA, NA))) + expect_null(check_unique(c("a", NA, NA, "b"))) +}) + +test_that("check_unique() errors on duplicates", { + expect_snapshot(error = TRUE, check_unique(c("a", "a"))) + expect_snapshot(error = TRUE, check_unique(c("a", "b", "a", "b"))) + expect_snapshot(error = TRUE, { + my_ids <- c("x", "x") + check_unique(my_ids) + }) +}) + test_that("vctrs-helpers-parameters", { expect_false(dials:::is_parameters(2)) expect_snapshot(