Merge pull request #117 from paleolimbot/wkb-is-na

never vapply() along a wkb vector

NEWS.md

@@ -17,6 +17,8 @@
   vectors for better integration with sf (#113, #114).
 * Refactored well-known text parser to be more reusable and faster
   (#115, #104).
+* Minor performance enhancement for `is.na()` and `validate_wk_wkb()`
+  when called on a very long `wkb()` vector (#117).
 
 # wk 0.5.0
 

R/wkb.R

@@ -88,9 +88,8 @@ new_wk_wkb <- function(x = list(), crs = NULL, geodesic = NULL) {
 #' @rdname new_wk_wkb
 #' @export
 validate_wk_wkb <- function(x) {
-  types <- vapply(unclass(x), typeof, character(1))
-  good_types <- types %in% c("raw", "NULL")
-  if (any(!good_types)) {
+  good_types <- .Call(wk_c_wkb_is_raw_or_null, x)
+  if (!all(good_types)) {
     stop("items in wkb input must be raw() or NULL", call. = FALSE)
   }
 
@@ -120,7 +119,7 @@ is_wk_wkb <- function(x) {
 
 #' @export
 is.na.wk_wkb <- function(x) {
-  vapply(unclass(x), is.null, logical(1))
+  .Call(wk_c_wkb_is_na, x)
 }
 
 #' @export

src/init.c

@@ -28,6 +28,8 @@ extern SEXP wk_c_trans_affine_new(SEXP trans_matrix);
 extern SEXP wk_c_trans_affine_as_matrix(SEXP trans_xptr);
 extern SEXP wk_c_trans_set_new(SEXP xy, SEXP use_z, SEXP use_m);
 extern SEXP wk_c_trans_filter_new(SEXP handler_xptr, SEXP trans_xptr);
+extern SEXP wk_c_wkb_is_na(SEXP geom);
+extern SEXP wk_c_wkb_is_raw_or_null(SEXP geom);
 extern SEXP wk_c_vertex_filter_new(SEXP handler_xptr, SEXP add_details);
 extern SEXP wk_c_handler_void_new();
 extern SEXP wk_c_handler_addr(SEXP xptr);
@@ -60,6 +62,8 @@ static const R_CallMethodDef CallEntries[] = {
   {"wk_c_trans_affine_as_matrix", (DL_FUNC) &wk_c_trans_affine_as_matrix, 1},
   {"wk_c_trans_set_new", (DL_FUNC) &wk_c_trans_set_new, 3},
   {"wk_c_trans_filter_new", (DL_FUNC) &wk_c_trans_filter_new, 2},
+  {"wk_c_wkb_is_na", (DL_FUNC) &wk_c_wkb_is_na, 1},
+  {"wk_c_wkb_is_raw_or_null", (DL_FUNC) &wk_c_wkb_is_raw_or_null, 1},
   {"wk_c_vertex_filter_new", (DL_FUNC) &wk_c_vertex_filter_new, 2},
   {"wk_c_handler_void_new", (DL_FUNC) &wk_c_handler_void_new, 0},
   {"wk_c_handler_addr", (DL_FUNC) &wk_c_handler_addr, 1},

src/vctr.c

@@ -0,0 +1,30 @@
+#define R_NO_REMAP
+#include <R.h>
+#include <Rinternals.h>
+
+SEXP wk_c_wkb_is_na(SEXP geom) {
+  R_xlen_t size = Rf_xlength(geom);
+  SEXP result = PROTECT(Rf_allocVector(LGLSXP, size));
+  int* pResult = LOGICAL(result);
+
+  for (R_xlen_t i = 0; i < size; i++) {
+    pResult[i] = VECTOR_ELT(geom, i) == R_NilValue;
+  }
+
+  UNPROTECT(1);
+  return result;
+}
+
+SEXP wk_c_wkb_is_raw_or_null(SEXP geom) {
+  R_xlen_t size = Rf_xlength(geom);
+  SEXP result = PROTECT(Rf_allocVector(LGLSXP, size));
+  int* pResult = LOGICAL(result);
+  int typeOf;
+  for (R_xlen_t i = 0; i < size; i++) {
+    typeOf = TYPEOF(VECTOR_ELT(geom, i));
+    pResult[i] = (typeOf == NILSXP) || (typeOf == RAWSXP);
+  }
+
+  UNPROTECT(1);
+  return result;
+}