tests/testthat/test-base-compat.R

In a5R: 'A5' Discrete Global Grid System

set.seed(11)
n <- 5000L
x <- a5_lonlat_to_cell(runif(n, -180, 180), runif(n, -85, 85), resolution = 12)
y <- x[sample(n)]
a <- x[1:3]
b <- x[4:6]

test_that("match and %in% agree with vctrs, including NA", {
  expect_identical(match(x, y), vctrs::vec_match(x, y))
  expect_identical(x %in% y, vctrs::vec_in(x, y))
  xna <- c(a, a5_cell(NA), b)
  yna <- c(a5_cell(NA), b[2])
  expect_identical(match(xna, yna), vctrs::vec_match(xna, yna))
  expect_identical(match(a, b), rep(NA_integer_, 3))
  expect_identical(unique(c(a, a)), a)
})

test_that("mtfrm key is exact and distinct for distinct cells", {
  k <- mtfrm(x)
  expect_type(k, "complex")
  expect_identical(anyDuplicated(k) > 0, anyDuplicated(as.character(x)) > 0)
  expect_identical(vctrs::vec_unique_count(k), vctrs::vec_unique_count(x))
})

test_that("assignment past the end grows with NA", {
  z <- a
  z[5] <- b[1]
  expect_length(z, 5L)
  expect_true(is.na(z[4]))
  expect_identical(z[5], b[1])
  z <- a
  z[length(z) + 1] <- b[2]
  expect_identical(z, c(a, b[2]))
  # In-range assignment is still type checked by vctrs.
  expect_error(z[2] <- "not a cell")
  # Hex strings are still cast in range.
  z[2] <- as.character(b[3])
  expect_identical(z[2], b[3])
})

test_that("length<- grows with NA and shrinks", {
  z <- a
  length(z) <- 5
  expect_length(z, 5L)
  expect_true(all(is.na(z[4:5])))
  expect_identical(z[1:3], a)
  length(z) <- 2
  expect_identical(z, a[1:2])
})

test_that("rbind on data frames with a5_cell columns matches vec_rbind", {
  d1 <- data.frame(cell = a, v = 1:3)
  d2 <- data.frame(cell = b, v = 4:6)
  expect_identical(rbind(d1, d2), vctrs::vec_rbind(d1, d2))
  expect_identical(rbind(d1, d2)$cell, c(a, b))
})

test_that("as_a5_cell_list wraps plain lists so unlist works", {
  plain <- lapply(1:3, function(i) a5_cell_to_children(a[i]))
  expect_type(unlist(plain), "raw")  # the base behaviour being worked around
  lst <- as_a5_cell_list(plain)
  expect_s3_class(lst, "a5_cell_list")
  expect_identical(unlist(lst), a5_cell_to_children(a))
  expect_identical(as_a5_cell_list(lst), lst)
  mixed <- as_a5_cell_list(list(a, as.character(b), NULL))
  expect_identical(lengths(mixed), c(3L, 3L, 0L))
  expect_identical(unlist(mixed), c(a, b))
  expect_error(as_a5_cell_list(a), "list")
})

test_that("split of cells by a factor works; grouping by cells needs vctrs", {
  s <- split(a, c("p", "q", "p"))
  expect_identical(s$p, a[c(1, 3)])
  # split(x, cells) sees the record's fields, so use vec_split()
  g <- c(a[1], a[2], a[1])
  expect_identical(vctrs::vec_split(1:3, g)$val, list(c(1L, 3L), 2L))
})

# -- gaps filled by vctrs are NA, not the world cell (#27) --------------------

test_that("every gap-filling path gives NA", {
  x <- a5_lonlat_to_cell(-3.19, 55.95, 10)
  expect_identical(is.na(c(x, NA)), c(FALSE, TRUE))
  expect_identical(is.na(vctrs::vec_c(x, NA)), c(FALSE, TRUE))
  expect_identical(is.na(x[c(1, NA)]), c(FALSE, TRUE))
  expect_identical(is.na(vctrs::vec_slice(x, c(1L, NA))), c(FALSE, TRUE))
  expect_true(all(is.na(vctrs::vec_init(x, 3))))
  y <- c(x, x)
  y[2] <- NA
  expect_identical(is.na(y), c(FALSE, TRUE))

  df <- data.frame(id = 1:2)
  df$cell <- c(x, x)
  joined <- merge(df, data.frame(id = 3), all = TRUE)
  expect_identical(is.na(joined$cell), c(FALSE, FALSE, TRUE))
  bound <- vctrs::vec_rbind(data.frame(a = 1, cell = x), data.frame(a = 2))
  expect_identical(is.na(bound$cell), c(FALSE, TRUE))
})

test_that("gap NAs behave like any other NA", {
  x <- a5_lonlat_to_cell(-3.19, 55.95, 10)
  filled <- c(x, NA)
  expect_identical(format(filled)[2], NA_character_)
  expect_identical(filled[2], a5_cell(NA_character_))
  expect_identical(unique(c(x, NA, x, NA)), filled)
  expect_true(is.na(a5_get_resolution(filled)[2]))
})

test_that("resolution-30 cells whose top byte is 0xFC are not NA", {
  # Resolution 30 keeps only 5, 3 or 1 quintant bits at the top, so valid
  # cells in quintants 31, 39 and 41 can start with 0xFC.
  cell <- a5_cell("fc9529c9c837d6e7")
  expect_false(is.na(cell))
  expect_identical(a5_get_resolution(cell), 30L)
  ll <- a5_cell_to_lonlat(cell, as_dataframe = TRUE)
  expect_false(is.na(ll$lon))
  back <- a5_lonlat_to_cell(ll$lon, ll$lat, resolution = 30)
  expect_identical(format(back), "fc9529c9c837d6e7")
  expect_false(is.na(back))
})

test_that("ordering follows true id order across the b8 encoding", {
  hex <- c("fc9529c9c837d6e7", "0000000000000000", "0800000000000006",
           "6344be8000000000", "f400000000000000")
  cells <- a5_cell(hex)
  expect_identical(format(sort(cells)), sort(hex))
  expect_identical(order(cells), order(hex))
  expect_true(cells[3] < cells[1])
})