vctrs: Vector Helpers

test_that("ptype2 base methods are not inherited", {
  ptypes <- vec_remove(base_empty_types, c("null", "dataframe"))
  for (ptype in ptypes) {
    x <- new_vctr(ptype, class = "foobar", inherit_base_type = TRUE)
    expect_s3_class(vec_ptype2(x, x), "foobar")
    expect_error(vec_ptype2(x, ptype), class = "vctrs_error_incompatible_type")
    expect_error(vec_ptype2(ptype, x), class = "vctrs_error_incompatible_type")
  }
})

test_that("cast base methods are not inherited", {
  ptypes <- vec_remove(base_empty_types, c("null", "dataframe"))
  for (ptype in ptypes) {
    x <- new_vctr(ptype, class = "foobar", inherit_base_type = TRUE)
    expect_s3_class(vec_cast(ptype, x), "foobar")
    expect_error(vec_cast(x, ptype), class = "vctrs_error_incompatible_type")
  }
})

test_that("default cast allows objects with the same type", {
  x <- structure(1, class = c("foo", "double"))
  expect_equal(vec_cast(x, x), x)
})

# vec_shaped_ptype -------------------------------------------------------

test_that("array dimensions are preserved", {
  mat1 <- matrix(lgl(), nrow = 1, ncol = 1)
  mat2 <- matrix(lgl(), nrow = 2, ncol = 2)
  mat3 <- matrix(lgl(), nrow = 2, ncol = 3)

  expect_equal(vec_ptype2(mat1, mat1), matrix(lgl(), nrow = 0, ncol = 1))
  expect_equal(vec_ptype2(mat1, mat2), matrix(lgl(), nrow = 0, ncol = 2))
  expect_error(vec_ptype2(mat2, mat3), class = "vctrs_error_incompatible_type")
})

test_that("vec_shaped_ptype()", {
  int <- function(...) array(NA_integer_, c(...))

  expect_identical(vec_shaped_ptype(integer(), int(5), int(10)), new_shape(integer()))
  expect_identical(vec_shaped_ptype(integer(), int(5, 1), int(10, 1)), new_shape(integer(), 1))
  expect_identical(vec_shaped_ptype(integer(), int(5, 1, 2), int(10, 1, 2)), new_shape(integer(), 1:2))
})

test_that("vec_shaped_ptype() evaluates arg lazily", {
  expect_silent(vec_shaped_ptype(integer(), int(5), int(10), x_arg = print("oof")))
  expect_silent(vec_shaped_ptype(integer(), int(5), int(10), y_arg = print("oof")))
})

# vec_cast() --------------------------------------------------------------

# NULL

test_that("NULL is idempotent", {
  expect_equal(vec_cast(NULL, NULL), NULL)
  expect_equal(vec_cast(list(1:3), NULL), list(1:3))
})


# Logical

test_that("safe casts work as expected", {
  exp <- lgl(TRUE, FALSE)
  expect_equal(vec_cast(NULL, logical()), NULL)
  expect_equal(vec_cast(lgl(TRUE, FALSE), logical()), exp)
  expect_equal(vec_cast(int(1L, 0L), logical()), exp)
  expect_equal(vec_cast(dbl(1, 0), logical()), exp)

  # These used to be allowed
  expect_error(vec_cast(chr("T", "F"), logical()), class = "vctrs_error_incompatible_type")
  expect_error(vec_cast(chr("TRUE", "FALSE"), logical()), class = "vctrs_error_incompatible_type")
  expect_error(vec_cast(chr("true", "false"), logical()), class = "vctrs_error_incompatible_type")
  expect_error(vec_cast(list(1, 0), logical()), class = "vctrs_error_incompatible_type")
})

test_that("NA casts work as expected", {
  exp <- lgl(NA)
  to <- lgl()

  expect_equal(vec_cast(lgl(NA), to), exp)
  expect_equal(vec_cast(int(NA), to), exp)
  expect_equal(vec_cast(dbl(NA), to), exp)

  # These used to be allowed
  expect_error(vec_cast(chr(NA), to), class = "vctrs_error_incompatible_type")
  expect_error(vec_cast(list(NA), to), class = "vctrs_error_incompatible_type")
})

