tests/testthat/test-pkg-wk.R

In paleolimbot/geoarrow: Extension Types for Spatial Data for Use with 'Arrow'

test_that("as_geoarrow_array.wkt() generates the correct buffers", {
  array <- as_geoarrow_array(wk::wkt(c("POINT (0 1)", NA)))
  schema <- infer_nanoarrow_schema(array)

  expect_identical(schema$format, "u")
  expect_identical(schema$metadata[["ARROW:extension:name"]], "geoarrow.wkt")

  expect_identical(
    as.raw(array$buffers[[1]]),
    as.raw(nanoarrow::as_nanoarrow_array(c(TRUE, rep(FALSE, 7)))$buffers[[2]])
  )

  expect_identical(
    as.raw(array$buffers[[2]]),
    as.raw(nanoarrow::as_nanoarrow_buffer(c(0L, 11L, 11L)))
  )

  expect_identical(
    as.raw(array$buffers[[3]]),
    as.raw(nanoarrow::as_nanoarrow_buffer("POINT (0 1)"))
  )
})

test_that("as_geoarrow_array.wkt() falls back to default method for non-geoarrow.wkt", {
  array <- as_geoarrow_array(wk::wkt(c("POINT (0 1)", NA)), schema = na_extension_wkb())
  schema <- infer_nanoarrow_schema(array)

  expect_identical(schema$format, "z")
  expect_identical(schema$metadata[["ARROW:extension:name"]], "geoarrow.wkb")
})

test_that("as_geoarrow_array() for wkt() respects schema", {
  skip_if_not_installed("arrow")

  array <- as_geoarrow_array(
    wk::wkt(c("POINT (0 1)")),
    schema = na_extension_large_wkt()
  )
  schema <- infer_nanoarrow_schema(array)
  expect_identical(schema$format, "U")
})

test_that("as_geoarrow_array.wkb() generates the correct buffers for geoarrow.wkb", {
  array <- as_geoarrow_array(wk::as_wkb(c("POINT (0 1)", NA)))
  schema <- infer_nanoarrow_schema(array)

  expect_identical(schema$format, "z")
  expect_identical(schema$metadata[["ARROW:extension:name"]], "geoarrow.wkb")

  expect_identical(
    as.raw(array$buffers[[1]]),
    as.raw(nanoarrow::as_nanoarrow_array(c(TRUE, rep(FALSE, 7)))$buffers[[2]])
  )

  expect_identical(
    as.raw(array$buffers[[2]]),
    as.raw(nanoarrow::as_nanoarrow_buffer(c(0L, 21L, 21L)))
  )
})

test_that("as_geoarrow_array.wkb() falls back to default method for non-geoarrow.wkb", {
  array <- as_geoarrow_array(
    wk::as_wkb(c("POINT (0 1)", NA)),
    schema = na_extension_wkt()
  )
  schema <- infer_nanoarrow_schema(array)

  expect_identical(schema$format, "u")
  expect_identical(schema$metadata[["ARROW:extension:name"]], "geoarrow.wkt")
})

test_that("as_geoarrow_array() for wkb() respects schema", {
  skip_if_not_installed("arrow")

  array <- as_geoarrow_array(
    wk::as_wkb(c("POINT (0 1)")),
    schema = na_extension_large_wkb()
  )
  schema <- infer_nanoarrow_schema(array)
  expect_identical(schema$format, "Z")
})

test_that("as_geoarrow_array.wk_xy() generates the correct buffers", {
  array <- as_geoarrow_array(wk::xy(1:5, 6:10))
  schema <- infer_nanoarrow_schema(array)

  expect_identical(schema$format, "+s")
  expect_identical(schema$metadata[["ARROW:extension:name"]], "geoarrow.point")

  expect_identical(
    as.raw(array$children[[1]]$buffers[[2]]),
    as.raw(nanoarrow::as_nanoarrow_buffer(as.double(1:5)))
  )

  expect_identical(
    as.raw(array$children[[2]]$buffers[[2]]),
    as.raw(nanoarrow::as_nanoarrow_buffer(as.double(6:10)))
  )
})

test_that("as_geoarrow_arrayx.xy() falls back to default method for non-geoarrow.point", {
  array <- as_geoarrow_array(wk::xy(1:5, 6:10), schema = na_extension_wkt())
  schema <- infer_nanoarrow_schema(array)

  expect_identical(schema$format, "u")
  expect_identical(schema$metadata[["ARROW:extension:name"]], "geoarrow.wkt")
})

