Improve error message of checkSubset (#212)

.lintr

@@ -0,0 +1,10 @@
+linters: with_defaults(
+    # lintr defaults: https://github.com/jimhester/lintr#available-linters
+    # the following setup changes/removes certain linters
+    assignment_linter = NULL, # do not force using <- for assignments
+    object_name_linter = NULL,
+    cyclocomp_linter = NULL, # do not check function complexity
+    commented_code_linter = NULL, # allow code in comments
+    line_length_linter = line_length_linter(180)
+    )
+

DESCRIPTION

@@ -38,7 +38,7 @@ Suggests:
     tibble
 License: BSD_3_clause + file LICENSE
 VignetteBuilder: knitr
-RoxygenNote: 7.1.1
+RoxygenNote: 7.1.2
 Collate:
     'AssertCollection.R'
     'allMissing.R'

R/checkDisjunct.R

@@ -18,16 +18,13 @@
 #' testDisjunct(1, "1")
 #' testDisjunct(1, as.integer(1))
 checkDisjunct = function(x, y, fmatch = FALSE) {
-  if (length(x) == 0L || length(y) == 0)
-    return(TRUE)
+  qassert(x, "a")
   qassert(y, "a")
 
   if (isTRUE(fmatch) && requireNamespace("fastmatch", quietly = TRUE))
     match = fastmatch::fmatch
-  i = (match(x, y, 0L) > 0L)
-  if (any(i))
-    return(sprintf("Must be disjunct from set %s, but has %s", set_collapse(y), set_collapse(x[i])))
-  return(TRUE)
+
+  check_disjunct_internal(x, y, match)
 }
 
 #' @export

R/checkNames.R

@@ -52,48 +52,48 @@ checkNames = function(x, type = "named", subset.of = NULL, must.include = NULL,
 checkNamesCmp = function(x, subset.of, must.include, permutation.of, identical.to, disjunct.from, what) {
   if (!is.null(subset.of)) {
     qassert(subset.of, "S")
-    if (anyMissing(match(x, subset.of))) {
-      return(sprintf("%s must be a subset of set {%s}",
-          capitalize(what),
-          paste0(subset.of, collapse = ",")
-      ))
-    }
+    msg = check_subset_internal(x, subset.of, match, what)
+    if (!isTRUE(msg))
+      return(msg)
   }
+
   if (!is.null(must.include)) {
     qassert(must.include, "S")
-    if (anyMissing(match(must.include, x))) {
-      return(sprintf("%s must include the elements {%s}",
-          capitalize(what),
-          paste0(must.include, collapse = ",")
+    ii = match(must.include, x)
+    if (anyMissing(ii)) {
+      return(set_msg("must include the elements %s, but is missing elements %s",
+        what,
+        set_collapse(must.include),
+        set_collapse(must.include[is.na(ii)])
       ))
     }
   }
+
   if (!is.null(permutation.of)) {
     permutation.of = unique(qassert(permutation.of, "S"))
-    if (length(x) != length(permutation.of) || !setequal(x, permutation.of)) {
-      return(sprintf("%s must be a permutation of set {%s}",
-          capitalize(what),
-          paste0(permutation.of, collapse = ",")
-      ))
-    }
+    msg = check_set_equal_internal(x, permutation.of, match, what)
+    if (!isTRUE(msg))
+      return(msg)
   }
+
   if (!is.null(identical.to)) {
     qassert(identical.to, "S")
     if (!identical(x, identical.to)) {
-      return(sprintf("%s must be a identical to (%s)",
-          capitalize(what),
-          paste0(identical.to, collapse = ",")
+      return(set_msg("must be a identical to set %s, but is %s",
+        what,
+        set_collapse(identical.to),
+        set_collapse(x)
       ))
     }
   }
+
   if (!is.null(disjunct.from)) {
-    if (any(x %in% disjunct.from)) {
-      return(sprintf("%s must be disjunct from (%s)",
-          capitalize(what),
-          paste0(disjunct.from, collapse = ",")
-      ))
-    }
+    qassert(disjunct.from, "S")
+    msg = check_disjunct_internal(x, disjunct.from, match, what)
+    if (!isTRUE(msg))
+      return(msg)
   }
+
   return(TRUE)
 }
 

R/checkSetEqual.R

@@ -29,13 +29,13 @@ checkSetEqual = function(x, y, ordered = FALSE, fmatch = FALSE) {
   if (ordered) {
     if (!isSameType(x, y) || length(x) != length(y) || any(xor(is.na(x), is.na(y)) | x != y, na.rm = TRUE))
       return(sprintf("Must be equal to %s, but is %s", array_collapse(y), array_collapse(x)))
-  } else {
-    if (isTRUE(fmatch) && requireNamespace("fastmatch", quietly = TRUE))
-      match = fastmatch::fmatch
-    if ((!isSameType(x, y) && !allMissing(x)) || anyMissing(match(x, y)) || anyMissing(match(y, x)))
-      return(sprintf("Must be equal to set %s, but is %s", set_collapse(y), set_collapse(x)))
+    return(TRUE)
   }
-  return(TRUE)
+
+  if (isTRUE(fmatch) && requireNamespace("fastmatch", quietly = TRUE))
+    match = fastmatch::fmatch
+
+  check_set_equal_internal(x, y, match)
 }
 
 #' @export

R/checkSubset.R

@@ -29,19 +29,10 @@ checkSubset = function(x, choices, empty.ok = TRUE, fmatch = FALSE) {
     return(TRUE)
   }
 
-  qassert(choices, "a")
-  if (length(choices) == 0L) {
-    if (length(x) == 0L)
-      return(TRUE)
-    return("Must be a subset of the empty set, i.e. also empty")
-  }
-
   if (isTRUE(fmatch) && requireNamespace("fastmatch", quietly = TRUE))
     match = fastmatch::fmatch
 
-  if (!is.null(x) && ((!isSameType(x, choices) && !allMissing(x)) || anyMissing(match(x, choices))))
-    return(sprintf("Must be a subset of %s, but is %s", set_collapse(choices), set_collapse(x)))
-  return(TRUE)
+  check_subset_internal(x, choices, match)
 }
 
 #' @export

R/helper.R

@@ -29,13 +29,86 @@ array_collapse = function(x) {
   sprintf("['%s']", paste0(x, collapse = "','"))
 }
 
+capitalize = function(x) {
+  substr(x, 1L, 1L) = toupper(substr(x, 1L, 1L))
+  x
+}
+
 set_collapse = function(x) {
   if (length(x) == 0L)
     return("{}")
   sprintf("{'%s'}", paste0(unique(x), collapse = "','"))
 }
 
-capitalize = function(x) {
-  substr(x, 1L, 1L) = toupper(substr(x, 1L, 1L))
-  x
+set_msg = function(msg, what, ...) {
+  if (is.null(what)) {
+    sprintf(capitalize(msg), ...)
+  } else {
+    paste0(capitalize(what), sprintf(msg, ...))
+  }
+}
+
+check_subset_internal = function(x, choices, match, what = NULL) {
+  qassert(choices, "a")
+  if (length(choices) == 0L) {
+    if (length(x) == 0L)
+      return(TRUE)
+    return(set_msg("must be a subset of the empty set, i.e. also empty", what))
+  }
+
+  if (!is.null(x)) {
+    if (!isSameType(x, choices) && !allMissing(x)) {
+      return(set_msg("must be a subset of %s, but has different type", what, set_collapse(choices)))
+    }
+
+    ii = match(x, choices)
+    if (anyMissing(ii)) {
+      return(set_msg(
+        "must be a subset of %s, but has additional elements %s",
+        what, set_collapse(choices), set_collapse(x[is.na(ii)])
+      ))
+    }
+  }
+
+  return(TRUE)
+}
+
+check_set_equal_internal = function(x, y, match, what = NULL) {
+  if ((!isSameType(x, y) && !allMissing(x))) {
+    return(set_msg("Must be setequal to %s, but has different type",
+        what, set_collapse(y)))
+  }
+
+  ii = match(x, y)
+  if (anyMissing(ii)) {
+    return(set_msg("must be a permutation of set %s, but has extra elements %s",
+        what, set_collapse(y), set_collapse(x[is.na(ii)])
+    ))
+  }
+
+  ii = match(y, x)
+  if (anyMissing(ii)) {
+    return(set_msg("must be a set equal to %s, but is missing elements %s",
+        what, set_collapse(y), set_collapse(y[is.na(ii)])
+    ))
+  }
+
+  return(TRUE)
+}
+
+check_disjunct_internal = function(x, y, match, what = NULL) {
+  if (length(x) == 0L || length(y) == 0L) {
+    return(TRUE)
+  }
+
+  ii = match(x, y, 0L) > 0L
+  if (any(ii)) {
+    return(set_msg("must be disjunct from %s, but has elements %s",
+      what,
+      set_collapse(y),
+      set_collapse(x[ii])
+    ))
+  }
+
+  return(TRUE)
 }

tests/testthat/test_checkNames.R

@@ -60,6 +60,11 @@ test_that("checkNames / subset.of", {
   expect_false(testNames(NULL, subset.of = character(0)))
   expect_true(testNames(character(0), subset.of = character(0)))
   expect_true(testNames(character(0), subset.of = NULL))
+
+  expect_error(
+    assert_names(names(x), subset.of = c("a", "b")),
+    "{'c'}", fixed = TRUE
+  )
 })
 
 test_that("checkNames / identical.to", {
@@ -75,6 +80,11 @@ test_that("checkNames / identical.to", {
   expect_true(testNames(character(0), identical.to = character(0)))
   expect_true(testNames(character(0), identical.to = NULL))
   expect_false(testNames(NULL, identical.to = NULL))
+
+  expect_error(
+    assert_names(names(x), identical.to = c("a", "b")),
+    "{'a','b','c'}", fixed = TRUE
+  )
 })
 
 test_that("checkNames / permutation.of", {
@@ -90,6 +100,16 @@ test_that("checkNames / permutation.of", {
   expect_true(testNames(character(0), permutation.of = character(0)))
   expect_true(testNames(character(0), permutation.of = NULL))
   expect_false(testNames(NULL, permutation.of = NULL))
+
+  expect_error(
+    assert_names(names(x), permutation.of = c("a", "b")),
+    "{'c'}", fixed = TRUE
+  )
+
+  expect_error(
+    assert_names(names(x), permutation.of = c("a", "b", "c", "d")),
+    "{'d'}", fixed = TRUE
+  )
 })
 
 test_that("checkNames / must.include", {
@@ -103,6 +123,11 @@ test_that("checkNames / must.include", {
   expect_false(testNames(NULL, must.include = character(0)))
   expect_true(testNames(character(0), must.include = character(0)))
   expect_true(testNames(character(0), must.include = NULL))
+
+  expect_error(
+    assert_names(names(x), must.include = c("a", "b", "c", "d")),
+    "{'d'}", fixed = TRUE
+  )
 })
 
 test_that("checkNames / disjunct.from", {
@@ -112,6 +137,11 @@ test_that("checkNames / disjunct.from", {
   expect_true(testNames(names(x)))
   expect_true(testNames(names(x), disjunct.from = "d"))
   expect_false(testNames(names(x), disjunct.from = "b"))
+
+  expect_error(
+    assert_names(names(x), disjunct.from = c("c")),
+    "{'c'}", fixed = TRUE
+  )
 })
 
 test_that("checkNames / errors are useful", {