test_that("Shaped NA casts work as expected", {
  mat <- matrix
  exp_mat <- mat(lgl(NA))
  to_mat <- matrix(lgl())

  expect_equal(vec_cast(mat(lgl(NA)), to_mat), exp_mat)
  expect_equal(vec_cast(mat(int(NA)), to_mat), exp_mat)
  expect_equal(vec_cast(mat(dbl(NA)), to_mat), exp_mat)

  # These used to be allowed
  expect_error(vec_cast(mat(chr(NA)), to_mat), class = "vctrs_error_incompatible_type")
  expect_error(vec_cast(mat(list(NA)), to_mat), class = "vctrs_error_incompatible_type")
})

test_that("lossy casts generate warning", {
  expect_lossy(vec_cast(int(2L, 1L), lgl()), lgl(TRUE, TRUE), x = int(),  to = lgl())
  expect_lossy(vec_cast(dbl(2, 1), lgl()), lgl(TRUE, TRUE), x = dbl(),  to = lgl())

  # These used to be allowed
  expect_error(vec_cast(chr("x", "TRUE"), lgl()), class = "vctrs_error_incompatible_type")
  expect_error(vec_cast(chr("t", "T"), lgl()), class = "vctrs_error_incompatible_type")
  expect_error(vec_cast(chr("f", "F"), lgl()), class = "vctrs_error_incompatible_type")
  expect_error(vec_cast(list(c(TRUE, FALSE), TRUE), lgl()), class = "vctrs_error_incompatible_type")
})

test_that("invalid casts generate error", {
  expect_error(vec_cast(factor("a"), logical()), class = "vctrs_error_incompatible_type")
})

test_that("dimensionality matches output" ,{
  x1 <- matrix(TRUE, nrow = 1, ncol = 1)
  x2 <- matrix(1, nrow = 0, ncol = 2)
  expect_dim(vec_cast(x1, x2), c(1, 2))
  expect_dim(vec_cast(TRUE, x2), c(1, 2))

  x <- matrix(1, nrow = 2, ncol = 2)
  expect_error(vec_cast(x, logical()), class = "vctrs_error_incompatible_type")
})

test_that("the common type of two `NA` vectors is unspecified", {
  expect_equal(vec_ptype2(NA, NA), unspecified())
})


# Integer

test_that("safe casts work as expected", {
  expect_equal(vec_cast(NULL, integer()), NULL)
  expect_equal(vec_cast(lgl(TRUE, FALSE), integer()), int(1L, 0L))
  expect_equal(vec_cast(int(1L, 2L), integer()), int(1L, 2L))
  expect_equal(vec_cast(dbl(1, 2), integer()), int(1L, 2L))

  # These used to be allowed
  expect_error(vec_cast(chr("1", "2"), integer()), class = "vctrs_error_incompatible_type")
  expect_error(vec_cast(list(1L, 2L), integer()), class = "vctrs_error_incompatible_type")
})

test_that("NA casts work as expected", {
  exp <- int(NA)
  to <- int()

  expect_equal(vec_cast(lgl(NA), to), exp)
  expect_equal(vec_cast(int(NA), to), exp)
  expect_equal(vec_cast(dbl(NA), to), exp)

  # These used to be allowed
  expect_error(vec_cast(chr(NA), to), class = "vctrs_error_incompatible_type")
  expect_error(vec_cast(list(NA), to), class = "vctrs_error_incompatible_type")
})

test_that("Shaped NA casts work as expected", {
  mat <- matrix
  exp_mat <- mat(int(NA))
  to_mat <- matrix(int())

  expect_equal(vec_cast(mat(lgl(NA)), to_mat), exp_mat)
  expect_equal(vec_cast(mat(int(NA)), to_mat), exp_mat)
  expect_equal(vec_cast(mat(dbl(NA)), to_mat), exp_mat)

  # These used to be allowed
  expect_error(vec_cast(mat(chr(NA)), to_mat), class = "vctrs_error_incompatible_type")
  expect_error(vec_cast(mat(list(NA)), to_mat), class = "vctrs_error_incompatible_type")
})

