tests/testthat/test-s2-cell.R

In s2: Spherical Geometry Operators Using the S2 Geometry Library

test_that("s2_cell class works", {
  expect_s3_class(new_s2_cell(double()), "s2_cell")
  expect_s3_class(new_s2_cell(NA_real_), "s2_cell")
  expect_true(is.na(new_s2_cell(NA_real_)))
  expect_identical(as_s2_cell(s2_cell()), s2_cell())
  expect_identical(
    as.list(new_s2_cell(NA_real_)),
    list(new_s2_cell(NA_real_))
  )
})

test_that("s2_cell bit64::integer64 support works", {
  cells <- c(as_s2_cell(NA_character_), s2_cell_sentinel())
  int64s <- bit64::as.integer64(cells)
  expect_identical(int64s, bit64::as.integer64(c(NA, -1)))
  expect_identical(as_s2_cell(int64s), cells)
})

test_that("invalid and sentinel values work as expected", {
  expect_false(s2_cell_is_valid(s2_cell_sentinel()))
  expect_false(s2_cell_is_valid(s2_cell_invalid()))
  expect_false(is.na(s2_cell_sentinel()))
  expect_false(is.na(s2_cell_invalid()))
  expect_true(s2_cell_sentinel() > s2_cell_invalid())
})

test_that("sort() and unique() work", {
  # temporary workaround for broken c() in wk
  expect_identical(
    unique(new_s2_cell(c(unclass(s2_cell_sentinel()), NA, 0, 0, unclass(s2_cell("5"))))),
    new_s2_cell(c(0, unclass(s2_cell("5")), NA, unclass(s2_cell_sentinel())))
  )

  expect_identical(
    sort(new_s2_cell(c(unclass(s2_cell_sentinel()), NA, 0, 0, unclass(s2_cell("5"))))),
    new_s2_cell(c(0, 0, unclass(s2_cell("5")), NA, unclass(s2_cell_sentinel())))
  )

  expect_identical(
    sort(
      new_s2_cell(c(unclass(s2_cell_sentinel()), NA, 0, 0, unclass(s2_cell("5")))),
      decreasing = TRUE
    ),
    rev(new_s2_cell(c(0, 0, unclass(s2_cell("5")), NA, unclass(s2_cell_sentinel()))))
  )
})

test_that("geography exporters work", {
  expect_identical(
    s2_as_text(s2_cell_center(as_s2_cell(s2_lnglat(c(-64, NA), c(45, NA)))), precision = 5),
    c("POINT (-64 45)", NA)
  )

  expect_identical(
    s2_as_text(s2_cell_polygon(as_s2_cell(s2_lnglat(c(-64, NA), c(45, NA)))), precision = 5),
    c("POLYGON ((-64 45, -64 45, -64 45, -64 45, -64 45))", NA)
  )

  expect_identical(
    s2_as_text(s2_cell_boundary(as_s2_cell(s2_lnglat(c(-64, NA), c(45, NA)))), precision = 5),
    c("LINESTRING (-64 45, -64 45, -64 45, -64 45, -64 45)", NA)
  )

  expect_equal(
    s2_x(s2_cell_vertex(s2_cell(c("5", "5", "5", NA)), k = c(0, 1, NA, 1))),
    c(45, 135, NA, NA)
  )
})

test_that("s2_cell_is_valid() works", {
  expect_identical(
    s2_cell_is_valid(new_s2_cell(double())),
    logical()
  )
  expect_identical(
    s2_cell_is_valid(new_s2_cell(NA_real_)),
    FALSE
  )
})

test_that("Ops, Math, and Summary errors for non-meaningful s2_cell() ops", {
  expect_error(s2_cell("X") + 1, "not meaningful")
  expect_error(abs(s2_cell("X")), "not meaningful")
  expect_error(all(s2_cell("X")), "not meaningful")
})