test_that("as_geoarrow_array() for wk generates the correct metadata", {
  array <- as_geoarrow_array(wk::wkt(c("POINT (0 1)", NA)))
  schema <- infer_nanoarrow_schema(array)
  expect_identical(schema$format, "u")
  expect_identical(schema$metadata[["ARROW:extension:name"]], "geoarrow.wkt")
  expect_identical(schema$metadata[["ARROW:extension:metadata"]], "{}")

  array <- as_geoarrow_array(wk::wkt(c("POINT (0 1)", NA), crs = "OGC:CRS84"))
  schema <- infer_nanoarrow_schema(array)
  expect_identical(schema$format, "u")
  expect_identical(schema$metadata[["ARROW:extension:name"]], "geoarrow.wkt")
  expect_identical(
    schema$metadata[["ARROW:extension:metadata"]],
    sprintf('{"crs":%s}', wk::wk_crs_projjson("OGC:CRS84"))
  )

  array <- as_geoarrow_array(wk::wkt(c("POINT (0 1)", NA), geodesic = TRUE))
  schema <- infer_nanoarrow_schema(array)
  expect_identical(schema$format, "u")
  expect_identical(schema$metadata[["ARROW:extension:name"]], "geoarrow.wkt")
  expect_identical(
    schema$metadata[["ARROW:extension:metadata"]],
    sprintf('{"edges":"spherical"}')
  )
})

test_that("convert_array() works for wkt()", {
  # Check from exact storage
  array <- as_geoarrow_array(wk::wkt("POINT (0 1)"))
  expect_identical(
    convert_array(array, wk::wkt()),
    wk::wkt("POINT (0 1)")
  )

  # Check from something that goes through the handler/writer
  array <- as_geoarrow_array(wk::as_wkb("POINT (0 1)"))
  expect_identical(
    convert_array(array, wk::wkt()),
    wk::wkt("POINT (0 1)")
  )

  # Check that crs attribute is passed through
  array <- as_geoarrow_array(wk::wkt("POINT (0 1)", crs = "OGC:CRS84"))
  expect_identical(
    convert_array(array, wk::wkt()),
    wk::wkt("POINT (0 1)", crs = wk::wk_crs_projjson("OGC:CRS84"))
  )

  # Check that geodesic attribute is passed through
  array <- as_geoarrow_array(wk::wkt("POINT (0 1)", geodesic = TRUE))
  expect_identical(
    convert_array(array, wk::wkt(geodesic = TRUE)),
    wk::wkt("POINT (0 1)", geodesic = TRUE)
  )
})

test_that("convert_array() works for wkb()", {
  # Check from exact storage
  array <- as_geoarrow_array(wk::as_wkb(c("POINT (0 1)")))
  expect_identical(
    convert_array(array, wk::wkb()),
    wk::as_wkb(c("POINT (0 1)"))
  )

  # Check from something that goes through the handler/writer
  array <- as_geoarrow_array(wk::wkt(c("POINT (0 1)")))
  expect_identical(
    convert_array(array, wk::wkb()),
    wk::as_wkb(c("POINT (0 1)"))
  )

  # Check that crs attribute is passed through
  array <- as_geoarrow_array(wk::as_wkb(wk::wkt("POINT (0 1)", crs = "OGC:CRS84")))
  expect_identical(
    convert_array(array, wk::wkb()),
    wk::as_wkb(wk::wkt("POINT (0 1)", crs = wk::wk_crs_projjson("OGC:CRS84")))
  )

  # Check that geodesic attribute is passed through
  array <- as_geoarrow_array(wk::as_wkb(wk::wkt("POINT (0 1)", geodesic = TRUE)))
  expect_identical(
    convert_array(array, wk::wkb(geodesic = TRUE)),
    wk::as_wkb(wk::wkt("POINT (0 1)", geodesic = TRUE))
  )
})

test_that("convert_array() works for xy()", {
  # Check from exact storage
  array <- as_geoarrow_array(wk::xy(0, 1))
  expect_identical(
    convert_array(array, wk::xy()),
    wk::xy(0, 1)
  )

  # Check from something that goes through the handler/writer
  array <- as_geoarrow_array(wk::wkt(c("POINT (0 1)")))
  expect_identical(
    convert_array(array, wk::xy()),
    wk::xy(0, 1)
  )

  # Check that crs attribute is passed through
  array <- as_geoarrow_array(wk::xy(0, 1, crs = "OGC:CRS84"))
  expect_identical(
    convert_array(array, wk::xy()),
    wk::xy(0, 1, crs = wk::wk_crs_projjson("OGC:CRS84"))
  )
})

test_that("convert_array() works for rct()", {
  # Check from exact storage
  array <- as_geoarrow_array(wk::rct(0, 1, 2, 3))
  expect_identical(
    convert_array(array, wk::rct()),
    wk::rct(0, 1, 2, 3)
  )

  # Check that crs attribute is passed through
  array <- as_geoarrow_array(wk::rct(0, 1, 2, 3, crs = "OGC:CRS84"))
  expect_identical(
    convert_array(array, wk::rct()),
    wk::rct(0, 1, 2, 3, crs = wk::wk_crs_projjson("OGC:CRS84"))
  )

  # Check from something that goes through the handler/writer
  array <- as_geoarrow_array(wk::rct(0, 1, 2, 3))
  expect_identical(
    convert_array(array, wk::wkt()),
    wk::wkt("POLYGON ((0 1, 2 1, 2 3, 0 3, 0 1))")
  )
})