Handle xy(NA, NA) as null instead of empty (#205)

* xy NA NA as empty

* writer/handler consistency for xy

* with maybe working nullability/empty split in xy

* fix the vertex filter

* add example

* fix some rough edges

* stronger NA/NaN testing for sfc

* fix NA/NaN for custom conversion to xy

* fix copy/paste error

Author: paleolimbot

NAMESPACE

@@ -92,6 +92,7 @@ S3method(grd_tile,wk_grd_rct)
 S3method(grd_tile,wk_grd_xy)
 S3method(is.na,wk_rcrd)
 S3method(is.na,wk_wkb)
+S3method(is.na,wk_xy)
 S3method(length,wk_rcrd)
 S3method(names,wk_rcrd)
 S3method(plot,wk_crc)

R/pkg-sf.R

@@ -163,6 +163,9 @@ as_xy.sfc <- function(x, ...) {
     coords <- sf::st_coordinates(x)
     dims <- colnames(coords)
     dimnames(coords) <- NULL
+    if (anyNA(coords)) {
+      coords[is.na(coords)] <- NaN
+    }
 
     if (identical(dims, c("X", "Y"))) {
       new_wk_xy(
@@ -263,7 +266,8 @@ st_as_sfc.wk_xy <- function(x, ...) {
 }
 
 st_as_sf.wk_xy <- function(x, ...) {
-  if ((length(x) > 0) && all(!is.na(x))) {
+  is_na_or_nan <- Reduce("&", lapply(unclass(x), is.na))
+  if ((length(x) > 0) && all(!is_na_or_nan)) {
     sf::st_as_sf(as.data.frame(x), coords = xy_dims(x), crs = sf_crs_from_wk(x))
   } else {
     sf::st_as_sf(

R/utils.R

@@ -34,9 +34,3 @@ recycle_common <- function(...) {
 is_vector_class <- function(x) {
   identical(class(x[integer(0)]), class(x))
 }
-
-# This helps when comparing with sf package objects, which tend to use
-# NA rather than NaN.
-expect_equal_ignore_na_nan <- function(actual, expected) {
-  testthat::expect_true(all.equal(actual, expected))
-}

R/vertex-filter.R

@@ -94,11 +94,12 @@ wk_vertex_filter <- function(handler, add_details = FALSE) {
 #' @export
 wk_coords.wk_xy <- function(handleable, ...) {
   feature_id <- seq_along(handleable)
-  not_empty <- !is.na(handleable)
+  is_na <- Reduce("&", lapply(unclass(handleable), is.na))
+  has_coord <- !is_na
 
-  if (!all(not_empty)) {
-    handleable <- handleable[not_empty]
-    feature_id <- feature_id[not_empty]
+  if (!all(has_coord)) {
+    handleable <- handleable[has_coord]
+    feature_id <- feature_id[has_coord]
   }
 
   new_data_frame(

R/xyzm.R

@@ -15,6 +15,10 @@
 #' xym(1:5, 1:5, 10)
 #' xyzm(1:5, 1:5, 10, 12)
 #'
+#' # NA, NA maps to a null/na feature; NaN, NaN maps to EMPTY
+#' as_wkt(xy(NaN, NaN))
+#' as_wkt(xy(NA, NA))
+#'
 xy <- function(x = double(), y = double(), crs = wk_crs_auto()) {
   vec <- new_wk_xy(recycle_common(x = as.double(x), y = as.double(y)), crs = wk_crs_auto_value(x, crs))
   validate_wk_xy(vec)
@@ -309,6 +313,13 @@ format.wk_xyzm <- function(x, ...) {
   structure(result, class = class(x), crs = wk_crs_output(x, replacement))
 }
 
+#' @export
+is.na.wk_xy <- function(x, ...) {
+  is_na <- Reduce("&", lapply(unclass(x), is.na))
+  is_nan <- Reduce("&", lapply(unclass(x), is.nan))
+  is_na & !is_nan
+}
+
 
 #' XY vector extractors
 #'

man/xy.Rd

@@ -66,29 +66,32 @@ SEXP wk_read_xy(SEXP data, wk_handler_t* handler) {
 #endif
 
       int coord_empty = 1;
+      int coord_null = 1;
       for (int j = 0; j < coord_size; j++) {
         coord[j] = data_ptr[j][data_ptr_i];
         meta.bounds_min[j] = data_ptr[j][data_ptr_i];
         meta.bounds_max[j] = data_ptr[j][data_ptr_i];
 
-        if (!ISNAN(coord[j])) {
-          coord_empty = 0;
-        }
+        coord_null = coord_null && ISNA(coord[j]);
+        coord_empty = coord_empty && ISNAN(coord[j]);
       }
 
-      if (coord_empty) {
+      if (coord_null) {
+        HANDLE_CONTINUE_OR_BREAK(handler->null_feature(handler->handler_data));
+      } else if (coord_empty) {
         meta.size = 0;
+        HANDLE_CONTINUE_OR_BREAK(
+            handler->geometry_start(&meta, WK_PART_ID_NONE, handler->handler_data));
+        HANDLE_CONTINUE_OR_BREAK(
+            handler->geometry_end(&meta, WK_PART_ID_NONE, handler->handler_data));
       } else {
         meta.size = 1;
-      }
-
-      HANDLE_CONTINUE_OR_BREAK(
-          handler->geometry_start(&meta, WK_PART_ID_NONE, handler->handler_data));
-      if (!coord_empty) {
+        HANDLE_CONTINUE_OR_BREAK(
+            handler->geometry_start(&meta, WK_PART_ID_NONE, handler->handler_data));
         HANDLE_CONTINUE_OR_BREAK(handler->coord(&meta, coord, 0, handler->handler_data));
+        HANDLE_CONTINUE_OR_BREAK(
+            handler->geometry_end(&meta, WK_PART_ID_NONE, handler->handler_data));
       }
-      HANDLE_CONTINUE_OR_BREAK(
-          handler->geometry_end(&meta, WK_PART_ID_NONE, handler->handler_data));
 
       if (handler->feature_end(&vector_meta, i, handler->handler_data) == WK_ABORT) {
         break;

src/handle-xy.c

@@ -128,11 +128,6 @@ int wk_vertex_filter_feature_start(const wk_vector_meta_t* meta, R_xlen_t feat_i
   return WK_CONTINUE;
 }
 
-int wk_vertex_filter_feature_null(void* handler_data) {
-  vertex_filter_t* vertex_filter = (vertex_filter_t*)handler_data;
-  return vertex_filter->next->null_feature(vertex_filter->next->handler_data);
-}
-
 int wk_vertex_filter_feature_end(const wk_vector_meta_t* meta, R_xlen_t feat_id,
                                  void* handler_data) {
   return WK_CONTINUE;
@@ -234,7 +229,6 @@ SEXP wk_c_vertex_filter_new(SEXP handler_xptr, SEXP add_details) {
   handler->vector_end = &wk_vertex_filter_vector_end;
 
   handler->feature_start = &wk_vertex_filter_feature_start;
-  handler->null_feature = &wk_vertex_filter_feature_null;
   handler->feature_end = &wk_vertex_filter_feature_end;
 
   handler->geometry_start = &wk_vertex_filter_geometry_start;

src/vertex-filter.c

@@ -82,7 +82,7 @@ static inline void xy_writer_append_empty(xy_writer_t* writer) {
 
   for (int i = 0; i < 4; i++) {
     if (writer->result_ptr[i]) {
-      writer->result_ptr[i][writer->feat_id] = NA_REAL;
+      writer->result_ptr[i][writer->feat_id] = R_NaN;
     }
   }
   writer->feat_id++;
@@ -135,6 +135,17 @@ int xy_writer_feature_start(const wk_vector_meta_t* meta, R_xlen_t feat_id,
   return WK_CONTINUE;
 }
 
+int xy_writer_null_feature(void* handler_data) {
+  xy_writer_t* data = (xy_writer_t*)handler_data;
+  for (int i = 0; i < 4; i++) {
+    if (data->result_ptr[i]) {
+      data->result_ptr[i][data->feat_id - 1] = NA_REAL;
+    }
+  }
+
+  return WK_ABORT_FEATURE;
+}
+
 int xy_writer_geometry_start(const wk_meta_t* meta, uint32_t part_id,
                              void* handler_data) {
   xy_writer_t* data = (xy_writer_t*)handler_data;
@@ -289,6 +300,7 @@ SEXP wk_c_xy_writer_new(void) {
 
   handler->vector_start = &xy_writer_vector_start;
   handler->feature_start = &xy_writer_feature_start;
+  handler->null_feature = &xy_writer_null_feature;
   handler->geometry_start = &xy_writer_geometry_start;
   handler->coord = &xy_writer_coord;
   handler->vector_end = &xy_writer_vector_end;

src/xy-writer.c

@@ -1,22 +1,31 @@
 
 test_that("wk_handle.wk_xy() works", {
   expect_identical(
-    wk_handle(xy(c(NA, 2, 3, NA), c(NA, NA, 4, 5)), wkt_writer()),
-    wkt(c("POINT EMPTY", "POINT (2 nan)", "POINT (3 4)", "POINT (nan 5)"))
+    wk_handle(xy(c(NA, NaN, 2, 3, NA), c(NA, NaN, NA, 4, 5)), wkt_writer()),
+    wkt(c(NA, "POINT EMPTY", "POINT (2 nan)", "POINT (3 4)", "POINT (nan 5)"))
   )
 
   expect_identical(
-    wk_handle(xyz(c(NA, 2, 3, NA), c(NA, NA, 4, 5), c(NA, NA, NA, NA)), wkt_writer()),
-    wkt(c("POINT Z EMPTY", "POINT Z (2 nan nan)", "POINT Z (3 4 nan)", "POINT Z (nan 5 nan)"))
+    wk_handle(
+      xyz(c(NA, NaN, 2, 3, NA), c(NA, NaN, NA, 4, 5), c(NA, NaN, NA, NA, NA)),
+      wkt_writer()
+    ),
+    wkt(c(NA, "POINT Z EMPTY", "POINT Z (2 nan nan)", "POINT Z (3 4 nan)", "POINT Z (nan 5 nan)"))
   )
 
   expect_identical(
-    wk_handle(xym(c(NA, 2, 3, NA), c(NA, NA, 4, 5), c(NA, NA, NA, NA)), wkt_writer()),
-    wkt(c("POINT M EMPTY", "POINT M (2 nan nan)", "POINT M (3 4 nan)", "POINT M (nan 5 nan)"))
+    wk_handle(
+      xym(c(NA, NaN, 2, 3, NA), c(NA, NaN, NA, 4, 5), c(NA, NaN, NA, NA, NA)),
+      wkt_writer()
+    ),
+    wkt(c(NA, "POINT M EMPTY", "POINT M (2 nan nan)", "POINT M (3 4 nan)", "POINT M (nan 5 nan)"))
   )
 
   expect_identical(
-    wk_handle(xyzm(c(NA, 2, 3, NA), c(NA, NA, 4, 5), c(NA, NA, NA, NA), c(NA, rep(1, 3))), wkt_writer()),
-    wkt(c("POINT ZM EMPTY", "POINT ZM (2 nan nan 1)", "POINT ZM (3 4 nan 1)", "POINT ZM (nan 5 nan 1)"))
+    wk_handle(
+      xyzm(c(NA, NaN, 2, 3, NA), c(NA, NaN, NA, 4, 5), c(NA, NaN, NA, NA, NA), c(NA, NaN, rep(1, 3))),
+      wkt_writer()
+    ),
+    wkt(c(NA, "POINT ZM EMPTY", "POINT ZM (2 nan nan 1)", "POINT ZM (3 4 nan 1)", "POINT ZM (nan 5 nan 1)"))
   )
 })

tests/testthat/test-handle-xy.R

@@ -94,13 +94,16 @@ test_that("conversion from sf to xy works", {
 
   sfc <- sf::st_sfc(sf::st_point(), sf::st_point(c(0, 1)))
   expect_s3_class(as_xy(sfc), "wk_xy")
-  expect_identical(as_xy(sfc), xy(c(NA, 0), c(NA, 1)))
+  expect_identical(as_xy(sfc), xy(c(NaN, 0), c(NaN, 1)))
 
   sf <- sf::st_as_sf(new_data_frame(list(geometry = sfc)))
-  expect_identical(as_xy(sf), xy(c(NA, 0), c(NA, 1)))
+  expect_identical(as_xy(sf), xy(c(NaN, 0), c(NaN, 1)))
 
   expect_identical(as_xy(sf::st_sfc()), xy(crs = NULL))
-  expect_identical(as_xy(sf::st_sfc(sf::st_linestring())), xy(NA, NA, crs = sf::NA_crs_))
+  expect_identical(
+    as_xy(sf::st_sfc(sf::st_linestring())),
+    xy(NaN, NaN, crs = sf::NA_crs_)
+  )
 
   # check all dimensions
   expect_identical(as_xy(sf::st_sfc(sf::st_point(c(1, 2, 3, 4), dim = "XYZM"))), xyzm(1, 2, 3, 4))
@@ -119,26 +122,29 @@ test_that("conversion from bbox to rct works", {
 test_that("conversion to sf works", {
   skip_if_not_installed("sf")
 
-  # Use NaN/NaN instead of NA/NA because Waldo cares about this comparison
   sfc <- sf::st_sfc(sf::st_point(), sf::st_point(c(0, 1)), NULL, crs = 4326)
   sf <- sf::st_as_sf(new_data_frame(list(geometry = sfc)))
   wkb <- as_wkb(c("POINT EMPTY", "POINT (0 1)", NA), crs = 4326)
   wkt <- as_wkt(c("POINT EMPTY", "POINT (0 1)", NA), crs = 4326)
 
-  expect_equal_ignore_na_nan(sf::st_as_sf(wkb), sf)
-  expect_equal_ignore_na_nan(sf::st_as_sfc(wkb), sfc)
+  expect_equal(sf::st_as_sf(wkb), sf)
+  expect_equal(sf::st_as_sfc(wkb), sfc)
   expect_equal(sf::st_as_sf(wkt), sf)
   expect_equal(sf::st_as_sfc(wkt), sfc)
 
   # xy
-  expect_equal_ignore_na_nan(
+  expect_equal(
     sf::st_as_sf(xy(c(NA, 0, NA), c(NA, 1, NA), crs = 4326)),
     sf
   )
-  expect_equal_ignore_na_nan(
+  expect_equal(
     sf::st_as_sfc(xy(c(NA, 0, NA), c(NA, 1, NA), crs = 4326)),
     sfc
   )
+  expect_equal(
+    sf::st_as_sfc(xy(c(NaN, 0, NA), c(NaN, 1, NA), crs = 4326)),
+    sfc
+  )
 
   # xy with all !is.na() uses faster sf conversion with coords
   expect_equal(sf::st_as_sf(xy(0, 1, crs = 4326)), sf[2,, , drop = FALSE])

tests/testthat/test-pkg-sf.R

@@ -5,27 +5,7 @@ test_that("sfc_writer() works with fixed-length input", {
   # zero-length
   expect_identical(wk_handle(wkb(), sfc_writer()), sf::st_sfc())
 
-  # empties (equal because of NaN/NA difference for POINT)
-  expect_equal_ignore_na_nan(
-    wk_handle(
-      as_wkb(
-        c("POINT EMPTY", "LINESTRING EMPTY", "POLYGON EMPTY",
-          "MULTIPOINT EMPTY", "MULTILINESTRING EMPTY", "MULTIPOLYGON EMPTY",
-          "GEOMETRYCOLLECTION EMPTY"
-        )
-      ),
-      sfc_writer()
-    ),
-    sf::st_sfc(
-      sf::st_point(), sf::st_linestring(), sf::st_polygon(),
-      sf::st_multipoint(), sf::st_multilinestring(), sf::st_multipolygon(),
-      sf::st_geometrycollection()
-    )
-  )
-
-  # subtely different for WKT, since a point will fire zero coordinates
-  # whereas for WKB it will fire (NaN, NaN)
-  expect_equal_ignore_na_nan(
+  expect_identical(
     wk_handle(
       as_wkt(
         c("POINT EMPTY", "LINESTRING EMPTY", "POLYGON EMPTY",
@@ -102,27 +82,7 @@ test_that("sfc_writer() works with fixed-length input", {
 test_that("sfc_writer() works with promote_multi = TRUE", {
   skip_if_not_installed("sf")
 
-  # empties (equal because of NaN/NA difference for POINT)
-  expect_equal_ignore_na_nan(
-    wk_handle(
-      as_wkb(
-        c("POINT EMPTY", "LINESTRING EMPTY", "POLYGON EMPTY",
-          "MULTIPOINT EMPTY", "MULTILINESTRING EMPTY", "MULTIPOLYGON EMPTY",
-          "GEOMETRYCOLLECTION EMPTY"
-        )
-      ),
-      sfc_writer(promote_multi = TRUE)
-    ),
-    sf::st_sfc(
-      sf::st_multipoint(), sf::st_multilinestring(), sf::st_multipolygon(),
-      sf::st_multipoint(), sf::st_multilinestring(), sf::st_multipolygon(),
-      sf::st_geometrycollection()
-    )
-  )
-
-  # subtely different for WKT, since a point will fire zero coordinates
-  # whereas for WKB it will fire (NaN, NaN)
-  expect_equal_ignore_na_nan(
+  expect_identical(
     wk_handle(
       as_wkt(
         c("POINT EMPTY", "LINESTRING EMPTY", "POLYGON EMPTY",
@@ -240,7 +200,7 @@ test_that("sfc_writer() turns NULLs into EMPTY", {
   )
 
   for (i in seq_along(all_types)) {
-    expect_equal_ignore_na_nan(
+    expect_identical(
       wk_handle(c(all_types[i], wkb(list(NULL))), sfc_writer()),
       wk_handle(c(all_types[i], all_types[i]), sfc_writer())
     )
@@ -270,7 +230,7 @@ test_that("sfc_writer() turns NULLs into EMPTY", {
 
   for (i in seq_along(all_types)) {
     vec <- wk_handle(c(all_types_non_empty[i], wkb(list(NULL))), sfc_writer())
-    expect_equal_ignore_na_nan(vec[[2]], wk_handle(all_types[i], sfc_writer())[[1]])
+    expect_identical(vec[[2]], wk_handle(all_types[i], sfc_writer())[[1]])
     expect_s3_class(vec, paste0("sfc_", types[i]))
   }
 
@@ -284,7 +244,7 @@ test_that("sfc_writer() turns NULLs into EMPTY", {
   )
 
   for (i in seq_along(all_types)) {
-    expect_equal_ignore_na_nan(
+    expect_identical(
       wk_handle(c(zm_types[i], wkb(list(NULL))), sfc_writer()),
       wk_handle(c(zm_types[i], zm_types_empty[i]), sfc_writer())
     )

tests/testthat/test-sfc-writer.R

@@ -2,11 +2,11 @@
 test_that("wk_vertices() works", {
   expect_identical(
     wk_vertices(wkt(c("POINT (0 0)", "POINT (1 1)", NA))),
-    wkt(c("POINT (0 0)", "POINT (1 1)", NA))
+    wkt(c("POINT (0 0)", "POINT (1 1)"))
   )
   expect_identical(
     wk_vertices(wkt(c("LINESTRING (0 0, 1 1)", NA))),
-    wkt(c("POINT (0 0)", "POINT (1 1)", NA))
+    wkt(c("POINT (0 0)", "POINT (1 1)"))
   )
   expect_error(wk_vertices(new_wk_wkt("POINT ENTPY")), "ENTPY")
 
@@ -141,6 +141,9 @@ test_that("optimized wk_coords() for xy() works", {
   xys <- xy(1:5, 6:10)
   expect_identical(wk_coords(xys), wk_coords.default(xys))
 
-  xys_with_empty <- c(xys, xy(NA, NA))
-  expect_identical(wk_coords(xys_with_empty), wk_coords.default(xys_with_empty))
+  xys_with_empty_and_null <- c(xys, xy(NA, NA), xy(NaN, NaN))
+  expect_identical(
+    wk_coords(xys_with_empty_and_null),
+    wk_coords.default(xys_with_empty_and_null)
+  )
 })