Extend expect_length to use an S4 object's length method, if exists

R/expect-length.R

@@ -15,18 +15,10 @@ expect_length <- function(object, n) {
   stopifnot(is.numeric(n), length(n) == 1)
   lab <- label(object)
 
-  if (!is_vector(object)) {
-    fail(sprintf("%s is not a vector.", lab))
-  }
-
   expect(
     length(object) == n,
     sprintf("%s has length %i, not length %i.", lab, length(object), n)
   )
 
   invisible(object)
 }
-
-is_vector <- function(x) {
-  typeof(x) %in% c("logical", "integer", "double", "complex", "character", "raw", "list")
-}

tests/testthat/test-expect-length.R

@@ -1,12 +1,31 @@
 context("expect_length")
 
-test_that("fails if not a vector", {
-  expect_failure(expect_length(environment(), 1), "not a vector")
-})
-
 test_that("length computed correctly", {
   expect_success(expect_length(1, 1))
-  expect_failure(expect_length(1, 2))
+  expect_failure(expect_length(1, 2), "has length 1, not length 2.")
+  expect_success(expect_length(1:10, 10))
+  expect_success(expect_length(letters[1:5], 5))
+})
+
+test_that("uses S4 length method, if exists", {
+  # A has no length method defined
+  A <- setClass("ExpectLengthA", slots=c(x="numeric", y="numeric"))
+  # Default for S4 objects that don't inherit a length method: always length 1
+  expect_success(expect_length(A(x=1:5, y=3), 1))
+
+  # B does has a length method defined
+  B <- setClass("ExpectLengthB", slots=c(x="numeric"))
+  setMethod("length", "ExpectLengthB", function (x) 5L)
+  expect_success(expect_length(B(x=1:8), 5))
+
+  # C does not, but it inherits from something that does
+  C <- setClass("ExpectLengthC", contains="list")
+  expect_success(expect_length(C(), 0))
+  expect_success(expect_length(C(1:10), 10))
+
+  # D does not explicitly have one, but it inherits from B, which does
+  D <- setClass("ExpectLengthD", contains="ExpectLengthB")
+  expect_success(expect_length(D(x=1:8), 5))
 })
 
 test_that("returns input", {