test_that("lossy casts generate error", {
  expect_lossy(vec_cast(c(2.5, 2), int()),     int(2, 2), x = dbl(), to = int())
  expect_lossy(vec_cast(c(.Machine$integer.max + 1, 1), int()),  int(NA, 1L), x = dbl(), to = int())
  expect_lossy(vec_cast(c(-.Machine$integer.max - 1, 1), int()), int(NA, 1L), x = dbl(), to = int())

  # These used to be allowed
  expect_error(vec_cast(c("2.5", "2"), int()), class = "vctrs_error_incompatible_type")
})

test_that("invalid casts generate error", {
  expect_error(vec_cast(factor("a"), integer()), class = "vctrs_error_incompatible_type")
})


# Double

test_that("safe casts work as expected", {
  expect_equal(vec_cast(NULL, double()), NULL)
  expect_equal(vec_cast(lgl(TRUE, FALSE), double()), dbl(1, 0))
  expect_equal(vec_cast(int(1, 0), double()), dbl(1, 0))
  expect_equal(vec_cast(dbl(1, 1.5), double()), dbl(1, 1.5))

  # These used to be allowed
  expect_error(vec_cast(chr("1", "1.5"), double()), class = "vctrs_error_incompatible_type")
  expect_error(vec_cast(list(1, 1.5), double()), class = "vctrs_error_incompatible_type")
})

test_that("NA casts work as expected", {
  exp <- dbl(NA)
  to <- dbl()

  expect_equal(vec_cast(lgl(NA), to), exp)
  expect_equal(vec_cast(int(NA), to), exp)
  expect_equal(vec_cast(dbl(NA), to), exp)

  # These used to be allowed
  expect_error(vec_cast(chr(NA), to), class = "vctrs_error_incompatible_type")
  expect_error(vec_cast(list(NA), to), class = "vctrs_error_incompatible_type")
})

test_that("Shaped NA casts work as expected", {
  mat <- matrix
  exp_mat <- mat(dbl(NA))
  to_mat <- matrix(dbl())

  expect_equal(vec_cast(mat(lgl(NA)), to_mat), exp_mat)
  expect_equal(vec_cast(mat(int(NA)), to_mat), exp_mat)
  expect_equal(vec_cast(mat(dbl(NA)), to_mat), exp_mat)

  # These used to be allowed
  expect_error(vec_cast(mat(chr(NA)), to_mat), class = "vctrs_error_incompatible_type")
  expect_error(vec_cast(mat(list(NA)), to_mat), class = "vctrs_error_incompatible_type")
})

test_that("invalid casts generate error", {
  expect_error(vec_cast(factor("a"), double()), class = "vctrs_error_incompatible_type")
})


# Complex

test_that("safe casts to complex works", {
  expect_identical(vec_cast(NULL, cpl()), NULL)
  expect_identical(vec_cast(lgl(TRUE, FALSE), cpl()), cpl(1, 0))
  expect_identical(vec_cast(int(1, 0), cpl()), cpl(1, 0))
  expect_identical(vec_cast(dbl(1, 1.5), cpl()), cpl(1, 1.5))

  # This used to be allowed
  expect_error(vec_cast(list(1, 1.5), cpl()), class = "vctrs_error_incompatible_type")
})

test_that("NA casts work as expected", {
  # This goes through a special path for <unspecified>
  expect_equal(vec_cast(lgl(NA), cpl()), NA_complex_)

  # TODO: Use our own cast routines here?
  # It isn't great that this logical `NA` cast returns a different `NA`
  # than the one above with just `lgl(NA)` (which is seen as unspecified). i.e.
  # check the `Im()` slot between the two in R >=4.4.0. We can fix this with our
  # own cast routines rather than using `vec_coerce_bare()`.
  expect_type(vec_cast(lgl(NA, TRUE), cpl()), "complex")
  expect_identical(is.na(vec_cast(lgl(NA, TRUE), cpl())), c(TRUE, FALSE))

  # TODO: Use our own cast routines here?
  # `as.complex(NA/NA_real_/NA_integer_)` and `Rf_CoerceVector(NA/NA_real_/NA_integer_)`
  # have gone back and forth about what they return in the `Im()` slot. In some
  # R versions they return `0` and in others they return `NA_real_`.
  # https://stat.ethz.ch/pipermail/r-devel/2023-April/082545.html
  # https://stat.ethz.ch/pipermail/r-devel/2023-September/082864.html
  # expect_equal(vec_cast(int(NA), cpl()), NA_complex_)
  expect_type(vec_cast(int(NA), cpl()), "complex")
  expect_identical(is.na(vec_cast(int(NA), cpl())), TRUE)

  # expect_equal(vec_cast(dbl(NA), cpl()), NA_complex_)
  expect_type(vec_cast(dbl(NA), cpl()), "complex")
  expect_identical(is.na(vec_cast(dbl(NA), cpl())), TRUE)

  # This used to be allowed
  expect_error(vec_cast(list(NA), cpl()), class = "vctrs_error_incompatible_type")
})

