vctrs: Vector Helpers

test_that("inputs must be vectors", {
  expect_error(vec_compare(NULL, 1), class = "vctrs_error_scalar_type")
  expect_error(vec_compare(1, NULL), class = "vctrs_error_scalar_type")
})

test_that("matches R ordering", {
  expect_same <- function(x, y) {
    expect_equal(vec_compare(!!x, !!y), cmp(!!x, !!y))
  }

  expect_same(c(NA, FALSE, TRUE), FALSE)
  expect_same(c(NA, -100L, 0L, 100L), 0L)
  expect_same(c(NA, -Inf, -100, 100, Inf), 0L)
  expect_same(c(NA, NaN, 0), NA)
  expect_same(c(NA, "a", "b", "c"), "b")
  expect_same(as.raw(2:5), as.raw(4))
})

test_that("NAs equal when requested", {
  expect_value <- function(x, y, val, .ptype = NULL) {
    expect_equal(vec_compare(!!x, !!y, .ptype = .ptype, na_equal = TRUE), !!val)
  }

  expect_value(NA, NA, 0L)
  expect_value(NA, FALSE, -1L)
  expect_value(FALSE, NA, 1L)

  expect_value(NA_integer_, NA_integer_, 0L)
  expect_value(NA_integer_, 0L, -1L)
  expect_value(0L, NA_integer_, 1L)

  expect_value(NA_character_, NA_character_, 0L)
  expect_value(NA_character_, "", -1L)
  expect_value("", NA_character_, 1L)

  expect_value(0, NA_real_, 1L)
  expect_value(0, NaN, 1L)
  expect_value(0, 0, 0L)
  expect_value(NA_real_, NA_real_, 0L)
  expect_value(NA_real_, NaN, 1L)
  expect_value(NA_real_, 0, -1L)
  expect_value(NaN, NA_real_, -1L)
  expect_value(NaN, NaN, 0L)
  expect_value(NaN, 0, -1L)
})

test_that("data frames are compared column by column", {
  df1 <- data.frame(x = c(1, 1, 1), y = c(-1, 0, 1))

  expect_equal(vec_compare(df1, df1[2, ]), c(-1, 0, 1))
  expect_equal(vec_compare(df1[1], df1[2, 1, drop = FALSE]), c(0, 0, 0))
  expect_equal(vec_compare(df1[2], df1[2, 2, drop = FALSE]), c(-1, 0, 1))
  expect_equal(vec_compare(df1[2:1], df1[2, 2:1]), c(-1, 0, 1))
})

test_that("can compare data frames with various types of columns", {
  x1 <- data_frame(x = 1, y = 2)
  y1 <- data_frame(x = 2, y = 1)

  x2 <- data_frame(x = "a")
  y2 <- data_frame(x = "b")

  x3 <- data_frame(x = FALSE)
  y3 <- data_frame(x = TRUE)

  x4 <- data_frame(x = 1L)
  y4 <- data_frame(x = 2L)

  expect_equal(vec_compare(x1, y1), -1)
  expect_equal(vec_compare(x2, y2), -1)
  expect_equal(vec_compare(x3, y3), -1)
  expect_equal(vec_compare(x4, y4), -1)
})

test_that("can compare data frames with data frame columns", {
  df1 <- data_frame(x = data_frame(a = 1))
  df2 <- data_frame(x = data_frame(a = 2))

  expect_equal(vec_compare(df1, df1), 0)
  expect_equal(vec_compare(df1, df2), -1)
})

test_that("can compare data frames with 0 columns", {
  x <- new_data_frame(n = 2L)
  expect_identical(vec_compare(x, x), c(0L, 0L))
})

test_that("C code doesn't crash with bad inputs", {
  df <- data.frame(x = c(1, 1, 1), y = c(-1, 0, 1))

  expect_error(.Call(ffi_vec_compare, df, df[1], TRUE), "not comparable")

  # Names are not checked, as `vec_cast_common()` should take care of the type.
  # So if `vec_cast_common()` is not called, or is improperly specified, then
  # this could result in false equality.
  expect_equal(.Call(ffi_vec_compare, df, setNames(df, c("x", "z")), TRUE), c(0, 0, 0))

  df1 <- new_data_frame(list(x = 1:3, y = c(1, 1, 1)))
  df2 <- new_data_frame(list(y = 1:2, x = 1:2))
  expect_error(.Call(ffi_vec_compare, df1, df2, TRUE), "must have the same types and lengths")
})

test_that("xtfrm.vctrs_vctr works for variety of base classes", {
  df <- data.frame(x = c(NA, 1, 1), y = c(1, 2, 1))
  # Internally uses `vec_rank()`, which propagates rows if not "complete"
  expect_equal(xtfrm.vctrs_vctr(df), c(NA, 2, 1))

  x <- c(2, 3, 1)
  expect_equal(xtfrm.vctrs_vctr(x), x)
  expect_equal(xtfrm.vctrs_vctr(letters[x]), x)
})

test_that("vec_proxy_order() orders list using order of appearance", {
  x <- 1:2
  y <- 2:4
  z <- "a"

  lst <- list(x, y, x, y, z)

  expect_identical(vec_proxy_order(lst), c(1L, 2L, 1L, 2L, 5L))
})

test_that("vec_compare() calls vec_proxy_compare()", {
  local_methods(
    vec_proxy_compare.vctrs_foobar = function(x, ...) rev(x),
    vec_ptype2.integer.vctrs_foobar = function(...) foobar(int()),
    vec_ptype2.vctrs_foobar = function(...) foobar(int()),
    vec_cast.vctrs_foobar = function(...) NULL,
    vec_cast.vctrs_foobar.integer = function(x, ...) x,
  )
  expect_identical(vec_compare(1:3, 1:3), int(0, 0, 0))
  expect_identical(vec_compare(1:3, foobar(1:3)), int(-1, 0, 1))
})