test_that("Ops, Math, and Summary ops work", {
  expect_identical(
    s2_cell(c("5", "5", "x", "x", "x", NA, NA)) ==
      s2_cell(c("5", "x", "5", "x", NA, "x", NA)),
    c(TRUE, FALSE, FALSE, TRUE, NA, NA, NA)
  )

  expect_identical(
    s2_cell(c("5", "5", "x", "x", "x", NA, NA)) !=
      s2_cell(c("5", "x", "5", "x", NA, "x", NA)),
    c(FALSE, TRUE, TRUE, FALSE, NA, NA, NA)
  )

  # 'invalid' is 0
  expect_identical(
    s2_cell(c("5", "5", "x", "x", "x", NA, NA)) >
      s2_cell(c("5", "x", "5", "x", NA, "x", NA)),
    c(FALSE, TRUE, FALSE, FALSE, NA, NA, NA)
  )

  expect_identical(
    s2_cell(c("5", "5", "x", "x", "x", NA, NA)) >=
      s2_cell(c("5", "x", "5", "x", NA, "x", NA)),
    c(TRUE, TRUE, FALSE, TRUE, NA, NA, NA)
  )

  expect_identical(
    s2_cell(c("5", "5", "x", "x", "x", NA, NA)) <
      s2_cell(c("5", "x", "5", "x", NA, "x", NA)),
    c(FALSE, FALSE, TRUE, FALSE, NA, NA, NA)
  )

  expect_identical(
    s2_cell(c("5", "5", "x", "x", "x", NA, NA)) <=
      s2_cell(c("5", "x", "5", "x", NA, "x", NA)),
    c(TRUE, FALSE, TRUE, TRUE, NA, NA, NA)
  )

  expect_identical(
    cummax(s2_cell(c("5", "x", "5", "x", NA, "x", NA))),
           s2_cell(c("5", "5", "5", "5", NA, NA, NA))
  )

  expect_identical(
    cummin(s2_cell(c("5", "x", "5", "x", NA, "x", NA))),
           s2_cell(c("5", "x", "x", "x", NA, NA, NA))
  )

  expect_identical(
    range(s2_cell(c("5", "x", "5", "x", NA, "x", NA)), na.rm = TRUE),
    s2_cell(c("X", "5"))
  )

  expect_identical(
    max(s2_cell(c("5", "x", "5", "x", NA, "x", NA)), na.rm = TRUE),
    s2_cell("5")
  )

  expect_identical(
    min(s2_cell(c("5", "x", "5", "x", NA, "x", NA)), na.rm = TRUE),
    s2_cell("X")
  )

  expect_identical(
    range(s2_cell(c("5", "x", "5", "x", NA, "x", NA))),
    s2_cell(c(NA_character_, NA_character_))
  )

  expect_identical(range(s2_cell()), s2_cell(c(NA_character_, NA_character_)))
  expect_identical(
    range(s2_cell(NA_character_), na.rm = TRUE),
    s2_cell(c(NA_character_, NA_character_))
  )
})

test_that("Binary ops are recycled at the C++ level", {
  expect_identical(s2_cell(rep("5", 2)) == s2_cell(rep("5", 2)), c(TRUE, TRUE))
  expect_identical(s2_cell(rep("5", 1)) == s2_cell(rep("5", 2)), c(TRUE, TRUE))
  expect_identical(s2_cell(rep("5", 2)) == s2_cell(rep("5", 1)), c(TRUE, TRUE))
  expect_error(s2_cell(rep("5", 2)) == s2_cell(rep("5", 0)), "Can't recycle")
})

test_that("s2_cell is not numeric", {
  expect_false(is.numeric(s2_cell()))
})

test_that("s2_cell subsetting and concatenation work", {
  cells <- new_s2_cell(c(NA_real_, NA_real_))
  expect_identical(cells[1], new_s2_cell(NA_real_))
  expect_identical(cells[[1]], cells[1])
  expect_identical(
    c(cells, cells),
    new_s2_cell(c(NA_real_, NA_real_, NA_real_, NA_real_))
  )
  expect_identical(
    rep(cells, 2),
    new_s2_cell(c(NA_real_, NA_real_, NA_real_, NA_real_))
  )
  expect_identical(
    rep_len(cells, 4),
    new_s2_cell(c(NA_real_, NA_real_, NA_real_, NA_real_))
  )
  expect_error(
    c(new_s2_cell(c(NA_real_, NA_real_)), 1:5),
    "Can't combine"
  )
})

