expect_setequal

DESCRIPTION

@@ -31,6 +31,7 @@ Collate:
     'compare.R'
     'compare-character.R'
     'compare-numeric.R'
+    'compare-set.R'
     'compare-time.R'
     'context.R'
     'describe.R'

NAMESPACE

@@ -16,10 +16,12 @@ S3method(format,expectation_error)
 S3method(format,expectation_success)
 S3method(format,mismatch_character)
 S3method(format,mismatch_numeric)
+S3method(format,mismatch_set)
 S3method(print,comparison)
 S3method(print,expectation)
 S3method(print,mismatch_character)
 S3method(print,mismatch_numeric)
+S3method(print,mismatch_set)
 S3method(print,testthat_results)
 export("%>%")
 export(CheckReporter)
@@ -41,6 +43,7 @@ export(capture_messages)
 export(capture_output)
 export(capture_warnings)
 export(compare)
+export(compare_set)
 export(context)
 export(describe)
 export(equals)
@@ -71,6 +74,7 @@ export(expect_output)
 export(expect_output_file)
 export(expect_s3_class)
 export(expect_s4_class)
+export(expect_setequal)
 export(expect_silent)
 export(expect_success)
 export(expect_that)

R/compare-set.R

@@ -0,0 +1,74 @@
+#' @export
+#' @rdname compare
+compare_set <- function(x,
+                        y,
+                        ...,
+                        max_diffs = 5,
+                        max_lines = 5,
+                        width = getOption("width")) {
+  if (setequal(x, y)) {
+    return(no_difference())
+  }
+
+  mismatches <- mismatch_set(x, y)
+  difference(format(
+    mismatches,
+    max_diffs = max_diffs,
+    max_lines = max_lines,
+    width = width
+  ))
+
+}
+
+mismatch_set <- function(x, y) {
+  structure(list(
+    x = setdiff(x, y),
+    y = setdiff(y, x),
+    n_x = length(setdiff(x, y)),
+    n_y = length(setdiff(y, x))
+  ),
+  class = "mismatch_set")
+}
+
+#' @export
+format.mismatch_set <- function(x,
+                                ...,
+                                max_diffs = 5,
+                                max_lines = 5,
+                                width = getOption("width")) {
+  width <- width - 6 # allocate space for labels
+  n_show <- seq_len(min(max(x$n_x, x$n_y), max_diffs))
+
+  encode <- function(x)
+    encodeString(x, quote = '"')
+  show_x <-
+    str_trunc(paste0(encode(x$x), collapse = ", "), width * max_lines)
+  show_y <-
+    str_trunc(paste0(encode(x$y), collapse = ", "), width * max_lines)
+
+  if (show_x == "") {
+    show_x = " "
+  }
+  if (show_y == "") {
+    show_y = " "
+  }
+
+  sidebyside <- paste(c(
+    paste0("setdiff(x, y): ",
+           str_chunk(as.character(show_x), width)),
+    paste0("setdiff(y, x): ",
+           str_chunk(as.character(show_y), width))
+  ),
+  collapse = "\n")
+
+  summary <- paste0(x$n_x,
+                    " elements of x are not in y\n",
+                    x$n_y,
+                    " elements of y are not in x\n")
+  paste0(summary, "\n", paste0(sidebyside, collapse = "\n\n"))
+}
+
+#' @export
+print.mismatch_set <- function(x, ...) {
+  cat(format(x, ...), "\n", sep = "")
+}

R/expect-equality.R

@@ -105,3 +105,21 @@ expect_identical <- function(object, expected, info = NULL, label = NULL,
   invisible(object)
 }
 
+#' @export
+#' @rdname equality-expectations
+expect_setequal <- function(object, expected, info = NULL, label = NULL,
+                            expected.label = NULL) {
+
+  lab_act <- make_label(object, label)
+  lab_exp <- make_label(expected, expected.label)
+
+  steq <- compare_set(object, expected)
+
+  expect(
+    steq$equal,
+    sprintf("%s not setequal to %s.\n%s", lab_act, lab_exp, steq$message),
+    info = info
+  )
+  invisible(object)
+
+}

tests/testthat/test-expect-equality.R

@@ -41,3 +41,10 @@ test_that("attributes for object (#452)", {
   expect_failure(expect_equal(oops, 0))
   expect_equal(as.numeric(oops), 0)
 })
+
+test_that("expect_setequal as expected", {
+  expect_success(expect_setequal(1:2, 2:1))
+  expect_success(expect_setequal(c("MALE", "FEMALE"), c("FEMALE", "MALE")))
+  expect_failure(expect_setequal(1:3, 1:2))
+  expect_failure(expect_setequal(c("MALE", "FEMALE"), c("BOY", "GIRL")))
+})