test_that("vec_proxy_compare() preserves data frames and vectors", {
  df <- data_frame(x = 1:2, y = c("a", "b"))
  expect_identical(vec_proxy_compare(df), df)

  x <- c(NA, "a", "b", "c")
  expect_identical(vec_proxy_compare(x), x)
})

test_that("vec_proxy_compare() handles data frame with a POSIXlt column", {
  df <- data.frame(times = 1:5, x = 1:5)
  df$times <- as.POSIXlt(seq.Date(as.Date("2019-12-30"), as.Date("2020-01-03"), by = "day"))

  df2 <- df
  df2$times <- vec_proxy_compare(df$times)

  expect_identical(
    vec_proxy_compare(df),
    vec_proxy_compare(df2)
  )
})

test_that("vec_proxy_compare.POSIXlt() correctly orders (#720)", {
  dates <- as.POSIXlt(seq.Date(as.Date("2019-12-30"), as.Date("2020-01-03"), by = "day"))
  expect_equal(vec_order(dates), 1:5)
})

test_that("vec_proxy_compare.POSIXlt() correctly orders around DST", {
  # 1am in EDT
  x <- as.POSIXlt("2020-11-01 01:00:00", tz = "America/New_York")

  # "falls back" to 1am again, but in EST
  y <- as.POSIXlt(x + 3600)

  expect_equal(vec_order(c(y, x)), c(2, 1))
})

test_that("vec_proxy_compare() flattens df-cols", {
  df_col <- data_frame(z = 3:4, w = 4:5)
  df <- data_frame(x = 1:2, y = df_col)

  expect <- data_frame(x = 1:2, z = 3:4, w = 4:5)

  expect_identical(vec_proxy_compare(df), expect)
})

test_that("vec_proxy_compare() unwraps 1 col dfs", {
  df <- data_frame(x = 1:2)

  expect_identical(vec_proxy_compare(df), 1:2)

  df_col <- data_frame(y = 1:2)
  df <- data_frame(x = df_col)

  expect_identical(vec_proxy_compare(df), 1:2)
})

test_that("vec_proxy_order() works on deeply nested lists", {
  df_col <- data_frame(z = list("b", "a", "b"))

  # Relaxed and unwrapped
  df1 <- data_frame(x = df_col)
  expect_identical(vec_proxy_order(df1), c(1L, 2L, 1L))

  df2 <- data_frame(x = df_col, y = 1:3)
  expect_identical(vec_proxy_order(df2), data_frame(x = c(1L, 2L, 1L), y = 1:3))
})

test_that("error is thrown when comparing complexes (#1655)", {
  expect_snapshot({
    (expect_error(vec_compare(complex(), complex())))
  })
})

test_that("error is thrown when comparing lists", {
  expect_error(vec_compare(list(), list()), class = "vctrs_error_unsupported")
  expect_error(.Call(ffi_vec_compare, list(), list(), FALSE), "Can't compare lists")
})

test_that("error is thrown when comparing data frames with list columns", {
  df <- data_frame(x = list())
  expect_error(vec_compare(df, df), class = "vctrs_error_unsupported")
  expect_error(.Call(ffi_vec_compare, df, df, FALSE), "Can't compare lists")
})

test_that("error is thrown when comparing scalars", {
  x <- new_sclr(x = 1)
  expect_error(vec_compare(x, x), class = "vctrs_error_scalar_type")
  expect_error(.Call(ffi_vec_compare, x, x, FALSE), class = "vctrs_error_scalar_type")
})

test_that("`na_equal` is validated", {
  expect_snapshot({
    (expect_error(vec_compare(1, 1, na_equal = 1)))
    (expect_error(vec_compare(1, 1, na_equal = c(TRUE, FALSE))))
  })
})

test_that("can compare equal strings with different encodings", {
  for (x_encoding in encodings()) {
    for (y_encoding in encodings()) {
      expect_equal(vec_compare(x_encoding, y_encoding), 0L)
    }
  }
})

test_that("can compare non-equal strings with different encodings", {
  x <- "x"
  y <- encodings()$latin1

  expect_equal(vec_compare(x, y), -1L)
})

test_that("comparison can be determined when strings have identical encodings", {
  encs <- encodings()

  for (enc in encs) {
    expect_equal(vec_compare(enc, enc), 0L)
  }
})

test_that("comparison is known to always fail with bytes", {
  enc <- encoding_bytes()
  error <- "translating strings with \"bytes\" encoding"
  expect_error(vec_compare(enc, enc), error)
})

test_that("comparison is known to fail when comparing bytes to other encodings", {
  error <- "translating strings with \"bytes\" encoding"

  for (enc in encodings()) {
    expect_error(vec_compare(encoding_bytes(), enc), error)
    expect_error(vec_compare(enc, encoding_bytes()), error)
  }
})

test_that("can compare unspecified", {
  expect_equal(vec_compare(NA, NA), NA_integer_)
  expect_equal(vec_compare(NA, NA, na_equal = TRUE), 0)
  expect_equal(vec_compare(c(NA, NA), unspecified(2)), c(NA_integer_, NA_integer_))
})

test_that("can't supply NA as `na_equal`", {
  expect_snapshot(error = TRUE, {
    vec_compare(NA, NA, na_equal = NA)
  })
})

test_that("vec_compare() silently falls back to base data frame", {
  expect_silent(expect_identical(
    vec_compare(foobar(mtcars), foobar(tibble::as_tibble(mtcars))),
    rep(0L, 32)
  ))
})