test_that("s2_cell() can be created from s2_geography()", {
  expect_identical(
    as_s2_cell(as_s2_geography("POINT (-64 45)")),
    s2_cell("4b59a0cd83b5de49")
  )
})

test_that("s2_cell() can be created from s2_lnglat()", {
  expect_identical(
    as_s2_cell(s2_lnglat(-64, 45)),
    s2_cell("4b59a0cd83b5de49")
  )
})

test_that("s2_cell() can be created from s2_point()", {
  expect_identical(
    as_s2_cell(as_s2_point(s2_lnglat(-64, 45))),
    s2_cell("4b59a0cd83b5de49")
  )
})

test_that("s2_cell() can be created from character", {
  expect_identical(
    as_s2_cell("4b59a0cd83b5de49"),
    as_s2_cell(s2_lnglat(-64, 45))
  )
})

test_that("subset-assignment works", {
  x <- as_s2_cell(c(NA, "4b59a0cd83b5de49", "4b5f6a7856889a33"))
  expect_identical(as.character(x[3]), "4b5f6a7856889a33")
  x[3] <- "4b59a0cd83b5de49"
  expect_identical(as.character(x[3]), "4b59a0cd83b5de49")

  x[[3]] <- "4b5f6a7856889a33"
  expect_identical(as.character(x[3]), "4b5f6a7856889a33")
})

test_that("s2_cell can be put into a data.frame", {
  expect_identical(
    data.frame(geom = new_s2_cell(NA_real_)),
    new_data_frame(list(geom = new_s2_cell(NA_real_)))
  )
  expect_error(as.data.frame(new_s2_cell(NA_real_)), "cannot coerce")
})

test_that("s2_cell default format/print/str methods work", {
  expect_identical(
    format(s2_cell()),
    as.character(s2_cell())
  )
  expect_output(print(new_s2_cell(double())), "s2_cell")
  expect_output(print(new_s2_cell(NA_real_)), "s2_cell")

  expect_output(str(as_s2_cell(character())), "s2_cell\\[0\\]")
  expect_output(str(as_s2_cell(NA_character_)), "NA")
})

test_that("s2 cell exporters work", {
  expect_equal(
    as.data.frame(s2_cell_to_lnglat(s2_cell(c("4b59a0cd83b5de49", "x", NA)))),
    as.data.frame(c(s2_lnglat(-64, 45), s2_lnglat(NA, NA), s2_lnglat(NA, NA)))
  )

  expect_identical(
    s2_cell_debug_string(s2_cell(c("4b5f6a7856889a33", NA))),
    c("2/112233231103300223101010310121", NA)
  )
  expect_match(s2_cell_debug_string(s2_cell("X")), "Invalid")
})

test_that("s2_cell() accessors work", {
  expect_identical(
    s2_cell_is_valid(s2_cell(c("4b5f6a7856889a33", "5", "x", NA))),
    c(TRUE, TRUE, FALSE, FALSE)
  )

  expect_identical(
    s2_cell_level(s2_cell(c("4b5f6a7856889a33", "5", "x", NA))),
    c(30L, 0L, NA, NA)
  )

  expect_identical(
    s2_cell_is_leaf(s2_cell(c("4b5f6a7856889a33", "5", "x", NA))),
    c(TRUE, FALSE, NA, NA)
  )

  expect_identical(
    s2_cell_is_face(s2_cell(c("4b5f6a7856889a33", "5", "x", NA))),
    c(FALSE, TRUE, NA, NA)
  )

  expect_equal(
    s2_cell_area(s2_cell(c("5", "x", NA)), radius = 1),
    c(2 * pi / 3, NA, NA)
  )

  expect_equal(
    s2_cell_area_approx(s2_cell(c("5", "x", NA)), radius = 1),
    c(2 * pi / 3, NA, NA)
  )
})

