tests/testthat/test-shape.R

In r-lib/vctrs: Vector Helpers

# common shape ------------------------------------------------------------

test_that("vec_shape2() applies recycling rules", {
  expect_equal(vec_shape2(shaped_int(1, 5, 5), shaped_int(1)),       c(0L, 5L, 5L))
  expect_equal(vec_shape2(shaped_int(1),       shaped_int(1, 5, 5)), c(0L, 5L, 5L))
  expect_equal(vec_shape2(shaped_int(1, 1),    shaped_int(1, 5, 5)), c(0L, 5L, 5L))
  expect_equal(vec_shape2(shaped_int(1, 1, 1), shaped_int(1, 5, 5)), c(0L, 5L, 5L))

  expect_equal(vec_shape2(shaped_int(1, 1, 5), shaped_int(1, 5, 1)), c(0L, 5L, 5L))
  expect_equal(vec_shape2(shaped_int(1, 5, 1), shaped_int(1, 1, 5)), c(0L, 5L, 5L))
  expect_equal(vec_shape2(shaped_int(1, 1, 1), shaped_int(1, 5, 5)), c(0L, 5L, 5L))

  expect_equal(vec_shape2(shaped_int(1, 0, 5), shaped_int(1, 1, 1)), c(0L, 0L, 5L))
})

test_that("incompatible shapes throw errors", {
  expect_snapshot({
    (expect_error(vec_shape2(shaped_int(1, 0, 5), shaped_int(1, 5, 1)), class = "vctrs_error_incompatible_type"))
    (expect_error(vec_shape2(shaped_int(1, 5, 0), shaped_int(1, 1, 5)), class = "vctrs_error_incompatible_type"))
  })
})

test_that("can override error args", {
  expect_snapshot({
    (expect_error(
      vec_shape2(shaped_int(1, 0, 5), shaped_int(1, 5, 1), x_arg = "foo", y_arg = "bar"),
      class = "vctrs_error_incompatible_type"
    ))
  })
})

test_that("vec_shape2() evaluates arg lazily", {
  expect_silent(vec_shape2(shaped_int(1, 5, 5), shaped_int(1), x_arg = print("oof")))
  expect_silent(vec_shape2(shaped_int(1, 5, 5), shaped_int(1), y_arg = print("oof")))
})

# broadcasting -------------------------------------------------------------

test_that("can broadcast to higher dimension, but not lower", {
  expect_identical(shape_broadcast_(1, NULL), 1)
  expect_null(shape_broadcast_(NULL, 1))

  expect_equal(
    shape_broadcast_(1, shaped_int(0, 4)),
    array(1, c(1, 4))
  )
  expect_error(
    shape_broadcast_(shaped_int(1, 1, 1), shaped_int(4, 4)),
    class = "vctrs_error_incompatible_type"
  )
  expect_error(
    shape_broadcast_(shaped_int(3, 2), shaped_int(3, 3)),
    class = "vctrs_error_incompatible_type"
  )
})

test_that("shape_broadcast_() applies recycling rules", {
  expect_equal(
    shape_broadcast_(array(1:4, c(1, 1, 4)), shaped_int(0, 4, 4))[1, , ],
    matrix(1:4, 4, 4, byrow = TRUE)
  )

  expect_equal(
    shape_broadcast_(array(1:4, c(1, 4, 1)), shaped_int(0, 4, 4))[1, , ],
    matrix(1:4, 4, 4)
  )

  expect_equal(
    shape_broadcast_(array(1L, c(1, 1)), shaped_int(1, 0)),
    matrix(integer(), nrow = 1)
  )

  expect_error(
    shape_broadcast_(array(1L, c(1, 2)), shaped_int(1, 0)),
    "Non-recyclable dimensions",
    class = "vctrs_error_incompatible_type"
  )

  expect_error(
    shape_broadcast_(array(1L, c(1, 0)), shaped_int(1, 1)),
    "Non-recyclable dimensions",
    class = "vctrs_error_incompatible_type"
  )
})

test_that("can combine shaped native classes (#1290, #1329)", {
  x <- new_datetime(c(1, 1e6))
  dim(x) <- c(1, 2)
  out <- vec_c(x, x)

  expect_s3_class(out, c("POSIXct", "POSIXt"))
  expect_dim(out, c(2, 2))

  y <- new_datetime(1:3 + 0.0)
  dim(y) <- c(1, 3)

  expect_snapshot(error = TRUE, vec_c(x, y))

  d <- structure(Sys.Date(), dim = 1)
  expect_equal(
    vec_rbind(data.frame(d), data.frame(d)),
    data.frame(d = structure(rep(Sys.Date(), 2), dim = 2))
  )
})

test_that("factor casts support shape", {
  x <- factor(c("x", "y", "z"))
  dim(x) <- c(3, 1)
  dimnames(x) <- list(c("r1", "r2", "r3"), "c1")

  y <- factor(c("w", "x", "y", "z"))
  dim(y) <- c(2, 2)

  exp <- factor(
    c("x", "y", "z", "x", "y", "z"),
    levels = c("w", "x", "y", "z")
  )
  dim(exp) <- c(3, 2)
  dimnames(exp) <- list(c("r1", "r2", "r3"), c("c1", "c1"))

  expect_equal(vec_cast(x, y), exp)

  x <- factor(c("x", "y", "z"))
  dim(x) <- c(3, 1)
  y <- factor(c("x", "y", "z"))
  expect_snapshot(error = TRUE, vec_cast(x, y))
})