tests/testthat/test-wkb-writer.R

In wk: Lightweight Well-Known Geometry Parsing

test_that("wkb_writer() works", {
  wkb_good <- wk_handle(
    new_wk_wkt(
      c(
        "POINT (1 1)", "LINESTRING (1 1, 2 2)", "POLYGON ((0 0, 0 1, 1 0, 0 0))",
        "MULTIPOINT ((1 1))", "MULTILINESTRING ((1 1, 2 2), (2 2, 3 3))",
        "MULTIPOLYGON (((0 0, 0 1, 1 0, 0 0)), ((0 0, 0 -1, -1 0, 0 0)))",
        "GEOMETRYCOLLECTION (POINT (1 1), LINESTRING (1 1, 2 2))"
      )
    ),
    wkb_writer(endian = 1L)
  )

  expect_identical(
    wk_handle(wkb_good, wkb_writer(endian = 1L)),
    wkb_good
  )

  wkb_bad <- unclass(wkb_good[1])
  wkb_bad[[1]][3:4] <- as.raw(0xff)
  expect_error(wk_handle(new_wk_wkb(wkb_bad), wkb_writer()), "Unrecognized geometry type code")
})

test_that("wkb_writer() can generate swapped endian", {
  wkb_system <- wk_handle(wkt("LINESTRING (1 2, 3 4)"), wkb_writer(endian = NA))
  wkb_le <- wk_handle(wkt("LINESTRING (1 2, 3 4)"), wkb_writer(endian = 1))
  wkb_be <- wk_handle(wkt("LINESTRING (1 2, 3 4)"), wkb_writer(endian = 0))

  expect_identical(as_wkt(wkb_system), wkt("LINESTRING (1 2, 3 4)"))
  expect_identical(as_wkt(wkb_le), wkt("LINESTRING (1 2, 3 4)"))
  expect_identical(as_wkt(wkb_be), wkt("LINESTRING (1 2, 3 4)"))

  expect_false(identical(wkb_be, wkb_le))

  expect_identical(
    wkb_be,
    # dput(geos::geos_write_wkb("LINESTRING (1 2, 3 4)", endian = 0))
    structure(
      list(
        as.raw(
          c(0x00,
            0x00, 0x00, 0x00, 0x02,
            0x00, 0x00, 0x00, 0x02,
            0x3f, 0xf0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
            0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
            0x40, 0x08, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
            0x40, 0x10, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00
          )
        )
      ),
      class = c("wk_wkb", "wk_vctr")
    )
  )

  expect_identical(
    wkb_le,
    # dput(geos::geos_write_wkb("LINESTRING (1 2, 3 4)", endian = 1))
    structure(
      list(
        as.raw(
          c(0x01,
            0x02, 0x00, 0x00, 0x00,
            0x02, 0x00, 0x00, 0x00,
            0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xf0, 0x3f,
            0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x40,
            0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x08, 0x40,
            0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x10, 0x40
          )
        )
      ),
      class = c("wk_wkb", "wk_vctr")
    )
  )
})

test_that("wkb_writer() reallocates its buffer as needed", {
  expect_identical(
    wk_handle(wkt("POINT (1 2)"), wkb_writer(buffer_size = 0)),
    wk_handle(wkt("POINT (1 2)"), wkb_writer(buffer_size = 1024))
  )
})

test_that("wkb_writer() works with streaming input", {
  wkb_good <- as_wkb(
    c(
      "POINT (1 1)", "LINESTRING (1 1, 2 2)", "POLYGON ((0 0, 0 1, 1 0, 0 0))",
      "MULTIPOINT ((1 1))", "MULTILINESTRING ((1 1, 2 2), (2 2, 3 3))",
      "MULTIPOLYGON (((0 0, 0 1, 1 0, 0 0)), ((0 0, 0 -1, -1 0, 0 0)))",
      "GEOMETRYCOLLECTION (POINT (1 1), LINESTRING (1 1, 2 2))"
    )
  )

  expect_identical(
    wk_handle(as_wkt(wkb_good), wkb_writer()),
    wkb_good
  )
})

test_that("wkb_writer() errors when the recursion limit is too high", {
  make_really_recursive_geom <- function(n) {
    wkt(paste0(
      c(rep("GEOMETRYCOLLECTION (", n), "POLYGON ((0 1))", rep(")", n)),
      collapse = ""
    ))
  }

  # errors in geometry_start
  expect_error(
    wk_handle(make_really_recursive_geom(31), wkb_writer()),
    "Can't write WKB with maximum"
  )
  # errors in ring_start
  expect_error(
    wk_handle(make_really_recursive_geom(32), wkb_writer()),
    "Can't write WKB with maximum"
  )
})

test_that("wkb_writer() works for a vector of indeterminate length", {
  long_xy <- as_wkt(xy(runif(2048), runif(2048)))
  expect_identical(
    handle_wkt_without_vector_size(long_xy, wkb_writer()),
    wk_handle(long_xy, wkb_writer())
  )
})