test_that("s2_cell() transversers work", {
  expect_identical(
    s2_cell_parent(s2_cell(c("5", "4b5f6a7856889a33", "x", NA)), 0),
    s2_cell(c("5", "5", NA, NA))
  )

  leaf_manual <- function(x, children) {
    if (length(children) == 0) {
      x
    } else {
      leaf_manual(
        s2_cell_child(x, children[1]),
        children[-1]
      )
    }
  }

  # see output of s2_cell_debug_string()
  expect_identical(
    leaf_manual(
      s2_cell("5"),
      as.numeric(strsplit("112233231103300223101010310121", "")[[1]])
    ),
    s2_cell("4b5f6a7856889a33")
  )

  expect_identical(
    s2_cell_child(s2_cell(c("5", "5", "5", "x", NA)), c(-1, 4, NA, 0, 0)),
    s2_cell(as.character(c(NA, NA, NA, NA, NA)))
  )

  expect_identical(
    s2_cell_debug_string(s2_cell_edge_neighbour(s2_cell("5"), 0:3)),
    c("1/", "3/", "4/", "0/")
  )

  expect_identical(
    s2_cell_edge_neighbour(s2_cell(c("5", "5", "5", "x", NA)), c(-1, 4, NA, 0, 0)),
    s2_cell(as.character(c(NA, NA, NA, NA, NA)))
  )
})

test_that("s2_cell() binary operators work", {
  cell <- s2_cell("4b5f6a7856889a33")
  expect_true(s2_cell_contains(s2_cell_parent(cell), cell))
  expect_false(s2_cell_contains(cell, s2_cell_parent(cell)))
  expect_identical(s2_cell_contains(s2_cell_sentinel(), s2_cell_sentinel()), NA)

  expect_equal(
    s2_cell_distance(
      as_s2_cell(s2_lnglat(0, 90)),
      as_s2_cell(s2_lnglat(0, 0)),
      radius = 1
    ),
    pi / 2
  )

  expect_equal(
    s2_cell_max_distance(
      as_s2_cell(s2_lnglat(0, 90)),
      as_s2_cell(s2_lnglat(0, 0)),
      radius = 1
    ),
    pi / 2
  )

  f1 <- s2_cell_parent(as_s2_cell(s2_lnglat(0, 0)), 0)
  f2 <- s2_cell_parent(as_s2_cell(s2_lnglat(0, 90)), 0)
  expect_equal(s2_cell_distance(f1, f2), 0)
  expect_equal(s2_cell_max_distance(f1, f2, radius = 1), pi)
  expect_identical(s2_cell_max_distance(s2_cell_sentinel(), s2_cell_sentinel()), NA_real_)
  expect_identical(s2_cell_distance(s2_cell_sentinel(), s2_cell_sentinel()), NA_real_)

  expect_false(
    s2_cell_may_intersect(
      as_s2_cell(s2_lnglat(0, 90)),
      as_s2_cell(s2_lnglat(0, 0))
    )
  )

  expect_true(s2_cell_may_intersect(s2_cell_parent(cell), cell))
  expect_true(s2_cell_may_intersect(cell, s2_cell_parent(cell)))
  expect_identical(s2_cell_may_intersect(s2_cell_sentinel(), s2_cell_sentinel()), NA)
})

test_that("s2_cell_common_ancestor_level() works", {
  cell <- s2_cell_parent(s2_cell("4b5f6a7856889a33"), 10)
  children <- s2_cell_child(cell, 0:4)
  expect_identical(
    s2_cell_common_ancestor_level(children, cell),
    c(rep(10L, 4), NA),
  )

  expect_identical(s2_cell_common_ancestor_level_agg(s2_cell()), NA_integer_)
  expect_identical(
    s2_cell_common_ancestor_level_agg(
      as_s2_cell(as_s2_geography(c("POINT (0 0)", "POINT (180 0)")))
    ),
    -1L
  )

  expect_identical(
    s2_cell_common_ancestor_level_agg(children, na.rm = TRUE),
    10L
  )

  expect_identical(
    s2_cell_common_ancestor_level_agg(children, na.rm = FALSE),
    NA_integer_
  )
})