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(vec_c(..., .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
}