From 584c03617e1fe1c155f20d7b84028936c1670e5b Mon Sep 17 00:00:00 2001 From: Taras Zakharko Date: Tue, 3 Jun 2025 11:37:50 +0200 Subject: [PATCH 01/13] Implement serialization support for s2_geometry vectors - `s2_geography` vectors are now ALTREP lists that serialize/deserialize via WKB - `new_s2_geography()` has been moved to C level and is now a designated constructor for `s2_geometry_`objects; code creating such objects has been updated accordingly - Implemented serialization tests for all s2 functions that create `s2_geometry` objects --- R/RcppExports.R | 4 + R/s2-geography.R | 3 - R/utils.R | 4 + src/Makevars.in | 1 + src/RcppExports.cpp | 20 +- src/geography.h | 2 + src/s2-altrep.cpp | 62 ++++++ src/s2-cell.cpp | 15 +- src/s2-constructors-formatters.cpp | 8 +- src/s2-new-geography.h | 3 + .../test-s2-constructors-formatters.R | 9 - tests/testthat/test-s2-serialization.R | 189 ++++++++++++++++++ 12 files changed, 290 insertions(+), 30 deletions(-) create mode 100644 src/s2-altrep.cpp create mode 100644 src/s2-new-geography.h create mode 100644 tests/testthat/test-s2-serialization.R diff --git a/R/RcppExports.R b/R/RcppExports.R index bb373a3f..4d17f0f9 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -61,6 +61,10 @@ cpp_s2_max_distance <- function(geog1, geog2) { .Call(`_s2_cpp_s2_max_distance`, geog1, geog2) } +new_s2_geography <- function(data) { + .Call(`_s2_new_s2_geography`, data) +} + cpp_s2_bounds_cap <- function(geog) { .Call(`_s2_cpp_s2_bounds_cap`, geog) } diff --git a/R/s2-geography.R b/R/s2-geography.R index df1ea5bf..f5b36a52 100644 --- a/R/s2-geography.R +++ b/R/s2-geography.R @@ -179,9 +179,6 @@ wk_set_geodesic.s2_geography <- function(x, geodesic) { x } -new_s2_geography <- function(x) { - structure(x, class = c("s2_geography", "wk_vctr")) -} #' @export is.na.s2_geography <- function(x) { diff --git a/R/utils.R b/R/utils.R index f12af485..7568add0 100644 --- a/R/utils.R +++ b/R/utils.R @@ -86,3 +86,7 @@ expect_wkt_equal <- function(x, y, precision = 16) { expect_near <- function(x, y, epsilon) { testthat::expect_true(abs(y - x) < epsilon) } + +expect_wkt_serializeable <- function(x) { + expect_wkt_equal(x, unserialize(serialize(x, NULL)), precision = 8) +} diff --git a/src/Makevars.in b/src/Makevars.in index 56682041..43a1c731 100644 --- a/src/Makevars.in +++ b/src/Makevars.in @@ -106,6 +106,7 @@ S2_OBJECTS = s2/encoded_s2cell_id_vector.o \ STATLIB = s2/libs2static.a OBJECTS = cpp-compat.o \ + s2-altrep.o \ s2-accessors.o \ s2-bounds.o \ s2-cell.o \ diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index 5c33e1be..c2088603 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -176,6 +176,17 @@ BEGIN_RCPP return rcpp_result_gen; END_RCPP } +// new_s2_geography +SEXP new_s2_geography(SEXP data); +RcppExport SEXP _s2_new_s2_geography(SEXP dataSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< SEXP >::type data(dataSEXP); + rcpp_result_gen = Rcpp::wrap(new_s2_geography(data)); + return rcpp_result_gen; +END_RCPP +} // cpp_s2_bounds_cap DataFrame cpp_s2_bounds_cap(List geog); RcppExport SEXP _s2_cpp_s2_bounds_cap(SEXP geogSEXP) { @@ -470,7 +481,7 @@ BEGIN_RCPP END_RCPP } // cpp_s2_cell_center -List cpp_s2_cell_center(NumericVector cellIdVector); +SEXP cpp_s2_cell_center(NumericVector cellIdVector); RcppExport SEXP _s2_cpp_s2_cell_center(SEXP cellIdVectorSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; @@ -481,7 +492,7 @@ BEGIN_RCPP END_RCPP } // cpp_s2_cell_polygon -List cpp_s2_cell_polygon(NumericVector cellIdVector); +SEXP cpp_s2_cell_polygon(NumericVector cellIdVector); RcppExport SEXP _s2_cpp_s2_cell_polygon(SEXP cellIdVectorSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; @@ -492,7 +503,7 @@ BEGIN_RCPP END_RCPP } // cpp_s2_cell_vertex -List cpp_s2_cell_vertex(NumericVector cellIdVector, IntegerVector k); +SEXP cpp_s2_cell_vertex(NumericVector cellIdVector, IntegerVector k); RcppExport SEXP _s2_cpp_s2_cell_vertex(SEXP cellIdVectorSEXP, SEXP kSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; @@ -1369,6 +1380,7 @@ static const R_CallMethodDef CallEntries[] = { {"_s2_cpp_s2_project_normalized", (DL_FUNC) &_s2_cpp_s2_project_normalized, 2}, {"_s2_cpp_s2_distance", (DL_FUNC) &_s2_cpp_s2_distance, 2}, {"_s2_cpp_s2_max_distance", (DL_FUNC) &_s2_cpp_s2_max_distance, 2}, + {"_s2_new_s2_geography", (DL_FUNC) &_s2_new_s2_geography, 1}, {"_s2_cpp_s2_bounds_cap", (DL_FUNC) &_s2_cpp_s2_bounds_cap, 1}, {"_s2_cpp_s2_bounds_rect", (DL_FUNC) &_s2_cpp_s2_bounds_rect, 1}, {"_s2_cpp_s2_cell_union_normalize", (DL_FUNC) &_s2_cpp_s2_cell_union_normalize, 1}, @@ -1476,7 +1488,9 @@ static const R_CallMethodDef CallEntries[] = { {NULL, NULL, 0} }; +void altrep_init(DllInfo *dll); RcppExport void R_init_s2(DllInfo *dll) { R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); R_useDynamicSymbols(dll, FALSE); + altrep_init(dll); } diff --git a/src/geography.h b/src/geography.h index ebfd0dd1..4f51a528 100644 --- a/src/geography.h +++ b/src/geography.h @@ -6,6 +6,8 @@ #include "s2geography.h" +SEXP new_s2_geography(SEXP data); + class RGeography { public: RGeography(std::unique_ptr geog): diff --git a/src/s2-altrep.cpp b/src/s2-altrep.cpp new file mode 100644 index 00000000..bffb1407 --- /dev/null +++ b/src/s2-altrep.cpp @@ -0,0 +1,62 @@ +#define R_NO_REMAP +#include +#include +#include "R_ext/Altrep.h" + +#include +using namespace Rcpp; + +R_altrep_class_t s2_geography_altrep_cls; + +// [[Rcpp::export]] +SEXP new_s2_geography(SEXP data) { + if (TYPEOF(data) != VECSXP) { + Rf_error("s2_geography data must be a list"); + } + + SEXP obj = PROTECT(R_new_altrep(s2_geography_altrep_cls, data, R_NilValue)); + + SEXP cls = PROTECT(Rf_allocVector(STRSXP, 2)); + SET_STRING_ELT(cls, 0, Rf_mkChar("s2_geography")); + SET_STRING_ELT(cls, 1, Rf_mkChar("wk_vctr")); + + Rf_setAttrib(obj, R_ClassSymbol, cls); + UNPROTECT(2); + + return obj; +} + +// ALTREP implementation for s2_geography +static R_INLINE R_xlen_t s2_altrep_Length(SEXP obj) { + SEXP data = R_altrep_data1(obj); + return Rf_xlength(data); +} + +static SEXP s2_altrep_Elt(SEXP obj, R_xlen_t i) { + SEXP data = R_altrep_data1(obj); + return VECTOR_ELT(data, i); +} + +static SEXP s2_altrep_Serialized_state(SEXP obj) +{ + Function to_wkb = Environment::namespace_env("s2")["s2_as_binary"]; + + return to_wkb(obj); +} + +static SEXP s2_altrep_Unserialize(SEXP cls, SEXP state) +{ + Function from_wkb = Environment::namespace_env("s2")["s2_geog_from_wkb"]; + + return from_wkb(state); +} + +// [[Rcpp::init]] +void altrep_init(DllInfo *dll) { + s2_geography_altrep_cls = R_make_altlist_class("s2_geography", "s2", dll); + + R_set_altrep_Length_method(s2_geography_altrep_cls, s2_altrep_Length); + R_set_altlist_Elt_method(s2_geography_altrep_cls, s2_altrep_Elt); + R_set_altrep_Serialized_state_method(s2_geography_altrep_cls, s2_altrep_Serialized_state); + R_set_altrep_Unserialize_method(s2_geography_altrep_cls, s2_altrep_Unserialize); +}; diff --git a/src/s2-cell.cpp b/src/s2-cell.cpp index 7c38e2c8..16a423aa 100644 --- a/src/s2-cell.cpp +++ b/src/s2-cell.cpp @@ -350,7 +350,7 @@ LogicalVector cpp_s2_cell_is_valid(NumericVector cellIdVector) { } // [[Rcpp::export]] -List cpp_s2_cell_center(NumericVector cellIdVector) { +SEXP cpp_s2_cell_center(NumericVector cellIdVector) { class Op: public UnaryS2CellOperator { SEXP processCell(S2CellId cellId, R_xlen_t i) { if (cellId.is_valid()) { @@ -363,12 +363,11 @@ List cpp_s2_cell_center(NumericVector cellIdVector) { Op op; List result = op.processVector(cellIdVector); - result.attr("class") = CharacterVector::create("s2_geography", "wk_vctr"); - return result; + return new_s2_geography(result); } // [[Rcpp::export]] -List cpp_s2_cell_polygon(NumericVector cellIdVector) { +SEXP cpp_s2_cell_polygon(NumericVector cellIdVector) { class Op: public UnaryS2CellOperator { SEXP processCell(S2CellId cellId, R_xlen_t i) { if (cellId.is_valid()) { @@ -382,12 +381,11 @@ List cpp_s2_cell_polygon(NumericVector cellIdVector) { Op op; List result = op.processVector(cellIdVector); - result.attr("class") = CharacterVector::create("s2_geography", "wk_vctr"); - return result; + return new_s2_geography(result); } // [[Rcpp::export]] -List cpp_s2_cell_vertex(NumericVector cellIdVector, IntegerVector k) { +SEXP cpp_s2_cell_vertex(NumericVector cellIdVector, IntegerVector k) { class Op: public UnaryS2CellOperator { SEXP processCell(S2CellId cellId, R_xlen_t i) { if (cellId.is_valid() && (this->k[i] >= 0)) { @@ -404,8 +402,7 @@ List cpp_s2_cell_vertex(NumericVector cellIdVector, IntegerVector k) { Op op; op.k = k; List result = op.processVector(cellIdVector); - result.attr("class") = CharacterVector::create("s2_geography", "wk_vctr"); - return result; + return new_s2_geography(result); } // [[Rcpp::export]] diff --git a/src/s2-constructors-formatters.cpp b/src/s2-constructors-formatters.cpp index 914a8bcd..7fdb89b8 100644 --- a/src/s2-constructors-formatters.cpp +++ b/src/s2-constructors-formatters.cpp @@ -109,12 +109,8 @@ int builder_vector_start(const wk_vector_meta_t* meta, void* handler_data) { SEXP builder_vector_end(const wk_vector_meta_t* meta, void* handler_data) { builder_handler_t* data = (builder_handler_t*) handler_data; builder_result_finalize(data); - SEXP cls = PROTECT(Rf_allocVector(STRSXP, 2)); - SET_STRING_ELT(cls, 0, Rf_mkChar("s2_geography")); - SET_STRING_ELT(cls, 1, Rf_mkChar("wk_vctr")); - Rf_setAttrib(data->result, R_ClassSymbol, cls); - UNPROTECT(1); - return data->result; + + return new_s2_geography(data->result); } int builder_feature_start(const wk_vector_meta_t* meta, R_xlen_t feat_id, void* handler_data) { diff --git a/src/s2-new-geography.h b/src/s2-new-geography.h new file mode 100644 index 00000000..885354ed --- /dev/null +++ b/src/s2-new-geography.h @@ -0,0 +1,3 @@ +#pragma once + +SEXP new_s2_geography(SEXP data); diff --git a/tests/testthat/test-s2-constructors-formatters.R b/tests/testthat/test-s2-constructors-formatters.R index f2918907..8afd623e 100644 --- a/tests/testthat/test-s2-constructors-formatters.R +++ b/tests/testthat/test-s2-constructors-formatters.R @@ -198,12 +198,3 @@ test_that("planar = TRUE works for s2_geog_from_text()", { out <- s2_as_binary(geog, planar = TRUE) expect_true(s2_num_points(out) > s2_num_points(geog)) }) - -test_that("null external pointers do not crash in the handler", { - geog <- as_s2_geography("POINT (0 1)") - geog2 <- unserialize(serialize(geog, NULL)) - expect_error( - wk::wk_void(geog2), - "External pointer is not valid" - ) -}) diff --git a/tests/testthat/test-s2-serialization.R b/tests/testthat/test-s2-serialization.R new file mode 100644 index 00000000..f6e5d6b3 --- /dev/null +++ b/tests/testthat/test-s2-serialization.R @@ -0,0 +1,189 @@ +# S2 Geography constructors +test_that("s2_geography() can be correctly serialized", { + expect_wkt_serializeable(s2_geography()) +}) + +test_that("s2_geog_point() can be correctly serialized", { + expect_wkt_serializeable(s2_geog_point( + -64, 45 + )) +}) + +test_that("s2_make_line() can be correctly serialized", { + expect_wkt_serializeable(s2_make_line( + c(-64, 8), c(45, 71) + )) +}) + +test_that("s2_make_polygon() can be correctly serialized", { + expect_wkt_serializeable(s2_make_polygon( + c(-45, 8, 0), c(64, 71, 90) + )) + expect_wkt_serializeable(s2_make_polygon( + c(-45, 8, 0, -45), c(64, 71, 90, 64) + )) +}) + +test_that("s2_geog_from_wkt() can be correctly serialized", { + expect_wkt_serializeable(s2_geog_from_text( + "POINT (-64 45)" + )) +}) + +test_that("s2_geog_from_wkb() can be correctly serialized", { + expect_wkt_serializeable(s2_geog_from_wkb( + as_wkb("POINT (-64 45)") + )) +}) + +# Geography Transformations +test_that("s2_union() can be correctly serialized", { + expect_wkt_serializeable(s2_union( + "POINT (10 30)", + "POINT (30 10)" + )) +}) + +test_that("s2_intersection() can be correctly serialized", { + expect_wkt_serializeable(s2_intersection( + "POLYGON ((0 0, 10 0, 10 10, 0 10, 0 0))", + "POLYGON ((5 5, 15 5, 15 15, 5 15, 5 5))", + )) +}) + + +test_that("s2_difference() can be correctly serialized", { + expect_wkt_serializeable(s2_difference( + "POLYGON ((0 0, 10 0, 10 10, 0 10, 0 0))", + "POLYGON ((5 5, 15 5, 15 15, 5 15, 5 5))", + )) +}) + +test_that("s2_sym_difference() can be correctly serialized", { + expect_wkt_serializeable(s2_sym_difference( + "POLYGON ((0 0, 10 0, 10 10, 0 10, 0 0))", + "POLYGON ((5 5, 15 5, 15 15, 5 15, 5 5))", + )) +}) + +test_that("s2_convex_hull() can be correctly serialized", { + expect_wkt_serializeable(s2_convex_hull( + "GEOMETRYCOLLECTION (POINT (-1 0), POINT (0 1), POINT (1 0))" + )) +}) + +test_that("s2_boundary() can be correctly serialized", { + expect_wkt_serializeable(s2_boundary( + "POLYGON ((0 0, 10 0, 10 10, 0 10, 0 0))" + )) +}) + + +test_that("s2_centroid() can be correctly serialized", { + expect_wkt_serializeable(s2_centroid( + "POLYGON ((0 0, 10 0, 10 10, 0 10, 0 0))" + )) +}) + +test_that("s2_closest_point() can be correctly serialized", { + expect_wkt_serializeable(s2_closest_point( + "POLYGON ((0 0, 10 0, 10 10, 0 10, 0 0))", + "POINT (-63 46)" + )) +}) + +test_that("s2_minimum_clearance_line_between() can be correctly serialized", { + expect_wkt_serializeable(s2_minimum_clearance_line_between( + "POINT (10 30)", + "POINT (30 10)" + )) +}) + +test_that("s2_snap_to_grid() can be correctly serialized", { + expect_wkt_serializeable(s2_snap_to_grid( + "POINT (10.25 30.5)", + 1 + )) +}) + +test_that("s2_simplify() can be correctly serialized", { + expect_wkt_serializeable(s2_simplify( + "POLYGON ((0 0, 10 0, 10 10, 0 10, 0 0))", + 1 + )) +}) + +test_that("s2_rebuild() can be correctly serialized", { + expect_wkt_serializeable(s2_rebuild( + "POLYGON ((0 0, 10 0, 10 10, 0 10, 0 0))" + )) +}) + +test_that("s2_buffer_cells() can be correctly serialized", { + expect_wkt_serializeable(s2_buffer_cells( + "POINT (10 10)", 100 + )) +}) + +test_that("s2_centroid_agg() can be correctly serialized", { + expect_wkt_serializeable(s2_centroid_agg(c( + "POINT (-1 0)", + "POINT (0 1)", + "POINT (1 0)" + ))) +}) + +test_that("s2_coverage_union_agg() can be correctly serialized", { + expect_wkt_serializeable(s2_coverage_union_agg(c( + "POINT (-1 0)", + "POINT (0 1)", + "POINT (1 0)" + ))) +}) + +test_that("s2_rebuild_agg() can be correctly serialized", { + expect_wkt_serializeable(s2_rebuild_agg(c( + "POINT (-1 0)", + "POINT (0 1)", + "POINT (1 0)" + ))) +}) + +test_that("s2_union_agg() can be correctly serialized", { + expect_wkt_serializeable(s2_union_agg(c( + "POINT (-1 0)", + "POINT (0 1)", + "POINT (1 0)" + ))) +}) + +test_that("s2_convex_hull_agg() can be correctly serialized", { + expect_wkt_serializeable(s2_convex_hull_agg(c( + "POINT (-1 0)", + "POINT (0 1)", + "POINT (1 0)" + ))) +}) + +test_that("s2_point_on_surface() can be correctly serialized", { + expect_wkt_serializeable(s2_point_on_surface( + "POLYGON ((0 0, 10 0, 10 10, 0 10, 0 0))" + )) +}) + +# S2 cell operators that construct s2 geography +test_that("s2_cell_center() can be correctly serialized", { + expect_wkt_serializeable(s2_cell_center(s2_cell("5"))) +}) + +test_that("s2_cell_boundary() can be correctly serialized", { + expect_wkt_serializeable(s2_cell_boundary(s2_cell("5"))) +}) + +test_that("s2_cell_polygon() can be correctly serialized", { + expect_wkt_serializeable(s2_cell_polygon(s2_cell("5"))) +}) + +test_that("s2_cell_vertex() can be correctly serialized", { + expect_wkt_serializeable(s2_cell_vertex(s2_cell("5"), seq_len(4L))) +}) From a7e7165566f391302b738085c5f7fa4b8c208112 Mon Sep 17 00:00:00 2001 From: Taras Zakharko Date: Tue, 3 Jun 2025 14:05:20 +0200 Subject: [PATCH 02/13] Fix a missing object entry in Makewars.win --- src/Makevars.win | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Makevars.win b/src/Makevars.win index 3d161f12..c8f49084 100644 --- a/src/Makevars.win +++ b/src/Makevars.win @@ -127,6 +127,7 @@ OBJECTS = s2/encoded_s2cell_id_vector.o \ s2/util/math/mathutil.o \ s2/util/units/length-units.o \ cpp-compat.o \ + s2-altrep.o \ s2-accessors.o \ s2-bounds.o \ s2-cell.o \ From cece63548cd9f15904157561d4ecd0a38ebf6aed Mon Sep 17 00:00:00 2001 From: Taras Zakharko Date: Wed, 4 Jun 2025 11:48:44 +0200 Subject: [PATCH 03/13] New serialization routines that do not lose precision --- R/s2-serialize.R | 18 +++++++++++ src/s2-altrep.cpp | 43 +++++++++++++++++++++----- tests/testthat/test-s2-serialization.R | 32 +++++++++++++++++++ 3 files changed, 85 insertions(+), 8 deletions(-) create mode 100644 R/s2-serialize.R diff --git a/R/s2-serialize.R b/R/s2-serialize.R new file mode 100644 index 00000000..92b29d31 --- /dev/null +++ b/R/s2-serialize.R @@ -0,0 +1,18 @@ +s2_geography_serialize <- function(x) { + wk::wk_handle( + as_s2_geography(x), + wk::wkb_writer(endian = 1L), + s2_projection = NULL + ) +} + +s2_geography_unserialize <- function(bytes) { + wk::wk_handle( + bytes, + s2::s2_geography_writer( + oriented = TRUE, + check = FALSE, + projection = NULL + ) + ) +} diff --git a/src/s2-altrep.cpp b/src/s2-altrep.cpp index bffb1407..ec712f7f 100644 --- a/src/s2-altrep.cpp +++ b/src/s2-altrep.cpp @@ -8,6 +8,23 @@ using namespace Rcpp; R_altrep_class_t s2_geography_altrep_cls; +static SEXP get_s2_namespace_env() { + static SEXP env = NULL; + + + + if (env == NULL) { + env = R_FindNamespace(PROTECT(Rf_mkString("s2"))); + UNPROTECT(1); + } + + return env; +} + + + + + // [[Rcpp::export]] SEXP new_s2_geography(SEXP data) { if (TYPEOF(data) != VECSXP) { @@ -37,18 +54,28 @@ static SEXP s2_altrep_Elt(SEXP obj, R_xlen_t i) { return VECTOR_ELT(data, i); } -static SEXP s2_altrep_Serialized_state(SEXP obj) -{ - Function to_wkb = Environment::namespace_env("s2")["s2_as_binary"]; +static SEXP s2_altrep_Serialized_state(SEXP obj) { + // fetch the pointer to s2::s2_geography_serialize() + SEXP env = get_s2_namespace_env(); + SEXP fn = Rf_findFun(Rf_install("s2_geography_serialize"), env); + + SEXP call = PROTECT(Rf_lang2(fn, obj)); + SEXP out = Rf_eval(call, env); - return to_wkb(obj); + UNPROTECT(1); + return out; } -static SEXP s2_altrep_Unserialize(SEXP cls, SEXP state) -{ - Function from_wkb = Environment::namespace_env("s2")["s2_geog_from_wkb"]; +static SEXP s2_altrep_Unserialize(SEXP cls, SEXP state) { + // fetch the pointer to s2::s2_geography_unserialize() + SEXP env = get_s2_namespace_env(); + SEXP fn = Rf_findFun(Rf_install("s2_geography_unserialize"), env); + + SEXP call = PROTECT(Rf_lang2(fn, state)); + SEXP out = Rf_eval(call, env); - return from_wkb(state); + UNPROTECT(1); + return out; } // [[Rcpp::init]] diff --git a/tests/testthat/test-s2-serialization.R b/tests/testthat/test-s2-serialization.R index f6e5d6b3..d7fcc8b3 100644 --- a/tests/testthat/test-s2-serialization.R +++ b/tests/testthat/test-s2-serialization.R @@ -1,3 +1,35 @@ +# Serialization routines +test_that("s2_geography_serialize() and s2_geography_deserialize() work", { + g <- s2_geog_from_text("POLYGON ((0 0, 10 0, 10 10, 0 10, 0 0))") + + expect_wkt_equal( + s2_geography_unserialize(s2_geography_serialize(g)), + g + ) +}) + +test_that("Serialization does not lose precision", { + # this polygons fails to correctly serialize using s2_as_binary() + g <- s2_make_polygon( + c( + 180, 180, + 179.364142661964, 178.725059362997, + 178.596838595117, 179.096609362997, + 179.413509362997, 180 + ), + c(-16.0671326636424, -16.5552165666392, + -16.8013540769469, -17.012041674368, + -16.63915, -16.4339842775474, + -16.3790542775474, -16.0671326636424 + ) + ) + + expect_wkt_equal( + s2_geography_unserialize(s2_geography_serialize(g)), + g + ) +}) + # S2 Geography constructors test_that("s2_geography() can be correctly serialized", { expect_wkt_serializeable(s2_geography()) From 23ed8aadc6262785da758e154130ef553865fbb6 Mon Sep 17 00:00:00 2001 From: Taras Zakharko Date: Wed, 4 Jun 2025 18:18:32 +0200 Subject: [PATCH 04/13] Only use ALTREP if building for R 4.3.0 or higher --- src/s2-altrep.cpp | 83 ++++++++++++++---------- tests/testthat/helper-s2-serialization.R | 7 ++ tests/testthat/test-s2-serialization.R | 69 ++++++++++++++++++++ 3 files changed, 124 insertions(+), 35 deletions(-) create mode 100644 tests/testthat/helper-s2-serialization.R diff --git a/src/s2-altrep.cpp b/src/s2-altrep.cpp index ec712f7f..c6e0bb7d 100644 --- a/src/s2-altrep.cpp +++ b/src/s2-altrep.cpp @@ -1,17 +1,35 @@ #define R_NO_REMAP #include #include +#include + +// ALTREP VECSXP are supported starting from R 4.3.0 +// +// When compiling for an earlier target serialization support is disabled +#if defined(R_VERSION) && R_VERSION >= R_Version(4, 3, 0) #include "R_ext/Altrep.h" +#define S2_GEOGRAPHY_ALTREP +#endif #include using namespace Rcpp; +// ALTREP implementation for s2_geography +#if defined(S2_GEOGRAPHY_ALTREP) R_altrep_class_t s2_geography_altrep_cls; -static SEXP get_s2_namespace_env() { - static SEXP env = NULL; +static R_xlen_t s2_altrep_Length(SEXP obj) { + SEXP data = R_altrep_data1(obj); + return Rf_xlength(data); +} +static SEXP s2_altrep_Elt(SEXP obj, R_xlen_t i) { + SEXP data = R_altrep_data1(obj); + return VECTOR_ELT(data, i); +} +static SEXP get_s2_namespace_env() { + static SEXP env = NULL; if (env == NULL) { env = R_FindNamespace(PROTECT(Rf_mkString("s2"))); @@ -21,39 +39,6 @@ static SEXP get_s2_namespace_env() { return env; } - - - - -// [[Rcpp::export]] -SEXP new_s2_geography(SEXP data) { - if (TYPEOF(data) != VECSXP) { - Rf_error("s2_geography data must be a list"); - } - - SEXP obj = PROTECT(R_new_altrep(s2_geography_altrep_cls, data, R_NilValue)); - - SEXP cls = PROTECT(Rf_allocVector(STRSXP, 2)); - SET_STRING_ELT(cls, 0, Rf_mkChar("s2_geography")); - SET_STRING_ELT(cls, 1, Rf_mkChar("wk_vctr")); - - Rf_setAttrib(obj, R_ClassSymbol, cls); - UNPROTECT(2); - - return obj; -} - -// ALTREP implementation for s2_geography -static R_INLINE R_xlen_t s2_altrep_Length(SEXP obj) { - SEXP data = R_altrep_data1(obj); - return Rf_xlength(data); -} - -static SEXP s2_altrep_Elt(SEXP obj, R_xlen_t i) { - SEXP data = R_altrep_data1(obj); - return VECTOR_ELT(data, i); -} - static SEXP s2_altrep_Serialized_state(SEXP obj) { // fetch the pointer to s2::s2_geography_serialize() SEXP env = get_s2_namespace_env(); @@ -77,13 +62,41 @@ static SEXP s2_altrep_Unserialize(SEXP cls, SEXP state) { UNPROTECT(1); return out; } +#endif + +// [[Rcpp::export]] +SEXP new_s2_geography(SEXP data) { + if (TYPEOF(data) != VECSXP) { + Rf_error("s2_geography data must be a list"); + } + +#if defined(S2_GEOGRAPHY_ALTREP) + SEXP obj = PROTECT(R_new_altrep(s2_geography_altrep_cls, data, R_NilValue)); +#else + SEXP obj = data; +#endif + + SEXP cls = PROTECT(Rf_allocVector(STRSXP, 2)); + SET_STRING_ELT(cls, 0, Rf_mkChar("s2_geography")); + SET_STRING_ELT(cls, 1, Rf_mkChar("wk_vctr")); + + Rf_setAttrib(obj, R_ClassSymbol, cls); +#if defined(S2_GEOGRAPHY_ALTREP) + UNPROTECT(2); +#else + UNPROTECT(1); +#endif + return obj; +} // [[Rcpp::init]] void altrep_init(DllInfo *dll) { +#if defined(S2_GEOGRAPHY_ALTREP) s2_geography_altrep_cls = R_make_altlist_class("s2_geography", "s2", dll); R_set_altrep_Length_method(s2_geography_altrep_cls, s2_altrep_Length); R_set_altlist_Elt_method(s2_geography_altrep_cls, s2_altrep_Elt); R_set_altrep_Serialized_state_method(s2_geography_altrep_cls, s2_altrep_Serialized_state); R_set_altrep_Unserialize_method(s2_geography_altrep_cls, s2_altrep_Unserialize); +#endif }; diff --git a/tests/testthat/helper-s2-serialization.R b/tests/testthat/helper-s2-serialization.R new file mode 100644 index 00000000..d44045c3 --- /dev/null +++ b/tests/testthat/helper-s2-serialization.R @@ -0,0 +1,7 @@ +skip_if_serialization_unsupported <- function(...) { + skip_if(getRversion() < "4.3.0") +} + +skip_if_serialization_supported <- function(...) { + skip_if(getRversion() >= "4.3.0") +} diff --git a/tests/testthat/test-s2-serialization.R b/tests/testthat/test-s2-serialization.R index d7fcc8b3..1b56acda 100644 --- a/tests/testthat/test-s2-serialization.R +++ b/tests/testthat/test-s2-serialization.R @@ -30,24 +30,43 @@ test_that("Serialization does not lose precision", { ) }) +test_that("null external pointers do not crash in the handler", { + skip_if_serialization_supported() + + geog <- as_s2_geography("POINT (0 1)") + geog2 <- unserialize(serialize(geog, NULL)) + expect_error( + wk::wk_void(geog2), + "External pointer is not valid" + ) +}) + # S2 Geography constructors test_that("s2_geography() can be correctly serialized", { + skip_if_serialization_unsupported() + expect_wkt_serializeable(s2_geography()) }) test_that("s2_geog_point() can be correctly serialized", { + skip_if_serialization_unsupported() + expect_wkt_serializeable(s2_geog_point( -64, 45 )) }) test_that("s2_make_line() can be correctly serialized", { + skip_if_serialization_unsupported() + expect_wkt_serializeable(s2_make_line( c(-64, 8), c(45, 71) )) }) test_that("s2_make_polygon() can be correctly serialized", { + skip_if_serialization_unsupported() + expect_wkt_serializeable(s2_make_polygon( c(-45, 8, 0), c(64, 71, 90) )) @@ -57,12 +76,16 @@ test_that("s2_make_polygon() can be correctly serialized", { }) test_that("s2_geog_from_wkt() can be correctly serialized", { + skip_if_serialization_unsupported() + expect_wkt_serializeable(s2_geog_from_text( "POINT (-64 45)" )) }) test_that("s2_geog_from_wkb() can be correctly serialized", { + skip_if_serialization_unsupported() + expect_wkt_serializeable(s2_geog_from_wkb( as_wkb("POINT (-64 45)") )) @@ -70,6 +93,8 @@ test_that("s2_geog_from_wkb() can be correctly serialized", { # Geography Transformations test_that("s2_union() can be correctly serialized", { + skip_if_serialization_unsupported() + expect_wkt_serializeable(s2_union( "POINT (10 30)", "POINT (30 10)" @@ -77,6 +102,8 @@ test_that("s2_union() can be correctly serialized", { }) test_that("s2_intersection() can be correctly serialized", { + skip_if_serialization_unsupported() + expect_wkt_serializeable(s2_intersection( "POLYGON ((0 0, 10 0, 10 10, 0 10, 0 0))", "POLYGON ((5 5, 15 5, 15 15, 5 15, 5 5))", @@ -85,6 +112,8 @@ test_that("s2_intersection() can be correctly serialized", { test_that("s2_difference() can be correctly serialized", { + skip_if_serialization_unsupported() + expect_wkt_serializeable(s2_difference( "POLYGON ((0 0, 10 0, 10 10, 0 10, 0 0))", "POLYGON ((5 5, 15 5, 15 15, 5 15, 5 5))", @@ -92,6 +121,8 @@ test_that("s2_difference() can be correctly serialized", { }) test_that("s2_sym_difference() can be correctly serialized", { + skip_if_serialization_unsupported() + expect_wkt_serializeable(s2_sym_difference( "POLYGON ((0 0, 10 0, 10 10, 0 10, 0 0))", "POLYGON ((5 5, 15 5, 15 15, 5 15, 5 5))", @@ -99,12 +130,16 @@ test_that("s2_sym_difference() can be correctly serialized", { }) test_that("s2_convex_hull() can be correctly serialized", { + skip_if_serialization_unsupported() + expect_wkt_serializeable(s2_convex_hull( "GEOMETRYCOLLECTION (POINT (-1 0), POINT (0 1), POINT (1 0))" )) }) test_that("s2_boundary() can be correctly serialized", { + skip_if_serialization_unsupported() + expect_wkt_serializeable(s2_boundary( "POLYGON ((0 0, 10 0, 10 10, 0 10, 0 0))" )) @@ -112,12 +147,16 @@ test_that("s2_boundary() can be correctly serialized", { test_that("s2_centroid() can be correctly serialized", { + skip_if_serialization_unsupported() + expect_wkt_serializeable(s2_centroid( "POLYGON ((0 0, 10 0, 10 10, 0 10, 0 0))" )) }) test_that("s2_closest_point() can be correctly serialized", { + skip_if_serialization_unsupported() + expect_wkt_serializeable(s2_closest_point( "POLYGON ((0 0, 10 0, 10 10, 0 10, 0 0))", "POINT (-63 46)" @@ -125,6 +164,8 @@ test_that("s2_closest_point() can be correctly serialized", { }) test_that("s2_minimum_clearance_line_between() can be correctly serialized", { + skip_if_serialization_unsupported() + expect_wkt_serializeable(s2_minimum_clearance_line_between( "POINT (10 30)", "POINT (30 10)" @@ -132,6 +173,8 @@ test_that("s2_minimum_clearance_line_between() can be correctly serialized", { }) test_that("s2_snap_to_grid() can be correctly serialized", { + skip_if_serialization_unsupported() + expect_wkt_serializeable(s2_snap_to_grid( "POINT (10.25 30.5)", 1 @@ -139,6 +182,8 @@ test_that("s2_snap_to_grid() can be correctly serialized", { }) test_that("s2_simplify() can be correctly serialized", { + skip_if_serialization_unsupported() + expect_wkt_serializeable(s2_simplify( "POLYGON ((0 0, 10 0, 10 10, 0 10, 0 0))", 1 @@ -146,18 +191,24 @@ test_that("s2_simplify() can be correctly serialized", { }) test_that("s2_rebuild() can be correctly serialized", { + skip_if_serialization_unsupported() + expect_wkt_serializeable(s2_rebuild( "POLYGON ((0 0, 10 0, 10 10, 0 10, 0 0))" )) }) test_that("s2_buffer_cells() can be correctly serialized", { + skip_if_serialization_unsupported() + expect_wkt_serializeable(s2_buffer_cells( "POINT (10 10)", 100 )) }) test_that("s2_centroid_agg() can be correctly serialized", { + skip_if_serialization_unsupported() + expect_wkt_serializeable(s2_centroid_agg(c( "POINT (-1 0)", "POINT (0 1)", @@ -166,6 +217,8 @@ test_that("s2_centroid_agg() can be correctly serialized", { }) test_that("s2_coverage_union_agg() can be correctly serialized", { + skip_if_serialization_unsupported() + expect_wkt_serializeable(s2_coverage_union_agg(c( "POINT (-1 0)", "POINT (0 1)", @@ -174,6 +227,8 @@ test_that("s2_coverage_union_agg() can be correctly serialized", { }) test_that("s2_rebuild_agg() can be correctly serialized", { + skip_if_serialization_unsupported() + expect_wkt_serializeable(s2_rebuild_agg(c( "POINT (-1 0)", "POINT (0 1)", @@ -182,6 +237,8 @@ test_that("s2_rebuild_agg() can be correctly serialized", { }) test_that("s2_union_agg() can be correctly serialized", { + skip_if_serialization_unsupported() + expect_wkt_serializeable(s2_union_agg(c( "POINT (-1 0)", "POINT (0 1)", @@ -190,6 +247,8 @@ test_that("s2_union_agg() can be correctly serialized", { }) test_that("s2_convex_hull_agg() can be correctly serialized", { + skip_if_serialization_unsupported() + expect_wkt_serializeable(s2_convex_hull_agg(c( "POINT (-1 0)", "POINT (0 1)", @@ -198,6 +257,8 @@ test_that("s2_convex_hull_agg() can be correctly serialized", { }) test_that("s2_point_on_surface() can be correctly serialized", { + skip_if_serialization_unsupported() + expect_wkt_serializeable(s2_point_on_surface( "POLYGON ((0 0, 10 0, 10 10, 0 10, 0 0))" )) @@ -205,17 +266,25 @@ test_that("s2_point_on_surface() can be correctly serialized", { # S2 cell operators that construct s2 geography test_that("s2_cell_center() can be correctly serialized", { + skip_if_serialization_unsupported() + expect_wkt_serializeable(s2_cell_center(s2_cell("5"))) }) test_that("s2_cell_boundary() can be correctly serialized", { + skip_if_serialization_unsupported() + expect_wkt_serializeable(s2_cell_boundary(s2_cell("5"))) }) test_that("s2_cell_polygon() can be correctly serialized", { + skip_if_serialization_unsupported() + expect_wkt_serializeable(s2_cell_polygon(s2_cell("5"))) }) test_that("s2_cell_vertex() can be correctly serialized", { + skip_if_serialization_unsupported() + expect_wkt_serializeable(s2_cell_vertex(s2_cell("5"), seq_len(4L))) }) From d7f286c5aee722bbd641e9bcb16d176796b7fed8 Mon Sep 17 00:00:00 2001 From: Taras Zakharko Date: Wed, 4 Jun 2025 18:50:33 +0200 Subject: [PATCH 05/13] Provide the option `s2.s2.disable_altrep` to turn off ALTREP for s2 geography --- src/s2-altrep.cpp | 34 +++++++++++++++----------- tests/testthat/test-s2-serialization.R | 15 ++++++++++++ 2 files changed, 35 insertions(+), 14 deletions(-) diff --git a/src/s2-altrep.cpp b/src/s2-altrep.cpp index c6e0bb7d..84d0d853 100644 --- a/src/s2-altrep.cpp +++ b/src/s2-altrep.cpp @@ -64,6 +64,21 @@ static SEXP s2_altrep_Unserialize(SEXP cls, SEXP state) { } #endif +static SEXP setting_s2_geography_class(SEXP x) { + // use callee protection here to simplify the caller code + x = PROTECT(x); + + SEXP cls = PROTECT(Rf_allocVector(STRSXP, 2)); + SET_STRING_ELT(cls, 0, Rf_mkChar("s2_geography")); + SET_STRING_ELT(cls, 1, Rf_mkChar("wk_vctr")); + + Rf_setAttrib(x, R_ClassSymbol, cls); + + UNPROTECT(2); + + return x; +} + // [[Rcpp::export]] SEXP new_s2_geography(SEXP data) { if (TYPEOF(data) != VECSXP) { @@ -71,22 +86,13 @@ SEXP new_s2_geography(SEXP data) { } #if defined(S2_GEOGRAPHY_ALTREP) - SEXP obj = PROTECT(R_new_altrep(s2_geography_altrep_cls, data, R_NilValue)); -#else - SEXP obj = data; + if (!R_isTRUE(Rf_GetOption1(Rf_install("s2.disable_altrep")))) { + // no protection is needed here since setting_s2_geography_class() protects its arguments + data = R_new_altrep(s2_geography_altrep_cls, data, R_NilValue); + } #endif - SEXP cls = PROTECT(Rf_allocVector(STRSXP, 2)); - SET_STRING_ELT(cls, 0, Rf_mkChar("s2_geography")); - SET_STRING_ELT(cls, 1, Rf_mkChar("wk_vctr")); - - Rf_setAttrib(obj, R_ClassSymbol, cls); -#if defined(S2_GEOGRAPHY_ALTREP) - UNPROTECT(2); -#else - UNPROTECT(1); -#endif - return obj; + return setting_s2_geography_class(data); } // [[Rcpp::init]] diff --git a/tests/testthat/test-s2-serialization.R b/tests/testthat/test-s2-serialization.R index 1b56acda..b8082d4f 100644 --- a/tests/testthat/test-s2-serialization.R +++ b/tests/testthat/test-s2-serialization.R @@ -41,6 +41,21 @@ test_that("null external pointers do not crash in the handler", { ) }) +test_that("ALTREP can be disabled", { + skip_if_serialization_unsupported() + on.exit(options(s2.disable_altrep = NULL)) + options(s2.disable_altrep = TRUE) + + geog <- as_s2_geography("POINT (0 1)") + geog2 <- unserialize(serialize(geog, NULL)) + expect_error( + wk::wk_void(geog2), + "External pointer is not valid" + ) + + options(s2.disable_altrep = NULL) +}) + # S2 Geography constructors test_that("s2_geography() can be correctly serialized", { skip_if_serialization_unsupported() From 5329e604f7106c81f7ea20f08aeb57fd1f349a76 Mon Sep 17 00:00:00 2001 From: Taras Zakharko Date: Tue, 10 Jun 2025 09:54:51 +0200 Subject: [PATCH 06/13] Restructured the C++ init code, which is now centrally invoked from init.cpp; implemented util.cpp/util.h which handles cached references. --- R/RcppExports.R | 4 ---- R/zzz.R | 3 --- src/Makevars.in | 1 + src/Makevars.win | 1 + src/RcppExports.cpp | 14 ++------------ src/geography.h | 1 + src/init.cpp | 13 +++++++++++-- src/s2-altrep.cpp | 40 +++++++++++----------------------------- src/s2-altrep.h | 18 ++++++++++++++++++ src/util.cpp | 17 +++++++++++++++++ src/util.h | 11 +++++++++++ 11 files changed, 73 insertions(+), 50 deletions(-) create mode 100644 src/s2-altrep.h create mode 100644 src/util.cpp create mode 100644 src/util.h diff --git a/R/RcppExports.R b/R/RcppExports.R index 4d17f0f9..f80646f3 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -1,10 +1,6 @@ # Generated by using Rcpp::compileAttributes() -> do not edit by hand # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 -cpp_s2_init <- function() { - invisible(.Call(`_s2_cpp_s2_init`)) -} - cpp_s2_is_collection <- function(geog) { .Call(`_s2_cpp_s2_is_collection`, geog) } diff --git a/R/zzz.R b/R/zzz.R index a06930ad..2efb3251 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -1,9 +1,6 @@ # nocov start .onLoad <- function(...) { - # call c++ init - cpp_s2_init() - # dynamically register vctrs dependencies for (cls in c("s2_geography", "s2_cell", "s2_cell_union")) { s3_register("vctrs::vec_proxy", cls) diff --git a/src/Makevars.in b/src/Makevars.in index 43a1c731..b4406645 100644 --- a/src/Makevars.in +++ b/src/Makevars.in @@ -115,6 +115,7 @@ OBJECTS = cpp-compat.o \ s2-predicates.o \ s2-transformers.o \ init.o \ + util.o \ RcppExports.o \ s2-geography.o \ s2-lnglat.o \ diff --git a/src/Makevars.win b/src/Makevars.win index c8f49084..c4fdd3ea 100644 --- a/src/Makevars.win +++ b/src/Makevars.win @@ -136,6 +136,7 @@ OBJECTS = s2/encoded_s2cell_id_vector.o \ s2-predicates.o \ s2-transformers.o \ init.o \ + util.o \ RcppExports.o \ s2-geography.o \ s2-lnglat.o \ diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index c2088603..42b01004 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -10,15 +10,6 @@ Rcpp::Rostream& Rcpp::Rcout = Rcpp::Rcpp_cout_get(); Rcpp::Rostream& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get(); #endif -// cpp_s2_init -void cpp_s2_init(); -RcppExport SEXP _s2_cpp_s2_init() { -BEGIN_RCPP - Rcpp::RNGScope rcpp_rngScope_gen; - cpp_s2_init(); - return R_NilValue; -END_RCPP -} // cpp_s2_is_collection LogicalVector cpp_s2_is_collection(List geog); RcppExport SEXP _s2_cpp_s2_is_collection(SEXP geogSEXP) { @@ -1365,7 +1356,6 @@ RcppExport SEXP c_s2_trans_s2_lnglat_new(void); RcppExport SEXP c_s2_trans_s2_point_new(void); static const R_CallMethodDef CallEntries[] = { - {"_s2_cpp_s2_init", (DL_FUNC) &_s2_cpp_s2_init, 0}, {"_s2_cpp_s2_is_collection", (DL_FUNC) &_s2_cpp_s2_is_collection, 1}, {"_s2_cpp_s2_is_valid", (DL_FUNC) &_s2_cpp_s2_is_valid, 1}, {"_s2_cpp_s2_is_valid_reason", (DL_FUNC) &_s2_cpp_s2_is_valid_reason, 1}, @@ -1488,9 +1478,9 @@ static const R_CallMethodDef CallEntries[] = { {NULL, NULL, 0} }; -void altrep_init(DllInfo *dll); +void cpp_s2_init(DllInfo *dll); RcppExport void R_init_s2(DllInfo *dll) { R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); R_useDynamicSymbols(dll, FALSE); - altrep_init(dll); + cpp_s2_init(dll); } diff --git a/src/geography.h b/src/geography.h index 4f51a528..a75f14cf 100644 --- a/src/geography.h +++ b/src/geography.h @@ -5,6 +5,7 @@ #include #include "s2geography.h" +#include "s2-altrep.h" SEXP new_s2_geography(SEXP data); diff --git a/src/init.cpp b/src/init.cpp index bc3a057a..b1810390 100644 --- a/src/init.cpp +++ b/src/init.cpp @@ -2,10 +2,19 @@ #include "absl/log/log.h" #include "s2/s2debug.h" #include +#include "s2-altrep.h" +#include "util.h" + using namespace Rcpp; -// [[Rcpp::export]] -void cpp_s2_init() { +// [[Rcpp::init]] +void cpp_s2_init(DllInfo *dll) { + // init the altrep classes + s2_init_altrep(dll); + + // init the global sexp cache + s2_init_cached_sexps(); + // It's important to set this flag, as users might have "debug" flags // for their build environment, and there are some checks that will terminate // R instead of throw an exception if this value is set to true. diff --git a/src/s2-altrep.cpp b/src/s2-altrep.cpp index 84d0d853..492e9f1d 100644 --- a/src/s2-altrep.cpp +++ b/src/s2-altrep.cpp @@ -3,21 +3,15 @@ #include #include -// ALTREP VECSXP are supported starting from R 4.3.0 -// -// When compiling for an earlier target serialization support is disabled -#if defined(R_VERSION) && R_VERSION >= R_Version(4, 3, 0) -#include "R_ext/Altrep.h" -#define S2_GEOGRAPHY_ALTREP -#endif - -#include -using namespace Rcpp; +#include "s2-altrep.h" +#include "util.h" // ALTREP implementation for s2_geography #if defined(S2_GEOGRAPHY_ALTREP) +#include "R_ext/Altrep.h" R_altrep_class_t s2_geography_altrep_cls; + static R_xlen_t s2_altrep_Length(SEXP obj) { SEXP data = R_altrep_data1(obj); return Rf_xlength(data); @@ -28,24 +22,13 @@ static SEXP s2_altrep_Elt(SEXP obj, R_xlen_t i) { return VECTOR_ELT(data, i); } -static SEXP get_s2_namespace_env() { - static SEXP env = NULL; - - if (env == NULL) { - env = R_FindNamespace(PROTECT(Rf_mkString("s2"))); - UNPROTECT(1); - } - - return env; -} static SEXP s2_altrep_Serialized_state(SEXP obj) { // fetch the pointer to s2::s2_geography_serialize() - SEXP env = get_s2_namespace_env(); - SEXP fn = Rf_findFun(Rf_install("s2_geography_serialize"), env); + SEXP fn = Rf_findFun(Rf_install("s2_geography_serialize"), s2_ns_pkg); SEXP call = PROTECT(Rf_lang2(fn, obj)); - SEXP out = Rf_eval(call, env); + SEXP out = Rf_eval(call, s2_ns_pkg); UNPROTECT(1); return out; @@ -53,16 +36,15 @@ static SEXP s2_altrep_Serialized_state(SEXP obj) { static SEXP s2_altrep_Unserialize(SEXP cls, SEXP state) { // fetch the pointer to s2::s2_geography_unserialize() - SEXP env = get_s2_namespace_env(); - SEXP fn = Rf_findFun(Rf_install("s2_geography_unserialize"), env); + SEXP fn = Rf_findFun(Rf_install("s2_geography_unserialize"), s2_ns_pkg); SEXP call = PROTECT(Rf_lang2(fn, state)); - SEXP out = Rf_eval(call, env); + SEXP out = Rf_eval(call, s2_ns_pkg); UNPROTECT(1); return out; } -#endif + static SEXP setting_s2_geography_class(SEXP x) { // use callee protection here to simplify the caller code @@ -95,8 +77,7 @@ SEXP new_s2_geography(SEXP data) { return setting_s2_geography_class(data); } -// [[Rcpp::init]] -void altrep_init(DllInfo *dll) { +void s2_init_altrep(DllInfo *dll) { #if defined(S2_GEOGRAPHY_ALTREP) s2_geography_altrep_cls = R_make_altlist_class("s2_geography", "s2", dll); @@ -106,3 +87,4 @@ void altrep_init(DllInfo *dll) { R_set_altrep_Unserialize_method(s2_geography_altrep_cls, s2_altrep_Unserialize); #endif }; +#endif diff --git a/src/s2-altrep.h b/src/s2-altrep.h new file mode 100644 index 00000000..e2a74b06 --- /dev/null +++ b/src/s2-altrep.h @@ -0,0 +1,18 @@ +#ifndef S2_ALTREP_H +#define S2_ALTREP_H + +#include +#include + +// ALTREP VECSXP are supported starting from R 4.3.0 +// +// When compiling for an earlier target serialization support is disabled +#if defined(R_VERSION) && R_VERSION >= R_Version(4, 3, 0) +#define S2_GEOGRAPHY_ALTREP +#endif + +// Utility functions are always declared, but might be no-ops on unsupported platforms +SEXP make_s2_geography_altrep(SEXP list); +void s2_init_altrep(DllInfo *dll); + +#endif diff --git a/src/util.cpp b/src/util.cpp new file mode 100644 index 00000000..aced128d --- /dev/null +++ b/src/util.cpp @@ -0,0 +1,17 @@ +#define R_NO_REMAP +#include +#include + +#include "util.h" + +SEXP s2_ns_pkg = NULL; + +void s2_init_cached_sexps(void) { + // package namespace environment + s2_ns_pkg = PROTECT(R_FindNamespace(PROTECT(Rf_mkString("nanoarrow")))); + + // mark the cached objects as in use to prevent deallocation + R_PreserveObject(s2_ns_pkg); + + UNPROTECT(2); +} diff --git a/src/util.h b/src/util.h new file mode 100644 index 00000000..5ba3062e --- /dev/null +++ b/src/util.h @@ -0,0 +1,11 @@ +#ifndef UTIL_H +#define UTIL_H + +#include +#include + +extern SEXP s2_ns_pkg; + +void s2_init_cached_sexps(void); + +#endif From da5e6bc4f5256546262e01851817e3dcc474c11a Mon Sep 17 00:00:00 2001 From: Taras Zakharko Date: Tue, 10 Jun 2025 10:43:18 +0200 Subject: [PATCH 07/13] Move new_s2_geography() back to R, make sure that all constructors use it --- R/RcppExports.R | 4 +- R/plot.R | 4 +- R/s2-cell.R | 8 ++-- R/s2-constructors-formatters.R | 73 +++++++++++++++++------------- R/s2-geography.R | 26 ++++++++--- R/s2-serialize.R | 14 +++--- src/RcppExports.cpp | 18 ++++---- src/geography.h | 2 - src/s2-altrep.cpp | 39 ++++------------ src/s2-altrep.h | 2 - src/s2-cell.cpp | 12 ++--- src/s2-constructors-formatters.cpp | 2 +- tests/testthat/test-wk-utils.R | 72 ++++++++++++++--------------- 13 files changed, 137 insertions(+), 139 deletions(-) diff --git a/R/RcppExports.R b/R/RcppExports.R index f80646f3..b78450fa 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -57,8 +57,8 @@ cpp_s2_max_distance <- function(geog1, geog2) { .Call(`_s2_cpp_s2_max_distance`, geog1, geog2) } -new_s2_geography <- function(data) { - .Call(`_s2_new_s2_geography`, data) +make_s2_geography_altrep <- function(list) { + .Call(`_s2_make_s2_geography_altrep`, list) } cpp_s2_bounds_cap <- function(geog) { diff --git a/R/plot.R b/R/plot.R index 01172632..38065217 100644 --- a/R/plot.R +++ b/R/plot.R @@ -145,12 +145,12 @@ cap_to_polygon <- function(centre = s2_lnglat(0, 0), radius_rad) { c(0, rad_proj, 0, -rad_proj, 0), c(rad_proj, 0, -rad_proj, 0, rad_proj) ) - points_s2 <- wk::wk_handle( + points_s2 <- new_s2_geography(wk::wk_handle( points, s2_geography_writer( projection = s2_projection_orthographic(centre) ) - ) + )) s2_make_polygon(s2_x(points_s2), s2_y(points_s2)) } diff --git a/R/s2-cell.R b/R/s2-cell.R index f7134699..bcd2e1b0 100644 --- a/R/s2-cell.R +++ b/R/s2-cell.R @@ -222,26 +222,26 @@ s2_cell_to_lnglat <- function(x) { #' @rdname s2_cell_is_valid #' @export s2_cell_center <- function(x) { - cpp_s2_cell_center(x) + new_s2_geography(cpp_s2_cell_center(x)) } #' @rdname s2_cell_is_valid #' @export s2_cell_boundary <- function(x) { - s2_boundary(cpp_s2_cell_polygon(x)) + s2_boundary(new_s2_geography(cpp_s2_cell_polygon(x))) } #' @rdname s2_cell_is_valid #' @export s2_cell_polygon <- function(x) { - cpp_s2_cell_polygon(x) + new_s2_geography(cpp_s2_cell_polygon(x)) } #' @rdname s2_cell_is_valid #' @export s2_cell_vertex <- function(x, k) { recycled <- recycle_common(x, k) - cpp_s2_cell_vertex(recycled[[1]], recycled[[2]]) + new_s2_geography(cpp_s2_cell_vertex(recycled[[1]], recycled[[2]])) } # accessors diff --git a/R/s2-constructors-formatters.R b/R/s2-constructors-formatters.R index e76501d3..79581e0e 100644 --- a/R/s2-constructors-formatters.R +++ b/R/s2-constructors-formatters.R @@ -91,17 +91,19 @@ #' ) #' s2_geog_point <- function(longitude, latitude) { - wk::wk_handle(wk::xy(longitude, latitude), s2_geography_writer()) + new_s2_geography(wk::wk_handle(wk::xy(longitude, latitude), s2_geography_writer())) } #' @rdname s2_geog_point #' @export s2_make_line <- function(longitude, latitude, feature_id = 1L) { - wk::wk_handle( - wk::xy(longitude, latitude), - wk::wk_linestring_filter( - s2_geography_writer(), - feature_id = as.integer(feature_id) + new_s2_geography( + wk::wk_handle( + wk::xy(longitude, latitude), + wk::wk_linestring_filter( + s2_geography_writer(), + feature_id = as.integer(feature_id) + ) ) ) } @@ -110,12 +112,14 @@ s2_make_line <- function(longitude, latitude, feature_id = 1L) { #' @export s2_make_polygon <- function(longitude, latitude, feature_id = 1L, ring_id = 1L, oriented = FALSE, check = TRUE) { - wk::wk_handle( - wk::xy(longitude, latitude), - wk::wk_polygon_filter( - s2_geography_writer(oriented = oriented, check = check), - feature_id = as.integer(feature_id), - ring_id = as.integer(ring_id) + new_s2_geography( + wk::wk_handle( + wk::xy(longitude, latitude), + wk::wk_polygon_filter( + s2_geography_writer(oriented = oriented, check = check), + feature_id = as.integer(feature_id), + ring_id = as.integer(ring_id) + ) ) ) } @@ -129,16 +133,18 @@ s2_geog_from_text <- function(wkt_string, oriented = FALSE, check = TRUE, wkt <- wk::new_wk_wkt(wkt_string, geodesic = TRUE) wk::validate_wk_wkt(wkt) - wk::wk_handle( - wkt, - s2_geography_writer( - oriented = oriented, - check = check, - tessellate_tol = if (planar) { - tessellate_tol_m / s2_earth_radius_meters() - } else { - Inf - } + new_s2_geography( + wk::wk_handle( + wkt, + s2_geography_writer( + oriented = oriented, + check = check, + tessellate_tol = if (planar) { + tessellate_tol_m / s2_earth_radius_meters() + } else { + Inf + } + ) ) ) } @@ -151,16 +157,19 @@ s2_geog_from_wkb <- function(wkb_bytes, oriented = FALSE, check = TRUE, attributes(wkb_bytes) <- NULL wkb <- wk::new_wk_wkb(wkb_bytes) wk::validate_wk_wkb(wkb) - wk::wk_handle( - wkb, - s2_geography_writer( - oriented = oriented, - check = check, - tessellate_tol = if (planar) { - tessellate_tol_m / s2_earth_radius_meters() - } else { - Inf - } + + new_s2_geography( + wk::wk_handle( + wkb, + s2_geography_writer( + oriented = oriented, + check = check, + tessellate_tol = if (planar) { + tessellate_tol_m / s2_earth_radius_meters() + } else { + Inf + } + ) ) ) } diff --git a/R/s2-geography.R b/R/s2-geography.R index f5b36a52..3cc3a943 100644 --- a/R/s2-geography.R +++ b/R/s2-geography.R @@ -71,9 +71,11 @@ as_s2_geography.wk_wkb <- function(x, ..., oriented = FALSE, check = TRUE) { } } - wk::wk_handle( - x, - s2_geography_writer(oriented = oriented, check = check) + new_s2_geography( + wk::wk_handle( + x, + s2_geography_writer(oriented = oriented, check = check) + ) ) } @@ -108,9 +110,11 @@ as_s2_geography.wk_wkt <- function(x, ..., oriented = FALSE, check = TRUE) { } } - wk::wk_handle( - x, - s2_geography_writer(oriented = oriented, check = check) + new_s2_geography( + wk::wk_handle( + x, + s2_geography_writer(oriented = oriented, check = check) + ) ) } @@ -179,6 +183,16 @@ wk_set_geodesic.s2_geography <- function(x, geodesic) { x } +new_s2_geography <- function(x) { + # set the ALTREP class + if (!isTRUE(getOption("s2.disable_altrep"))) { + x <- make_s2_geography_altrep(x) + } + # set the s2_geography class + class(x) <- c("s2_geography", "wk_vctr") + + x +} #' @export is.na.s2_geography <- function(x) { diff --git a/R/s2-serialize.R b/R/s2-serialize.R index 92b29d31..f48f50a7 100644 --- a/R/s2-serialize.R +++ b/R/s2-serialize.R @@ -7,12 +7,14 @@ s2_geography_serialize <- function(x) { } s2_geography_unserialize <- function(bytes) { - wk::wk_handle( - bytes, - s2::s2_geography_writer( - oriented = TRUE, - check = FALSE, - projection = NULL + new_s2_geography( + wk::wk_handle( + bytes, + s2::s2_geography_writer( + oriented = TRUE, + check = FALSE, + projection = NULL + ) ) ) } diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index 42b01004..042bc088 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -167,14 +167,14 @@ BEGIN_RCPP return rcpp_result_gen; END_RCPP } -// new_s2_geography -SEXP new_s2_geography(SEXP data); -RcppExport SEXP _s2_new_s2_geography(SEXP dataSEXP) { +// make_s2_geography_altrep +SEXP make_s2_geography_altrep(SEXP list); +RcppExport SEXP _s2_make_s2_geography_altrep(SEXP listSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< SEXP >::type data(dataSEXP); - rcpp_result_gen = Rcpp::wrap(new_s2_geography(data)); + Rcpp::traits::input_parameter< SEXP >::type list(listSEXP); + rcpp_result_gen = Rcpp::wrap(make_s2_geography_altrep(list)); return rcpp_result_gen; END_RCPP } @@ -472,7 +472,7 @@ BEGIN_RCPP END_RCPP } // cpp_s2_cell_center -SEXP cpp_s2_cell_center(NumericVector cellIdVector); +List cpp_s2_cell_center(NumericVector cellIdVector); RcppExport SEXP _s2_cpp_s2_cell_center(SEXP cellIdVectorSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; @@ -483,7 +483,7 @@ BEGIN_RCPP END_RCPP } // cpp_s2_cell_polygon -SEXP cpp_s2_cell_polygon(NumericVector cellIdVector); +List cpp_s2_cell_polygon(NumericVector cellIdVector); RcppExport SEXP _s2_cpp_s2_cell_polygon(SEXP cellIdVectorSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; @@ -494,7 +494,7 @@ BEGIN_RCPP END_RCPP } // cpp_s2_cell_vertex -SEXP cpp_s2_cell_vertex(NumericVector cellIdVector, IntegerVector k); +List cpp_s2_cell_vertex(NumericVector cellIdVector, IntegerVector k); RcppExport SEXP _s2_cpp_s2_cell_vertex(SEXP cellIdVectorSEXP, SEXP kSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; @@ -1370,7 +1370,7 @@ static const R_CallMethodDef CallEntries[] = { {"_s2_cpp_s2_project_normalized", (DL_FUNC) &_s2_cpp_s2_project_normalized, 2}, {"_s2_cpp_s2_distance", (DL_FUNC) &_s2_cpp_s2_distance, 2}, {"_s2_cpp_s2_max_distance", (DL_FUNC) &_s2_cpp_s2_max_distance, 2}, - {"_s2_new_s2_geography", (DL_FUNC) &_s2_new_s2_geography, 1}, + {"_s2_make_s2_geography_altrep", (DL_FUNC) &_s2_make_s2_geography_altrep, 1}, {"_s2_cpp_s2_bounds_cap", (DL_FUNC) &_s2_cpp_s2_bounds_cap, 1}, {"_s2_cpp_s2_bounds_rect", (DL_FUNC) &_s2_cpp_s2_bounds_rect, 1}, {"_s2_cpp_s2_cell_union_normalize", (DL_FUNC) &_s2_cpp_s2_cell_union_normalize, 1}, diff --git a/src/geography.h b/src/geography.h index a75f14cf..837f11b3 100644 --- a/src/geography.h +++ b/src/geography.h @@ -7,8 +7,6 @@ #include "s2geography.h" #include "s2-altrep.h" -SEXP new_s2_geography(SEXP data); - class RGeography { public: RGeography(std::unique_ptr geog): diff --git a/src/s2-altrep.cpp b/src/s2-altrep.cpp index 492e9f1d..e564de69 100644 --- a/src/s2-altrep.cpp +++ b/src/s2-altrep.cpp @@ -7,11 +7,11 @@ #include "util.h" // ALTREP implementation for s2_geography + #if defined(S2_GEOGRAPHY_ALTREP) #include "R_ext/Altrep.h" R_altrep_class_t s2_geography_altrep_cls; - static R_xlen_t s2_altrep_Length(SEXP obj) { SEXP data = R_altrep_data1(obj); return Rf_xlength(data); @@ -22,7 +22,6 @@ static SEXP s2_altrep_Elt(SEXP obj, R_xlen_t i) { return VECTOR_ELT(data, i); } - static SEXP s2_altrep_Serialized_state(SEXP obj) { // fetch the pointer to s2::s2_geography_serialize() SEXP fn = Rf_findFun(Rf_install("s2_geography_serialize"), s2_ns_pkg); @@ -44,37 +43,16 @@ static SEXP s2_altrep_Unserialize(SEXP cls, SEXP state) { UNPROTECT(1); return out; } - - -static SEXP setting_s2_geography_class(SEXP x) { - // use callee protection here to simplify the caller code - x = PROTECT(x); - - SEXP cls = PROTECT(Rf_allocVector(STRSXP, 2)); - SET_STRING_ELT(cls, 0, Rf_mkChar("s2_geography")); - SET_STRING_ELT(cls, 1, Rf_mkChar("wk_vctr")); - - Rf_setAttrib(x, R_ClassSymbol, cls); - - UNPROTECT(2); - - return x; -} +#endif // [[Rcpp::export]] -SEXP new_s2_geography(SEXP data) { - if (TYPEOF(data) != VECSXP) { - Rf_error("s2_geography data must be a list"); - } - +SEXP make_s2_geography_altrep(SEXP list) { #if defined(S2_GEOGRAPHY_ALTREP) - if (!R_isTRUE(Rf_GetOption1(Rf_install("s2.disable_altrep")))) { - // no protection is needed here since setting_s2_geography_class() protects its arguments - data = R_new_altrep(s2_geography_altrep_cls, data, R_NilValue); - } + return R_new_altrep(s2_geography_altrep_cls, list, R_NilValue); +#else + // nothing to do + return list; #endif - - return setting_s2_geography_class(data); } void s2_init_altrep(DllInfo *dll) { @@ -86,5 +64,4 @@ void s2_init_altrep(DllInfo *dll) { R_set_altrep_Serialized_state_method(s2_geography_altrep_cls, s2_altrep_Serialized_state); R_set_altrep_Unserialize_method(s2_geography_altrep_cls, s2_altrep_Unserialize); #endif -}; -#endif +} diff --git a/src/s2-altrep.h b/src/s2-altrep.h index e2a74b06..7f926c60 100644 --- a/src/s2-altrep.h +++ b/src/s2-altrep.h @@ -11,8 +11,6 @@ #define S2_GEOGRAPHY_ALTREP #endif -// Utility functions are always declared, but might be no-ops on unsupported platforms -SEXP make_s2_geography_altrep(SEXP list); void s2_init_altrep(DllInfo *dll); #endif diff --git a/src/s2-cell.cpp b/src/s2-cell.cpp index 16a423aa..8b1fa48c 100644 --- a/src/s2-cell.cpp +++ b/src/s2-cell.cpp @@ -350,7 +350,7 @@ LogicalVector cpp_s2_cell_is_valid(NumericVector cellIdVector) { } // [[Rcpp::export]] -SEXP cpp_s2_cell_center(NumericVector cellIdVector) { +List cpp_s2_cell_center(NumericVector cellIdVector) { class Op: public UnaryS2CellOperator { SEXP processCell(S2CellId cellId, R_xlen_t i) { if (cellId.is_valid()) { @@ -363,11 +363,11 @@ SEXP cpp_s2_cell_center(NumericVector cellIdVector) { Op op; List result = op.processVector(cellIdVector); - return new_s2_geography(result); + return result; } // [[Rcpp::export]] -SEXP cpp_s2_cell_polygon(NumericVector cellIdVector) { +List cpp_s2_cell_polygon(NumericVector cellIdVector) { class Op: public UnaryS2CellOperator { SEXP processCell(S2CellId cellId, R_xlen_t i) { if (cellId.is_valid()) { @@ -381,11 +381,11 @@ SEXP cpp_s2_cell_polygon(NumericVector cellIdVector) { Op op; List result = op.processVector(cellIdVector); - return new_s2_geography(result); + return result; } // [[Rcpp::export]] -SEXP cpp_s2_cell_vertex(NumericVector cellIdVector, IntegerVector k) { +List cpp_s2_cell_vertex(NumericVector cellIdVector, IntegerVector k) { class Op: public UnaryS2CellOperator { SEXP processCell(S2CellId cellId, R_xlen_t i) { if (cellId.is_valid() && (this->k[i] >= 0)) { @@ -402,7 +402,7 @@ SEXP cpp_s2_cell_vertex(NumericVector cellIdVector, IntegerVector k) { Op op; op.k = k; List result = op.processVector(cellIdVector); - return new_s2_geography(result); + return result; } // [[Rcpp::export]] diff --git a/src/s2-constructors-formatters.cpp b/src/s2-constructors-formatters.cpp index 7fdb89b8..3cc49833 100644 --- a/src/s2-constructors-formatters.cpp +++ b/src/s2-constructors-formatters.cpp @@ -110,7 +110,7 @@ SEXP builder_vector_end(const wk_vector_meta_t* meta, void* handler_data) { builder_handler_t* data = (builder_handler_t*) handler_data; builder_result_finalize(data); - return new_s2_geography(data->result); + return data->result; } int builder_feature_start(const wk_vector_meta_t* meta, R_xlen_t feat_id, void* handler_data) { diff --git a/tests/testthat/test-wk-utils.R b/tests/testthat/test-wk-utils.R index 36a2e48e..c0cdda5b 100644 --- a/tests/testthat/test-wk-utils.R +++ b/tests/testthat/test-wk-utils.R @@ -1,15 +1,15 @@ test_that("wk_handle() for s2_geography works", { for (name in names(s2_data_example_wkt)) { - geog <- wk::wk_handle( + geog <- new_s2_geography(wk::wk_handle( s2_data_example_wkt[[name]], s2_geography_writer() - ) + )) - geog2 <- wk::wk_handle( + geog2 <- new_s2_geography(wk::wk_handle( geog, s2_geography_writer(check = TRUE, oriented = TRUE) - ) + )) expect_equal(wk::wk_coords(geog), wk::wk_coords(geog2)) } @@ -17,12 +17,12 @@ test_that("wk_handle() for s2_geography works", { test_that("wk_handle() for s2_geography works for s2_point projection", { for (name in names(s2_data_example_wkt)) { - geog <- wk::wk_handle( + geog <- new_s2_geography(wk::wk_handle( s2_data_example_wkt[[name]], s2_geography_writer() - ) + )) - geog2 <- wk::wk_handle( + geog2 <- new_s2_geography(wk::wk_handle( geog, s2_geography_writer( check = TRUE, @@ -30,7 +30,7 @@ test_that("wk_handle() for s2_geography works for s2_point projection", { projection = NULL ), s2_projection = NULL - ) + )) expect_identical(wk::wk_coords(geog), wk::wk_coords(geog2)) } @@ -43,10 +43,10 @@ test_that("wk_writer() works for s2_geography()", { test_that("the s2_geography_writer() works for example WKT", { # nc has some rings that get reordered by this operation for (name in setdiff(names(s2_data_example_wkt), "nc")) { - geog <- wk::wk_handle( + geog <- new_s2_geography(wk::wk_handle( s2_data_example_wkt[[name]], s2_geography_writer() - ) + )) expect_equal( wk::wk_coords(as_wkt(geog))[c("x", "y")], @@ -57,13 +57,13 @@ test_that("the s2_geography_writer() works for example WKT", { test_that("wk_handle() works for example WKT", { for (name in names(s2_data_example_wkt)) { - geog <- wk::wk_handle( + geog <- new_s2_geography(wk::wk_handle( s2_data_example_wkt[[name]], s2_geography_writer() - ) + )) expect_wkt_equal( - wk_handle(geog, s2_geography_writer()), + new_s2_geography(wk_handle(geog, s2_geography_writer())), geog, precision = 14 ) @@ -72,14 +72,14 @@ test_that("wk_handle() works for example WKT", { test_that("wk_handle() works for example WKT with tessellation", { for (name in names(s2_data_example_wkt)) { - geog <- wk::wk_handle( + geog <- new_s2_geography(wk::wk_handle( s2_data_example_wkt[[name]], s2_geography_writer() - ) + )) expect_wkt_equal( # use a big but non-infinite number to trigger the tessellator - wk_handle(geog, s2_geography_writer(), s2_tessellate_tol = 1e10), + new_s2_geography(wk_handle(geog, s2_geography_writer(), s2_tessellate_tol = 1e10)), geog, precision = 14 ) @@ -109,28 +109,28 @@ test_that("s2_geography_writer() with tesselate_tol works", { expect_equal( wk::as_xy( - wk::wk_handle( + new_s2_geography(wk::wk_handle( wk::xy(0, 0), s2_geography_writer(tessellate_tol = tol) - ) + )) ), wk::xy(0, 0, crs = wk::wk_crs_longlat()) ) expect_identical( - wk::wk_handle( + new_s2_geography(wk::wk_handle( wk::wkt("LINESTRING (0 0, 0 45, -60 45)"), s2_geography_writer(tessellate_tol = tol) - ) %>% + )) %>% s2_num_points(), 6L ) expect_identical( - wk::wk_handle( + new_s2_geography(wk::wk_handle( wk::wkt("POLYGON ((0 0, 0 45, -60 45, 0 0))"), s2_geography_writer(tessellate_tol = tol) - ) %>% + )) %>% s2_num_points(), 8L ) @@ -139,10 +139,10 @@ test_that("s2_geography_writer() with tesselate_tol works", { test_that("s2_geography_writer() with tesselate_tol works with real data", { tol <- 1000 / s2_earth_radius_meters() - countries_tes <- wk::wk_handle( + countries_tes <- new_s2_geography(wk::wk_handle( s2::s2_data_tbl_countries$geometry, s2_geography_writer(tessellate_tol = tol) - ) + )) expect_true( sum(s2_num_points(countries_tes)) > @@ -163,21 +163,21 @@ test_that("wk_handle + tessellate_tol works", { ) expect_identical( - wk::wk_handle( + new_s2_geography( wk::wk_handle( as_s2_geography("LINESTRING (0 0, 0 45, -60 45)"), s2_geography_writer(), s2_tessellate_tol = tol - ) %>% + )) %>% s2_num_points(), 6L ) expect_identical( - wk::wk_handle( + new_s2_geography(wk::wk_handle( as_s2_geography("POLYGON ((0 0, 0 45, -60 45, 0 0))"), s2_geography_writer(), s2_tessellate_tol = tol - ) %>% + )) %>% s2_num_points(), 8L ) @@ -187,11 +187,11 @@ test_that("s2_geography_writer() with tesselate_tol works with real data", { tol <- 1000 / s2_earth_radius_meters() countries <- s2_data_countries() - countries_tes <- wk::wk_handle( + countries_tes <- new_s2_geography(wk::wk_handle( countries, s2_geography_writer(check = FALSE), s2_tessellate_tol = tol - ) + )) expect_true( sum(s2_num_points(countries_tes)) > @@ -201,10 +201,10 @@ test_that("s2_geography_writer() with tesselate_tol works with real data", { test_that("wk_handle() for s2_geography works with s2_projection_mercator()", { # sf::sf_project("EPSG:4326", "EPSG:3857", wk::xy(30, 10)) %>% dput() - geog <- wk::wk_handle( + geog <- new_s2_geography(wk::wk_handle( wk::xy(3339584.72379821, 1118889.97485796), s2_geography_writer(projection = s2_projection_mercator()) - ) + )) expect_equal( wk::wk_handle( @@ -230,11 +230,11 @@ test_that("s2_geography_writer() works with s2_projection_mercator()", { # sf::sf_project("EPSG:4326", "EPSG:3857", wk::xy(30, 10)) %>% dput() expect_equal( wk::as_xy( - wk::wk_handle( + new_s2_geography(wk::wk_handle( wk::xy(3339584.72379821, 1118889.97485796), s2_geography_writer(projection = s2_projection_mercator()) ) - ), + )), wk::xy(30, 10, crs = wk::wk_crs_longlat()) ) }) @@ -281,10 +281,10 @@ test_that("s2_geography_writer() works with s2_projection_mercator()", { c(0, sqrt(2) / 2, 0) ) - geog <- wk::wk_handle( + geog <- new_s2_geography(wk::wk_handle( xy, s2_geography_writer(projection = s2_projection_orthographic()) - ) + )) expect_identical( s2_as_text(geog, precision = 5), c("POINT (0 0)", "POINT (0 45)", "POINT (45 0)") From 0f42347417571bcae24407cfeb0c3e190c886369 Mon Sep 17 00:00:00 2001 From: Taras Zakharko Date: Thu, 19 Jun 2025 10:27:27 +0200 Subject: [PATCH 08/13] Fixed the copy-paste typo in package namespace caching code --- src/util.cpp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/util.cpp b/src/util.cpp index aced128d..d453ccb2 100644 --- a/src/util.cpp +++ b/src/util.cpp @@ -8,7 +8,7 @@ SEXP s2_ns_pkg = NULL; void s2_init_cached_sexps(void) { // package namespace environment - s2_ns_pkg = PROTECT(R_FindNamespace(PROTECT(Rf_mkString("nanoarrow")))); + s2_ns_pkg = PROTECT(R_FindNamespace(PROTECT(Rf_mkString("s2")))); // mark the cached objects as in use to prevent deallocation R_PreserveObject(s2_ns_pkg); From bccd9d904af774086998f2ea8a309864943ed93b Mon Sep 17 00:00:00 2001 From: Taras Zakharko Date: Thu, 19 Jun 2025 10:59:10 +0200 Subject: [PATCH 09/13] Creation of s2_geography object using wk_handle moved back to geography writer and `builder_vector_end()` using builder handler data to pass the ALTREP option --- R/plot.R | 4 +- R/s2-constructors-formatters.R | 72 +++++++++++++----------------- R/s2-geography.R | 16 +++---- R/s2-serialize.R | 14 +++--- R/wk-utils.R | 6 ++- src/RcppExports.cpp | 4 +- src/s2-altrep.h | 1 + src/s2-constructors-formatters.cpp | 18 +++++++- tests/testthat/test-wk-utils.R | 72 +++++++++++++++--------------- 9 files changed, 105 insertions(+), 102 deletions(-) diff --git a/R/plot.R b/R/plot.R index 38065217..01172632 100644 --- a/R/plot.R +++ b/R/plot.R @@ -145,12 +145,12 @@ cap_to_polygon <- function(centre = s2_lnglat(0, 0), radius_rad) { c(0, rad_proj, 0, -rad_proj, 0), c(rad_proj, 0, -rad_proj, 0, rad_proj) ) - points_s2 <- new_s2_geography(wk::wk_handle( + points_s2 <- wk::wk_handle( points, s2_geography_writer( projection = s2_projection_orthographic(centre) ) - )) + ) s2_make_polygon(s2_x(points_s2), s2_y(points_s2)) } diff --git a/R/s2-constructors-formatters.R b/R/s2-constructors-formatters.R index 79581e0e..04c2015e 100644 --- a/R/s2-constructors-formatters.R +++ b/R/s2-constructors-formatters.R @@ -91,19 +91,17 @@ #' ) #' s2_geog_point <- function(longitude, latitude) { - new_s2_geography(wk::wk_handle(wk::xy(longitude, latitude), s2_geography_writer())) + wk::wk_handle(wk::xy(longitude, latitude), s2_geography_writer()) } #' @rdname s2_geog_point #' @export s2_make_line <- function(longitude, latitude, feature_id = 1L) { - new_s2_geography( - wk::wk_handle( - wk::xy(longitude, latitude), - wk::wk_linestring_filter( - s2_geography_writer(), - feature_id = as.integer(feature_id) - ) + wk::wk_handle( + wk::xy(longitude, latitude), + wk::wk_linestring_filter( + s2_geography_writer(), + feature_id = as.integer(feature_id) ) ) } @@ -112,14 +110,12 @@ s2_make_line <- function(longitude, latitude, feature_id = 1L) { #' @export s2_make_polygon <- function(longitude, latitude, feature_id = 1L, ring_id = 1L, oriented = FALSE, check = TRUE) { - new_s2_geography( - wk::wk_handle( - wk::xy(longitude, latitude), - wk::wk_polygon_filter( - s2_geography_writer(oriented = oriented, check = check), - feature_id = as.integer(feature_id), - ring_id = as.integer(ring_id) - ) + wk::wk_handle( + wk::xy(longitude, latitude), + wk::wk_polygon_filter( + s2_geography_writer(oriented = oriented, check = check), + feature_id = as.integer(feature_id), + ring_id = as.integer(ring_id) ) ) } @@ -133,18 +129,16 @@ s2_geog_from_text <- function(wkt_string, oriented = FALSE, check = TRUE, wkt <- wk::new_wk_wkt(wkt_string, geodesic = TRUE) wk::validate_wk_wkt(wkt) - new_s2_geography( - wk::wk_handle( - wkt, - s2_geography_writer( - oriented = oriented, - check = check, - tessellate_tol = if (planar) { - tessellate_tol_m / s2_earth_radius_meters() - } else { - Inf - } - ) + wk::wk_handle( + wkt, + s2_geography_writer( + oriented = oriented, + check = check, + tessellate_tol = if (planar) { + tessellate_tol_m / s2_earth_radius_meters() + } else { + Inf + } ) ) } @@ -158,18 +152,16 @@ s2_geog_from_wkb <- function(wkb_bytes, oriented = FALSE, check = TRUE, wkb <- wk::new_wk_wkb(wkb_bytes) wk::validate_wk_wkb(wkb) - new_s2_geography( - wk::wk_handle( - wkb, - s2_geography_writer( - oriented = oriented, - check = check, - tessellate_tol = if (planar) { - tessellate_tol_m / s2_earth_radius_meters() - } else { - Inf - } - ) + wk::wk_handle( + wkb, + s2_geography_writer( + oriented = oriented, + check = check, + tessellate_tol = if (planar) { + tessellate_tol_m / s2_earth_radius_meters() + } else { + Inf + } ) ) } diff --git a/R/s2-geography.R b/R/s2-geography.R index 3cc3a943..c4c0856f 100644 --- a/R/s2-geography.R +++ b/R/s2-geography.R @@ -71,11 +71,9 @@ as_s2_geography.wk_wkb <- function(x, ..., oriented = FALSE, check = TRUE) { } } - new_s2_geography( - wk::wk_handle( - x, - s2_geography_writer(oriented = oriented, check = check) - ) + wk::wk_handle( + x, + s2_geography_writer(oriented = oriented, check = check) ) } @@ -110,11 +108,9 @@ as_s2_geography.wk_wkt <- function(x, ..., oriented = FALSE, check = TRUE) { } } - new_s2_geography( - wk::wk_handle( - x, - s2_geography_writer(oriented = oriented, check = check) - ) + wk::wk_handle( + x, + s2_geography_writer(oriented = oriented, check = check) ) } diff --git a/R/s2-serialize.R b/R/s2-serialize.R index f48f50a7..92b29d31 100644 --- a/R/s2-serialize.R +++ b/R/s2-serialize.R @@ -7,14 +7,12 @@ s2_geography_serialize <- function(x) { } s2_geography_unserialize <- function(bytes) { - new_s2_geography( - wk::wk_handle( - bytes, - s2::s2_geography_writer( - oriented = TRUE, - check = FALSE, - projection = NULL - ) + wk::wk_handle( + bytes, + s2::s2_geography_writer( + oriented = TRUE, + check = FALSE, + projection = NULL ) ) } diff --git a/R/wk-utils.R b/R/wk-utils.R index df6a6ca0..9dab5cde 100644 --- a/R/wk-utils.R +++ b/R/wk-utils.R @@ -39,7 +39,8 @@ wk_handle.s2_geography <- function(handleable, handler, ..., #' @export s2_geography_writer <- function(oriented = FALSE, check = TRUE, projection = s2_projection_plate_carree(), - tessellate_tol = Inf) { + tessellate_tol = Inf, + use_altrep = !isTRUE(getOption("s2.disable_altrep"))) { stopifnot(is.null(projection) || inherits(projection, "s2_projection")) wk::new_wk_handler( @@ -48,7 +49,8 @@ s2_geography_writer <- function(oriented = FALSE, check = TRUE, as.logical(oriented)[1], as.logical(check)[1], projection, - as.double(tessellate_tol[1]) + as.double(tessellate_tol[1]), + as.logical(use_altrep)[1] ), "s2_geography_writer" ) diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index 042bc088..cada0caa 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -1346,7 +1346,7 @@ BEGIN_RCPP END_RCPP } -RcppExport SEXP c_s2_geography_writer_new(SEXP, SEXP, SEXP, SEXP); +RcppExport SEXP c_s2_geography_writer_new(SEXP, SEXP, SEXP, SEXP, SEXP); RcppExport SEXP c_s2_handle_geography(SEXP, SEXP); RcppExport SEXP c_s2_handle_geography_tessellated(SEXP, SEXP); RcppExport SEXP c_s2_projection_mercator(SEXP); @@ -1467,7 +1467,7 @@ static const R_CallMethodDef CallEntries[] = { {"_s2_cpp_s2_buffer_cells", (DL_FUNC) &_s2_cpp_s2_buffer_cells, 4}, {"_s2_cpp_s2_convex_hull", (DL_FUNC) &_s2_cpp_s2_convex_hull, 1}, {"_s2_cpp_s2_convex_hull_agg", (DL_FUNC) &_s2_cpp_s2_convex_hull_agg, 2}, - {"c_s2_geography_writer_new", (DL_FUNC) &c_s2_geography_writer_new, 4}, + {"c_s2_geography_writer_new", (DL_FUNC) &c_s2_geography_writer_new, 5}, {"c_s2_handle_geography", (DL_FUNC) &c_s2_handle_geography, 2}, {"c_s2_handle_geography_tessellated", (DL_FUNC) &c_s2_handle_geography_tessellated, 2}, {"c_s2_projection_mercator", (DL_FUNC) &c_s2_projection_mercator, 1}, diff --git a/src/s2-altrep.h b/src/s2-altrep.h index 7f926c60..2f259fae 100644 --- a/src/s2-altrep.h +++ b/src/s2-altrep.h @@ -12,5 +12,6 @@ #endif void s2_init_altrep(DllInfo *dll); +SEXP make_s2_geography_altrep(SEXP list); #endif diff --git a/src/s2-constructors-formatters.cpp b/src/s2-constructors-formatters.cpp index 3cc49833..51e07c7f 100644 --- a/src/s2-constructors-formatters.cpp +++ b/src/s2-constructors-formatters.cpp @@ -50,6 +50,7 @@ typedef struct { SEXP result; R_xlen_t feat_id; int coord_size; + int use_altrep; char cpp_exception_error[8096]; } builder_handler_t; @@ -110,7 +111,17 @@ SEXP builder_vector_end(const wk_vector_meta_t* meta, void* handler_data) { builder_handler_t* data = (builder_handler_t*) handler_data; builder_result_finalize(data); - return data->result; + // make the result into a s2_geography object + SEXP result = data->result; + if (data->use_altrep) result = make_s2_geography_altrep(result); + + SEXP cls = PROTECT(Rf_allocVector(STRSXP, 2)); + SET_STRING_ELT(cls, 0, Rf_mkChar("s2_geography")); + SET_STRING_ELT(cls, 1, Rf_mkChar("wk_vctr")); + Rf_setAttrib(result, R_ClassSymbol, cls); + UNPROTECT(1); + + return result; } int builder_feature_start(const wk_vector_meta_t* meta, R_xlen_t feat_id, void* handler_data) { @@ -233,11 +244,13 @@ void delete_vector_constructor(SEXP xptr) { extern "C" SEXP c_s2_geography_writer_new(SEXP oriented_sexp, SEXP check_sexp, SEXP projection_xptr, - SEXP tessellate_tolerance_sexp) { + SEXP tessellate_tolerance_sexp, + SEXP use_altrep_sexp) { CPP_START int oriented = LOGICAL(oriented_sexp)[0]; int check = LOGICAL(check_sexp)[0]; + int use_altrep = LOGICAL(use_altrep_sexp)[0]; S2::Projection* projection = NULL; if (projection_xptr != R_NilValue) { projection = reinterpret_cast(R_ExternalPtrAddr(projection_xptr)); @@ -288,6 +301,7 @@ extern "C" SEXP c_s2_geography_writer_new(SEXP oriented_sexp, SEXP check_sexp, } data->coord_size = 2; + data->use_altrep = use_altrep; data->builder = builder; data->result = R_NilValue; memset(data->cpp_exception_error, 0, 8096); diff --git a/tests/testthat/test-wk-utils.R b/tests/testthat/test-wk-utils.R index c0cdda5b..36a2e48e 100644 --- a/tests/testthat/test-wk-utils.R +++ b/tests/testthat/test-wk-utils.R @@ -1,15 +1,15 @@ test_that("wk_handle() for s2_geography works", { for (name in names(s2_data_example_wkt)) { - geog <- new_s2_geography(wk::wk_handle( + geog <- wk::wk_handle( s2_data_example_wkt[[name]], s2_geography_writer() - )) + ) - geog2 <- new_s2_geography(wk::wk_handle( + geog2 <- wk::wk_handle( geog, s2_geography_writer(check = TRUE, oriented = TRUE) - )) + ) expect_equal(wk::wk_coords(geog), wk::wk_coords(geog2)) } @@ -17,12 +17,12 @@ test_that("wk_handle() for s2_geography works", { test_that("wk_handle() for s2_geography works for s2_point projection", { for (name in names(s2_data_example_wkt)) { - geog <- new_s2_geography(wk::wk_handle( + geog <- wk::wk_handle( s2_data_example_wkt[[name]], s2_geography_writer() - )) + ) - geog2 <- new_s2_geography(wk::wk_handle( + geog2 <- wk::wk_handle( geog, s2_geography_writer( check = TRUE, @@ -30,7 +30,7 @@ test_that("wk_handle() for s2_geography works for s2_point projection", { projection = NULL ), s2_projection = NULL - )) + ) expect_identical(wk::wk_coords(geog), wk::wk_coords(geog2)) } @@ -43,10 +43,10 @@ test_that("wk_writer() works for s2_geography()", { test_that("the s2_geography_writer() works for example WKT", { # nc has some rings that get reordered by this operation for (name in setdiff(names(s2_data_example_wkt), "nc")) { - geog <- new_s2_geography(wk::wk_handle( + geog <- wk::wk_handle( s2_data_example_wkt[[name]], s2_geography_writer() - )) + ) expect_equal( wk::wk_coords(as_wkt(geog))[c("x", "y")], @@ -57,13 +57,13 @@ test_that("the s2_geography_writer() works for example WKT", { test_that("wk_handle() works for example WKT", { for (name in names(s2_data_example_wkt)) { - geog <- new_s2_geography(wk::wk_handle( + geog <- wk::wk_handle( s2_data_example_wkt[[name]], s2_geography_writer() - )) + ) expect_wkt_equal( - new_s2_geography(wk_handle(geog, s2_geography_writer())), + wk_handle(geog, s2_geography_writer()), geog, precision = 14 ) @@ -72,14 +72,14 @@ test_that("wk_handle() works for example WKT", { test_that("wk_handle() works for example WKT with tessellation", { for (name in names(s2_data_example_wkt)) { - geog <- new_s2_geography(wk::wk_handle( + geog <- wk::wk_handle( s2_data_example_wkt[[name]], s2_geography_writer() - )) + ) expect_wkt_equal( # use a big but non-infinite number to trigger the tessellator - new_s2_geography(wk_handle(geog, s2_geography_writer(), s2_tessellate_tol = 1e10)), + wk_handle(geog, s2_geography_writer(), s2_tessellate_tol = 1e10), geog, precision = 14 ) @@ -109,28 +109,28 @@ test_that("s2_geography_writer() with tesselate_tol works", { expect_equal( wk::as_xy( - new_s2_geography(wk::wk_handle( + wk::wk_handle( wk::xy(0, 0), s2_geography_writer(tessellate_tol = tol) - )) + ) ), wk::xy(0, 0, crs = wk::wk_crs_longlat()) ) expect_identical( - new_s2_geography(wk::wk_handle( + wk::wk_handle( wk::wkt("LINESTRING (0 0, 0 45, -60 45)"), s2_geography_writer(tessellate_tol = tol) - )) %>% + ) %>% s2_num_points(), 6L ) expect_identical( - new_s2_geography(wk::wk_handle( + wk::wk_handle( wk::wkt("POLYGON ((0 0, 0 45, -60 45, 0 0))"), s2_geography_writer(tessellate_tol = tol) - )) %>% + ) %>% s2_num_points(), 8L ) @@ -139,10 +139,10 @@ test_that("s2_geography_writer() with tesselate_tol works", { test_that("s2_geography_writer() with tesselate_tol works with real data", { tol <- 1000 / s2_earth_radius_meters() - countries_tes <- new_s2_geography(wk::wk_handle( + countries_tes <- wk::wk_handle( s2::s2_data_tbl_countries$geometry, s2_geography_writer(tessellate_tol = tol) - )) + ) expect_true( sum(s2_num_points(countries_tes)) > @@ -163,21 +163,21 @@ test_that("wk_handle + tessellate_tol works", { ) expect_identical( - new_s2_geography( wk::wk_handle( + wk::wk_handle( as_s2_geography("LINESTRING (0 0, 0 45, -60 45)"), s2_geography_writer(), s2_tessellate_tol = tol - )) %>% + ) %>% s2_num_points(), 6L ) expect_identical( - new_s2_geography(wk::wk_handle( + wk::wk_handle( as_s2_geography("POLYGON ((0 0, 0 45, -60 45, 0 0))"), s2_geography_writer(), s2_tessellate_tol = tol - )) %>% + ) %>% s2_num_points(), 8L ) @@ -187,11 +187,11 @@ test_that("s2_geography_writer() with tesselate_tol works with real data", { tol <- 1000 / s2_earth_radius_meters() countries <- s2_data_countries() - countries_tes <- new_s2_geography(wk::wk_handle( + countries_tes <- wk::wk_handle( countries, s2_geography_writer(check = FALSE), s2_tessellate_tol = tol - )) + ) expect_true( sum(s2_num_points(countries_tes)) > @@ -201,10 +201,10 @@ test_that("s2_geography_writer() with tesselate_tol works with real data", { test_that("wk_handle() for s2_geography works with s2_projection_mercator()", { # sf::sf_project("EPSG:4326", "EPSG:3857", wk::xy(30, 10)) %>% dput() - geog <- new_s2_geography(wk::wk_handle( + geog <- wk::wk_handle( wk::xy(3339584.72379821, 1118889.97485796), s2_geography_writer(projection = s2_projection_mercator()) - )) + ) expect_equal( wk::wk_handle( @@ -230,11 +230,11 @@ test_that("s2_geography_writer() works with s2_projection_mercator()", { # sf::sf_project("EPSG:4326", "EPSG:3857", wk::xy(30, 10)) %>% dput() expect_equal( wk::as_xy( - new_s2_geography(wk::wk_handle( + wk::wk_handle( wk::xy(3339584.72379821, 1118889.97485796), s2_geography_writer(projection = s2_projection_mercator()) ) - )), + ), wk::xy(30, 10, crs = wk::wk_crs_longlat()) ) }) @@ -281,10 +281,10 @@ test_that("s2_geography_writer() works with s2_projection_mercator()", { c(0, sqrt(2) / 2, 0) ) - geog <- new_s2_geography(wk::wk_handle( + geog <- wk::wk_handle( xy, s2_geography_writer(projection = s2_projection_orthographic()) - )) + ) expect_identical( s2_as_text(geog, precision = 5), c("POINT (0 0)", "POINT (0 45)", "POINT (45 0)") From 8d65bb59c40087eef81300a9f40951312852132d Mon Sep 17 00:00:00 2001 From: Taras Zakharko Date: Thu, 19 Jun 2025 16:08:47 +0200 Subject: [PATCH 10/13] Add missing documentation for `use_altrep` parameter of `s2_geography_writer()` --- R/wk-utils.R | 3 +++ man/wk_handle.s2_geography.Rd | 7 ++++++- 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/R/wk-utils.R b/R/wk-utils.R index 9dab5cde..e41db7ee 100644 --- a/R/wk-utils.R +++ b/R/wk-utils.R @@ -7,6 +7,9 @@ #' @param tessellate_tol,s2_tessellate_tol An angle in radians. #' Points will not be added if a line segment is within this #' distance of a point. +#' @param use_altrep A flag indicating whether ALTREP representation of s2 geography +#' vectors should be used with support for data serialization (default: `TRUE` on R 4.3.0 and later, +#' set the option `s2.disable_altrep` to disable) #' @param x_scale The maximum x value of the projection #' @param centre The center point of the orthographic projection #' @param epsilon_east_west,epsilon_north_south Use a positive number to diff --git a/man/wk_handle.s2_geography.Rd b/man/wk_handle.s2_geography.Rd index 88ff6ec0..8c404f6c 100644 --- a/man/wk_handle.s2_geography.Rd +++ b/man/wk_handle.s2_geography.Rd @@ -25,7 +25,8 @@ s2_geography_writer( oriented = FALSE, check = TRUE, projection = s2_projection_plate_carree(), - tessellate_tol = Inf + tessellate_tol = Inf, + use_altrep = !isTRUE(getOption("s2.disable_altrep")) ) \method{wk_writer}{s2_geography}(handleable, ...) @@ -65,6 +66,10 @@ rings are defined clockwise).} Points will not be added if a line segment is within this distance of a point.} +\item{use_altrep}{A flag indicating whether ALTREP representation of s2 geography +vectors should be used with support for data serialization (default: \code{TRUE} on R 4.3.0 and later, +set the option \code{s2.disable_altrep} to disable)} + \item{x_scale}{The maximum x value of the projection} \item{centre}{The center point of the orthographic projection} From 3fbb71357e9d2cad6c69c5d41754cf23c19196de Mon Sep 17 00:00:00 2001 From: Taras Zakharko Date: Thu, 19 Jun 2025 23:12:49 +0200 Subject: [PATCH 11/13] Protect the ALTREP object --- src/s2-constructors-formatters.cpp | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/s2-constructors-formatters.cpp b/src/s2-constructors-formatters.cpp index 51e07c7f..252cbf08 100644 --- a/src/s2-constructors-formatters.cpp +++ b/src/s2-constructors-formatters.cpp @@ -113,7 +113,7 @@ SEXP builder_vector_end(const wk_vector_meta_t* meta, void* handler_data) { // make the result into a s2_geography object SEXP result = data->result; - if (data->use_altrep) result = make_s2_geography_altrep(result); + if (data->use_altrep) result = PROTECT(make_s2_geography_altrep(result)); SEXP cls = PROTECT(Rf_allocVector(STRSXP, 2)); SET_STRING_ELT(cls, 0, Rf_mkChar("s2_geography")); @@ -121,6 +121,8 @@ SEXP builder_vector_end(const wk_vector_meta_t* meta, void* handler_data) { Rf_setAttrib(result, R_ClassSymbol, cls); UNPROTECT(1); + if (data->use_altrep) UNPROTECT(1); + return result; } From f3be196e27a0fc77089d05870e573792ffcf760b Mon Sep 17 00:00:00 2001 From: Taras Zakharko Date: Thu, 19 Jun 2025 23:18:22 +0200 Subject: [PATCH 12/13] Remove extraneous tests --- tests/testthat/test-s2-serialization.R | 231 ------------------------- 1 file changed, 231 deletions(-) diff --git a/tests/testthat/test-s2-serialization.R b/tests/testthat/test-s2-serialization.R index b8082d4f..19f1c92a 100644 --- a/tests/testthat/test-s2-serialization.R +++ b/tests/testthat/test-s2-serialization.R @@ -56,13 +56,6 @@ test_that("ALTREP can be disabled", { options(s2.disable_altrep = NULL) }) -# S2 Geography constructors -test_that("s2_geography() can be correctly serialized", { - skip_if_serialization_unsupported() - - expect_wkt_serializeable(s2_geography()) -}) - test_that("s2_geog_point() can be correctly serialized", { skip_if_serialization_unsupported() @@ -71,42 +64,6 @@ test_that("s2_geog_point() can be correctly serialized", { )) }) -test_that("s2_make_line() can be correctly serialized", { - skip_if_serialization_unsupported() - - expect_wkt_serializeable(s2_make_line( - c(-64, 8), c(45, 71) - )) -}) - -test_that("s2_make_polygon() can be correctly serialized", { - skip_if_serialization_unsupported() - - expect_wkt_serializeable(s2_make_polygon( - c(-45, 8, 0), c(64, 71, 90) - )) - expect_wkt_serializeable(s2_make_polygon( - c(-45, 8, 0, -45), c(64, 71, 90, 64) - )) -}) - -test_that("s2_geog_from_wkt() can be correctly serialized", { - skip_if_serialization_unsupported() - - expect_wkt_serializeable(s2_geog_from_text( - "POINT (-64 45)" - )) -}) - -test_that("s2_geog_from_wkb() can be correctly serialized", { - skip_if_serialization_unsupported() - - expect_wkt_serializeable(s2_geog_from_wkb( - as_wkb("POINT (-64 45)") - )) -}) - -# Geography Transformations test_that("s2_union() can be correctly serialized", { skip_if_serialization_unsupported() @@ -115,191 +72,3 @@ test_that("s2_union() can be correctly serialized", { "POINT (30 10)" )) }) - -test_that("s2_intersection() can be correctly serialized", { - skip_if_serialization_unsupported() - - expect_wkt_serializeable(s2_intersection( - "POLYGON ((0 0, 10 0, 10 10, 0 10, 0 0))", - "POLYGON ((5 5, 15 5, 15 15, 5 15, 5 5))", - )) -}) - - -test_that("s2_difference() can be correctly serialized", { - skip_if_serialization_unsupported() - - expect_wkt_serializeable(s2_difference( - "POLYGON ((0 0, 10 0, 10 10, 0 10, 0 0))", - "POLYGON ((5 5, 15 5, 15 15, 5 15, 5 5))", - )) -}) - -test_that("s2_sym_difference() can be correctly serialized", { - skip_if_serialization_unsupported() - - expect_wkt_serializeable(s2_sym_difference( - "POLYGON ((0 0, 10 0, 10 10, 0 10, 0 0))", - "POLYGON ((5 5, 15 5, 15 15, 5 15, 5 5))", - )) -}) - -test_that("s2_convex_hull() can be correctly serialized", { - skip_if_serialization_unsupported() - - expect_wkt_serializeable(s2_convex_hull( - "GEOMETRYCOLLECTION (POINT (-1 0), POINT (0 1), POINT (1 0))" - )) -}) - -test_that("s2_boundary() can be correctly serialized", { - skip_if_serialization_unsupported() - - expect_wkt_serializeable(s2_boundary( - "POLYGON ((0 0, 10 0, 10 10, 0 10, 0 0))" - )) -}) - - -test_that("s2_centroid() can be correctly serialized", { - skip_if_serialization_unsupported() - - expect_wkt_serializeable(s2_centroid( - "POLYGON ((0 0, 10 0, 10 10, 0 10, 0 0))" - )) -}) - -test_that("s2_closest_point() can be correctly serialized", { - skip_if_serialization_unsupported() - - expect_wkt_serializeable(s2_closest_point( - "POLYGON ((0 0, 10 0, 10 10, 0 10, 0 0))", - "POINT (-63 46)" - )) -}) - -test_that("s2_minimum_clearance_line_between() can be correctly serialized", { - skip_if_serialization_unsupported() - - expect_wkt_serializeable(s2_minimum_clearance_line_between( - "POINT (10 30)", - "POINT (30 10)" - )) -}) - -test_that("s2_snap_to_grid() can be correctly serialized", { - skip_if_serialization_unsupported() - - expect_wkt_serializeable(s2_snap_to_grid( - "POINT (10.25 30.5)", - 1 - )) -}) - -test_that("s2_simplify() can be correctly serialized", { - skip_if_serialization_unsupported() - - expect_wkt_serializeable(s2_simplify( - "POLYGON ((0 0, 10 0, 10 10, 0 10, 0 0))", - 1 - )) -}) - -test_that("s2_rebuild() can be correctly serialized", { - skip_if_serialization_unsupported() - - expect_wkt_serializeable(s2_rebuild( - "POLYGON ((0 0, 10 0, 10 10, 0 10, 0 0))" - )) -}) - -test_that("s2_buffer_cells() can be correctly serialized", { - skip_if_serialization_unsupported() - - expect_wkt_serializeable(s2_buffer_cells( - "POINT (10 10)", 100 - )) -}) - -test_that("s2_centroid_agg() can be correctly serialized", { - skip_if_serialization_unsupported() - - expect_wkt_serializeable(s2_centroid_agg(c( - "POINT (-1 0)", - "POINT (0 1)", - "POINT (1 0)" - ))) -}) - -test_that("s2_coverage_union_agg() can be correctly serialized", { - skip_if_serialization_unsupported() - - expect_wkt_serializeable(s2_coverage_union_agg(c( - "POINT (-1 0)", - "POINT (0 1)", - "POINT (1 0)" - ))) -}) - -test_that("s2_rebuild_agg() can be correctly serialized", { - skip_if_serialization_unsupported() - - expect_wkt_serializeable(s2_rebuild_agg(c( - "POINT (-1 0)", - "POINT (0 1)", - "POINT (1 0)" - ))) -}) - -test_that("s2_union_agg() can be correctly serialized", { - skip_if_serialization_unsupported() - - expect_wkt_serializeable(s2_union_agg(c( - "POINT (-1 0)", - "POINT (0 1)", - "POINT (1 0)" - ))) -}) - -test_that("s2_convex_hull_agg() can be correctly serialized", { - skip_if_serialization_unsupported() - - expect_wkt_serializeable(s2_convex_hull_agg(c( - "POINT (-1 0)", - "POINT (0 1)", - "POINT (1 0)" - ))) -}) - -test_that("s2_point_on_surface() can be correctly serialized", { - skip_if_serialization_unsupported() - - expect_wkt_serializeable(s2_point_on_surface( - "POLYGON ((0 0, 10 0, 10 10, 0 10, 0 0))" - )) -}) - -# S2 cell operators that construct s2 geography -test_that("s2_cell_center() can be correctly serialized", { - skip_if_serialization_unsupported() - - expect_wkt_serializeable(s2_cell_center(s2_cell("5"))) -}) - -test_that("s2_cell_boundary() can be correctly serialized", { - skip_if_serialization_unsupported() - - expect_wkt_serializeable(s2_cell_boundary(s2_cell("5"))) -}) - -test_that("s2_cell_polygon() can be correctly serialized", { - skip_if_serialization_unsupported() - - expect_wkt_serializeable(s2_cell_polygon(s2_cell("5"))) -}) - -test_that("s2_cell_vertex() can be correctly serialized", { - skip_if_serialization_unsupported() - - expect_wkt_serializeable(s2_cell_vertex(s2_cell("5"), seq_len(4L))) -}) From 0a4b054908efcdc78a352a568435538f5dec0301 Mon Sep 17 00:00:00 2001 From: Taras Zakharko Date: Thu, 19 Jun 2025 23:23:17 +0200 Subject: [PATCH 13/13] Minor changes to ALTREP object protection. --- src/s2-constructors-formatters.cpp | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/src/s2-constructors-formatters.cpp b/src/s2-constructors-formatters.cpp index 252cbf08..44d9d8ca 100644 --- a/src/s2-constructors-formatters.cpp +++ b/src/s2-constructors-formatters.cpp @@ -112,16 +112,18 @@ SEXP builder_vector_end(const wk_vector_meta_t* meta, void* handler_data) { builder_result_finalize(data); // make the result into a s2_geography object - SEXP result = data->result; - if (data->use_altrep) result = PROTECT(make_s2_geography_altrep(result)); + SEXP result; + if (data->use_altrep) { + result = PROTECT(make_s2_geography_altrep(data->result)); + } else { + result = PROTECT(data->result); + } SEXP cls = PROTECT(Rf_allocVector(STRSXP, 2)); SET_STRING_ELT(cls, 0, Rf_mkChar("s2_geography")); SET_STRING_ELT(cls, 1, Rf_mkChar("wk_vctr")); Rf_setAttrib(result, R_ClassSymbol, cls); - UNPROTECT(1); - - if (data->use_altrep) UNPROTECT(1); + UNPROTECT(2); return result; }