Expect shape

R/expect-shape.R

@@ -15,42 +15,53 @@
 #' @export
 #' @examples
 expect_shape = function(object, ..., length, nrow, ncol, dim) {
-  # absent, not present, due to '!' operator precedence
-  n_absent <- missing(length) + missing(nrow) + missing(ncol) + missing(dim)
-  if (n_absent != 3L) {
-    cli::cli_abort(
-      "Exactly one of {.arg length}, {.arg nrow}, {.arg ncol}, or {.arg dim} must be provided."
-    )
-  }
+  rlang::check_exclusive(length, nrow, ncol, dim)
 
   # Re-use expect_length() to ensure they stay in sync.
   if (!missing(length)) {
     return(expect_length(object, length))
   }
 
+  # need base:: qualification or we might trigger an error for missing(length)
+  length <- base::length
+
   act <- quasi_label(enquo(object), arg = "object")
-  # need base:: qualification or we might trigger an error for missing(dim)
   dim_object <- base::dim(object)
 
+  expect(
+    !is.null(dim_object),
+    sprintf("%s has no dimensions.", act$lab)
+  )
+
   if (!missing(nrow)) {
     act$nrow <- dim_object[1L]
 
     expect(
-      act$nrow == nrow,
+      identical(as.integer(act$nrow), as.integer(nrow)),
       sprintf("%s has %i rows, not %i.", act$lab, act$nrow, nrow)
     )
   } else if (!missing(ncol)) {
+    expect(
+      length(dim_object) >= 2L,
+      sprintf("%s has only one dimension.", act$lab)
+    )
+
     act$ncol <- dim_object[2L]
 
     expect(
-      act$ncol == ncol,
+      identical(as.integer(act$ncol), as.integer(ncol)),
       sprintf("%s has %i columns, not %i.", act$lab, act$ncol, ncol)
     )
   } else { # !missing(dim)
     act$dim <- dim_object
 
     expect(
-      isTRUE(all.equal(act$dim, dim)),
+      length(act$dim) == length(dim),
+      sprintf("%s has %i dimensions, not %i", act$lab, length(act$dim), length(dim))
+    )
+
+    expect(
+      identical(as.integer(act$dim), as.integer(dim)),
       sprintf("%s has shape (%s), not (%s).", act$lab, toString(act$dim), toString(dim))
     )
   }

tests/testthat/_snaps/expect-shape.md

@@ -1,8 +1,8 @@
-# shape computed correctly
+# length compared correctly
 
     `object` has length 1, not length 2.
 
----
+# dim compared correctly
 
     matrix(nrow = 6, ncol = 3) has shape (6, 3), not (6, 2).
 
@@ -12,33 +12,66 @@
 
 ---
 
+    array(dim = 1:3) has 3 dimensions, not 2
+
+---
+
+    array(dim = 1:3) has 3 dimensions, not 4
+
+# nrow compared correctly
+
     matrix(nrow = 5, ncol = 5) has 5 rows, not 6.
 
 ---
 
+    1 has no dimensions.
+
+# ncol compared correctly
+
     matrix(nrow = 5, ncol = 5) has 5 columns, not 7.
 
+---
+
+    array(1) has only one dimension.
+
+---
+
+    array() has only one dimension.
+
+# NA handling (e.g. dbplyr)
+
+    `x` has NA rows, not 10.
+
+---
+
+    `x` has 10 columns, not NA.
+
+---
+
+    `x` has shape (NA, 10), not (10, NA).
+
 # at least one argument is required
 
     Code
       expect_shape(1:10)
     Condition
       Error in `expect_shape()`:
-      ! Exactly one of `length`, `nrow`, `ncol`, or `dim` must be provided.
+      ! One of `length`, `nrow`, `ncol`, or `dim` must be supplied.
 
 ---
 
     Code
       expect_shape(1:10, 2)
     Condition
       Error in `expect_shape()`:
-      ! Exactly one of `length`, `nrow`, `ncol`, or `dim` must be provided.
+      ! One of `length`, `nrow`, `ncol`, or `dim` must be supplied.
 
 ---
 
     Code
       expect_shape(1:10, nrow = 1L, ncol = 2L)
     Condition
       Error in `expect_shape()`:
-      ! Exactly one of `length`, `nrow`, `ncol`, or `dim` must be provided.
+      ! Exactly one of `length`, `nrow`, `ncol`, or `dim` must be supplied.
+      x `nrow` and `ncol` were supplied together.
 

tests/testthat/test-expect-shape.R

@@ -1,26 +1,66 @@
-test_that("shape computed correctly", {
-  # equivalent to expect_length
+test_that("length compared correctly", {
   expect_success(expect_shape(1, length = 1))
   expect_snapshot_failure(expect_shape(1, length = 2))
   expect_success(expect_shape(1:10, length = 10))
   expect_success(expect_shape(letters[1:5], length = 5))
+  expect_success(expect_shape(integer(), length = 0))
+})
 
-  # testing dim()
+test_that("dim compared correctly", {
   expect_success(expect_shape(matrix(nrow = 5, ncol = 4), dim = c(5L, 4L)))
   expect_snapshot_failure(expect_shape(matrix(nrow = 6, ncol = 3), dim = c(6L, 2L)))
   expect_snapshot_failure(expect_shape(matrix(nrow = 6, ncol = 3), dim = c(7L, 3L)))
   expect_success(expect_shape(data.frame(1:10, 11:20), dim = c(10, 2)))
   expect_success(expect_shape(array(dim = 1:3), dim = 1:3))
+  expect_snapshot_failure(expect_shape(array(dim = 1:3), dim = 1:2))
+  expect_snapshot_failure(expect_shape(array(dim = 1:3), dim = 1:4))
+  expect_success(expect_shape(array(), dim = 0L))
+  dd <- c(0L, 0L, 0L, 5L, 0L, 0L, 0L)
+  expect_success(expect_shape(array(dim = dd), dim = dd))
+})
 
-  # testing nrow=
+test_that("nrow compared correctly", {
   expect_success(expect_shape(matrix(nrow = 5, ncol = 4), nrow = 5L))
   expect_snapshot_failure(expect_shape(matrix(nrow = 5, ncol = 5), nrow = 6L))
   expect_success(expect_shape(data.frame(1:10, 11:20), nrow = 10L))
+  expect_snapshot_failure(expect_shape(1, nrow = 1))
+  expect_success(expect_shape(array(), nrow = 0L))
+  dd <- c(0L, 0L, 0L, 5L, 0L, 0L, 0L)
+  expect_success(expect_shape(array(dim = dd), nrow = 0L))
+})
 
-  # testing ncol=
+test_that("ncol compared correctly", {
   expect_success(expect_shape(matrix(nrow = 5, ncol = 4), ncol = 4L))
   expect_snapshot_failure(expect_shape(matrix(nrow = 5, ncol = 5), ncol = 7L))
   expect_success(expect_shape(data.frame(1:10, 11:20), ncol = 2L))
+  expect_snapshot_failure(expect_shape(array(1), ncol = 1))
+  expect_snapshot_failure(expect_shape(array(), ncol = 0L))
+  dd <- c(0L, 0L, 0L, 5L, 0L, 0L, 0L)
+  expect_success(expect_shape(array(dim = dd), ncol = 0L))
+})
+
+test_that("uses S3 dim method", {
+  dim.testthat_expect_shape <- function(x) 1:2
+  x <- integer()
+  class(x) <- "testthat_expect_shape"
+  registerS3method("dim", "testthat_expect_shape", dim.testthat_expect_shape)
+
+  expect_success(expect_shape(x, dim = 1:2))
+})
+
+test_that("NA handling (e.g. dbplyr)", {
+  dim.testthat_expect_shape_missing <- function(x) c(NA_integer_, 10L)
+  x <- integer()
+  class(x) <- "testthat_expect_shape_missing"
+  registerS3method("dim", "testthat_expect_shape_missing", dim.testthat_expect_shape_missing)
+
+  expect_success(expect_shape(x, nrow = NA_integer_))
+  expect_success(expect_shape(x, ncol = 10L))
+  expect_success(expect_shape(x, dim = c(NA_integer_, 10L)))
+
+  expect_snapshot_failure(expect_shape(x, nrow = 10L))
+  expect_snapshot_failure(expect_shape(x, ncol = NA_integer_))
+  expect_snapshot_failure(expect_shape(x, dim = c(10L, NA_integer_)))
 })
 
 test_that("uses S4 dim method", {