test_that("Shaped NA casts work as expected", {
  mat <- matrix
  exp_mat <- mat(NA_complex_)
  to_mat <- matrix(cpl())

  # TODO: Use our own cast routines here?
  # `as.complex(NA/NA_real_/NA_integer_)` and `Rf_CoerceVector(NA/NA_real_/NA_integer_)`
  # have gone back and forth about what they return in the `Im()` slot. In some
  # R versions they return `0` and in others they return `NA_real_`.
  # https://stat.ethz.ch/pipermail/r-devel/2023-April/082545.html
  # https://stat.ethz.ch/pipermail/r-devel/2023-September/082864.html

  # expect_equal(vec_cast(mat(lgl(NA)), to_mat), exp_mat)
  expect_type(vec_cast(mat(lgl(NA)), to_mat), "complex")
  expect_identical(is.na(vec_cast(mat(lgl(NA)), to_mat)), matrix(TRUE))

  # expect_equal(vec_cast(mat(int(NA)), to_mat), exp_mat)
  expect_type(vec_cast(mat(int(NA)), to_mat), "complex")
  expect_identical(is.na(vec_cast(mat(int(NA)), to_mat)), matrix(TRUE))

  # expect_equal(vec_cast(mat(dbl(NA)), to_mat), exp_mat)
  expect_type(vec_cast(mat(dbl(NA)), to_mat), "complex")
  expect_identical(is.na(vec_cast(mat(dbl(NA)), to_mat)), matrix(TRUE))

  # This used to be allowed
  expect_error(vec_cast(mat(list(NA)), to_mat), class = "vctrs_error_incompatible_type")
})

test_that("complex is coercible to numeric types", {
  expect_identical(vec_ptype2(cpl(), NULL), cpl())
  expect_identical(vec_ptype2(NULL, cpl()), cpl())

  expect_identical(vec_ptype2(cpl(), int()), cpl())
  expect_identical(vec_ptype2(int(), cpl()), cpl())

  expect_identical(vec_ptype2(cpl(), dbl()), cpl())
  expect_identical(vec_ptype2(dbl(), cpl()), cpl())

  expect_identical(vec_ptype2(cpl(), cpl()), cpl())

  expect_identical(vec_c(0, 1i), cpl(0i, 1i))
})

test_that("complex is not coercible to logical", {
  expect_error(vec_ptype2(cpl(), lgl()), class = "vctrs_error_incompatible_type")
  expect_error(vec_ptype2(lgl(), cpl()), class = "vctrs_error_incompatible_type")
})


# Character

test_that("safe casts work as expected", {
  expect_equal(vec_cast(NULL, character()), NULL)
  expect_equal(vec_cast(NA, character()), NA_character_)

  # These used to be allowed
  expect_error(vec_cast(lgl(TRUE, FALSE), character()), class = "vctrs_error_incompatible_type")
  expect_error(vec_cast(list("x", "y"), character()), class = "vctrs_error_incompatible_type")
})

test_that("NA casts work as expected", {
  exp <- chr(NA)
  to <- chr()

  expect_equal(vec_cast(lgl(NA), to), exp)
  expect_equal(vec_cast(chr(NA), to), exp)

  # These used to be allowed
  expect_error(vec_cast(int(NA), to), class = "vctrs_error_incompatible_type")
  expect_error(vec_cast(dbl(NA), to), class = "vctrs_error_incompatible_type")
  expect_error(vec_cast(list(NA), to), class = "vctrs_error_incompatible_type")
})

