tests/testthat/helper-vctrs.R

In vctrs: Vector Helpers

testthat_import_from <- function(ns, names, env = caller_env()) {
  skip_if_not_installed(ns)
  import_from(ns, names, env = env)
}

shaped_int <- function(...) {
  array(NA_integer_, c(...))
}

set_rownames_recursively <- function(x, i = NULL) {
  n <- vec_size(x)
  stopifnot(n <= length(letters))

  for (j in seq_along(x)) {
    if (is.data.frame(x[[j]])) {
      x[[j]] <- set_rownames_recursively(x[[j]], i = i)
    }
  }

  row.names(x) <- paste0(letters[seq_len(n)], i)
  x
}

expect_waldo_equal <- function(type, act, exp, info, ...) {
  comp <- waldo::compare(act$val, exp$val, ..., x_arg = "actual", y_arg = "expected")
  expect(
    length(comp) == 0,
    sprintf(
      "`actual` (%s) not %s to `expected` (%s).\n\n%s",
      act$lab, type, exp$lab, paste0(comp, collapse = "\n\n")
    ),
    info = info
  )

  invisible(act$val)
}

expect_identical <- function(object, expected, info = NULL, label = NULL,
                             expected.label = NULL, ...) {
  act <- quasi_label(enquo(object), label, arg = "object")
  exp <- quasi_label(enquo(expected), expected.label, arg = "expected")

  expect_waldo_equal("identical", act, exp, info, ...)
}

expect_equal <- function(object, expected, ...,
                         tolerance = .Machine$double.eps ^ 0.5,
                         info = NULL, label = NULL,
                         expected.label = NULL) {
  act <- quasi_label(enquo(object), label, arg = "object")
  exp <- quasi_label(enquo(expected), expected.label, arg = "expected")

  expect_waldo_equal("equal", act, exp, info, ..., tolerance = tolerance)
}

raw2 <- function(...) {
  as.raw(list_unchop(list2(...), ptype = integer()))
}
cpl2 <- function(...) {
  # R 4.4.0 changed `as.complex(NA_real/integer/logical)` so that it always uses
  # a `0` in the imaginary slot. While this is reasonable, it is annoying for
  # comparison purposes in tests, where we typically propagate the `NA`. As of
  # rlang 1.1.1, `cpl()` inherits this behavior change so we have a custom version
  # here that works the same on all R versions.
  # https://github.com/wch/r-source/commit/1a2aea9ac3c216fea718f33f712764afc34f6ee8
  out <- list2(...)
  out <- as.complex(out)
  out[is.na(out)] <- complex(real = NA_real_, imaginary = NA_real_)
  out
}