test_that("Shaped NA casts work as expected", {
  mat <- matrix
  exp_mat <- mat(chr(NA))
  to_mat <- matrix(chr())

  expect_equal(vec_cast(mat(chr(NA)), to_mat), exp_mat)

  # These used to be allowed
  expect_error(vec_cast(mat(lgl(NA)), to_mat), class = "vctrs_error_incompatible_type")
  expect_error(vec_cast(mat(int(NA)), to_mat), class = "vctrs_error_incompatible_type")
  expect_error(vec_cast(mat(dbl(NA)), to_mat), class = "vctrs_error_incompatible_type")
  expect_error(vec_cast(mat(list(NA)), to_mat), class = "vctrs_error_incompatible_type")
})

test_that("difftime does not get special treatment", {
  dt1 <- as.difftime(600, units = "secs")
  # This used to be allowed
  expect_error(vec_cast(dt1, character()), class = "vctrs_error_incompatible_type")
})


# Raw

test_that("safe casts work as expected", {
  expect_equal(vec_cast(NULL, raw()), NULL)

  # This used to be allowed
  expect_error(vec_cast(list(raw(1)), raw()), class = "vctrs_error_incompatible_type")
})

test_that("invalid casts generate error", {
  expect_error(vec_cast(raw(1), double()), class = "vctrs_error_incompatible_type")
  expect_error(vec_cast(double(1), raw()), class = "vctrs_error_incompatible_type")
})

test_that("can sort raw", {
  x <- as.raw(c(3, 1, 2, 4))
  expect_identical(vec_order(x), int(2, 3, 1, 4))
  expect_identical(x[vec_order(x)], as.raw(1:4))
})

test_that("raw has informative type summaries", {
  expect_equal(vec_ptype_abbr(raw()), "raw")
  expect_equal(vec_ptype_full(raw()), "raw")
})

test_that("can provide common type with raw", {
  local_methods(
    vec_ptype2.raw.vctrs_foobar = function(...) "dispatched-left",
    vec_ptype2.vctrs_foobar = function(...) NULL,
    vec_ptype2.vctrs_foobar.raw = function(...) "dispatched-right"
  )
  expect_identical(vec_ptype2(raw(), foobar("")), "dispatched-left")
  expect_identical(vec_ptype2(foobar(""), raw()), "dispatched-right")
})


# Lists

test_that("safe casts work as expected", {
  expect_equal(vec_cast(NULL, list()), NULL)
  expect_equal(vec_cast(NA, list()), list(NULL))
  expect_equal(vec_cast(list(1L, 2L), list()), list(1L, 2L))

  # This used to be allowed
  expect_error(vec_cast(1:2, list()), class = "vctrs_error_incompatible_type")
})

test_that("dimensionality matches to" ,{
  x1 <- matrix(TRUE, nrow = 1, ncol = 1)
  x2 <- matrix(1L, nrow = 0, ncol = 2)
  expect_dim(vec_cast(x1, x2), c(1, 2))
  expect_dim(vec_cast(TRUE, x2), c(1, 2))
})

test_that("data frames are cast to list row wise (#639)", {
  x <- data.frame(x = 1:2, row.names = c("a", "b"))
  expect <- list(data.frame(x = 1L), data.frame(x = 2L))

  # This used to be allowed
  expect_error(vec_cast(x, list()), class = "vctrs_error_incompatible_type")
})

test_that("data frames can be cast to shaped lists", {
  to <- array(list(), dim = c(0, 2, 1))
  x <- data.frame(x = 1:2, y = 3:4)

  expect <- list(vec_slice(x, 1), vec_slice(x, 2))
  expect <- array(expect, dim = c(2, 2, 1))

  # This used to be allowed
  expect_error(vec_cast(x, to), class = "vctrs_error_incompatible_type")
})

test_that("Casting atomic `NA` values to list results in a `NULL`", {
  x <- c(NA, 1)
  expect <- list(NULL, 1)

  # This used to be allowed
  expect_error(vec_cast(x, list()), class = "vctrs_error_incompatible_type")
})

test_that("Casting data frame `NA` rows to list results in a `NULL`", {
  x <- data.frame(x = c(NA, NA, 1), y = c(NA, 1, 2))
  expect <- list(NULL, vec_slice(x, 2), vec_slice(x, 3))

  # This used to be allowed
  expect_error(vec_cast(x, list()), class = "vctrs_error_incompatible_type")
})


# Unspecified

test_that("unspecified can be cast to bare methods", {
  for (x in vectors[-4]) {
    expect_identical(vec_cast(unspecified(3), x), vec_init(x, 3))
  }
})