Merge pull request #45 from R-ArcGIS/multipoly

Fix MultiPolygon JSON conversion

R/RcppExports.R

@@ -49,10 +49,6 @@ sfg_multipolygon_impl <- function(mply) {
     .Call(`_arcgisutils_sfg_multipolygon_impl`, mply)
 }
 
-sfc_multipolygon_impl <- function(mply) {
-    .Call(`_arcgisutils_sfc_multipolygon_impl`, mply)
-}
-
 transpose_impl <- function(x, names_template) {
     .Call(`_arcgisutils_transpose_impl`, x, names_template)
 }

R/as-esri-geometry.R

@@ -111,13 +111,11 @@ as_geometry <- function(x, crs, ...) {
 
 #' @export
 as_geometry.POINT <- function(x, crs = 4326, ..., call = rlang::current_env()) {
-
   crs_text <- validate_crs(crs, call = call)
 
   dims <- determine_dims(x)
 
-  geometry <- switch(
-    dims,
+  geometry <- switch(dims,
     "xy" = sfc_point_xy(list(x))[[1]],
     "xyz" = sfc_point_xyz(list(x))[[1]],
     "xyzm" = sfc_point_xyzm(list(x))[[1]],
@@ -145,8 +143,7 @@ as_geometry.MULTILINESTRING <- function(
     x,
     crs = 4326,
     ...,
-    call = rlang::current_env()
-) {
+    call = rlang::current_env()) {
   crs_text <- validate_crs(crs, call = call)
   geometry <- sfc_multilinestring_impl(list(x))[[1]]
 
@@ -158,18 +155,16 @@ as_geometry.POLYGON <- function(x, crs = 4326, ..., call = rlang::current_env())
   crs_text <- validate_crs(crs, call = call)
   geometry <- sfg_polygon_impl(x)
   c(hasZ = has_z(x), hasM = has_m(x), geometry, crs_text)
-
 }
 
 #' @export
 as_geometry.MULTIPOLYGON <- function(
     x,
     crs = 4326,
     ...,
-    call = rlang::current_env()
-) {
+    call = rlang::current_env()) {
   crs_text <- validate_crs(crs, call = call)
-  geometry <- sfc_multipolygon_impl(list(x))[[1]]
+  geometry <- sfg_polygon_impl(unlist(x, recursive = FALSE))
   res <- c(hasZ = has_z(x), hasM = has_m(x), geometry, crs_text)
   res
 }
@@ -198,7 +193,6 @@ as_features <- function(x, ..., call = rlang::caller_env()) {
 
 #' @export
 as_features.sfc <- function(x, ..., call = rlang::caller_env()) {
-
   geoms <- featureset_geometry(x, call = call)
 
   res <- lapply(
@@ -211,7 +205,6 @@ as_features.sfc <- function(x, ..., call = rlang::caller_env()) {
 
 #' @export
 as_features.sf <- function(x, ...) {
-
   geo <- sf::st_geometry(x)
   geom_list <- featureset_geometry(geo, call = call)
   x <- sf::st_drop_geometry(x)
@@ -243,15 +236,13 @@ as_features.sf <- function(x, ...) {
       transpose(x),
       SIMPLIFY = FALSE
     )
-
   }
 
   rows
 }
 
 #' @export
 as_features.data.frame <- function(x, ...) {
-
   # handle dates
   are_dates <- which(vapply(x, is_date, logical(1)))
   for (col in are_dates) {
@@ -272,7 +263,6 @@ as_features.data.frame <- function(x, ...) {
   rows <- lapply(fields, function(.x) list(attributes = .x))
 
   rows
-
 }
 
 
@@ -293,9 +283,7 @@ as_featureset.sfc <- function(
     crs = sf::st_crs(x),
     ...,
     arg = rlang::caller_arg(x),
-    call = rlang::caller_env()
-) {
-
+    call = rlang::caller_env()) {
   # check CRS first
   # TODO have better CRS handling. We prefer having _no_ crs over
   # a wrong one.
@@ -335,9 +323,7 @@ as_featureset.sf <- function(
     crs = sf::st_crs(x),
     ...,
     arg = rlang::caller_arg(x),
-    call = rlang::caller_env()
-) {
-
+    call = rlang::caller_env()) {
   # check CRS first
   if (is.na(sf::st_crs(x)) && is.na(sf::st_crs(crs))) {
     cli::cli_warn(
@@ -387,7 +373,6 @@ as_featureset.sf <- function(
       fields,
       SIMPLIFY = FALSE
     )
-
   }
 
   c(
@@ -401,7 +386,6 @@ as_featureset.sf <- function(
 
 #' @export
 as_featureset.data.frame <- function(x, ...) {
-
   # handle dates
   are_dates <- which(vapply(x, is_date, logical(1)))
   for (col in are_dates) {
@@ -417,7 +401,6 @@ as_featureset.data.frame <- function(x, ...) {
   fields <- transpose(x)
   rows <- lapply(fields, function(.x) list(attributes = .x))
   c(list(features = rows))
-
 }
 
 
@@ -431,7 +414,6 @@ as_featureset.data.frame <- function(x, ...) {
 #' @keywords internal
 #' @noRd
 featureset_geometry <- function(x, call = rlang::caller_env()) {
-
   # extract geometry
   x <- sf::st_geometry(x)
 
@@ -451,8 +433,7 @@ featureset_geometry <- function(x, call = rlang::caller_env()) {
   }
 
   # convert geometry
-  geo_conversion_fn <- switch(
-    geom_type,
+  geo_conversion_fn <- switch(geom_type,
     "POINT" = sfc_point_impl,
     "MULTIPOINT" = sfc_multipoint_impl,
     "LINESTRING" = sfc_linestring_impl,
@@ -462,7 +443,6 @@ featureset_geometry <- function(x, call = rlang::caller_env()) {
   )
 
   rlang::set_names(list(geo_conversion_fn(x)), esri_geo_type)
-
 }
 
 
@@ -500,4 +480,6 @@ featureset_geometry <- function(x, call = rlang::caller_env()) {
 
 # sfg object conversion ---------------------------------------------------
 
-
+sfc_multipolygon_impl <- function(x) {
+  sfc_polygon_impl(unlist(x, recursive = FALSE))
+}

R/esri-field-mapping.R

@@ -122,6 +122,7 @@ get_ptype <- function(field_type, n = 1, call = rlang::caller_env()) {
 
 #' @export
 #' @rdname field_mapping
+#' @param n the number of rows to create in the prototype table
 ptype_tbl <- function(fields, n = 0, call = rlang::caller_env()) {
   ftype <- fields[["type"]]
   fname <- fields[["name"]]

R/utils-requests.R

@@ -57,7 +57,6 @@ fetch_layer_metadata <- function(url, token = NULL, call = rlang::caller_env())
 #'
 #' Nothing. Used for it's side effect. If an error code is encountered in the
 #' response an error is thrown with the error code and the error message.
-#' @details
 #' @export
 #' @family requests
 #' @examples

src/RcppExports.cpp

@@ -142,17 +142,6 @@ BEGIN_RCPP
     return rcpp_result_gen;
 END_RCPP
 }
-// sfc_multipolygon_impl
-List sfc_multipolygon_impl(List mply);
-RcppExport SEXP _arcgisutils_sfc_multipolygon_impl(SEXP mplySEXP) {
-BEGIN_RCPP
-    Rcpp::RObject rcpp_result_gen;
-    Rcpp::RNGScope rcpp_rngScope_gen;
-    Rcpp::traits::input_parameter< List >::type mply(mplySEXP);
-    rcpp_result_gen = Rcpp::wrap(sfc_multipolygon_impl(mply));
-    return rcpp_result_gen;
-END_RCPP
-}
 // transpose_impl
 SEXP transpose_impl(SEXP x, SEXP names_template);
 RcppExport SEXP _arcgisutils_transpose_impl(SEXP xSEXP, SEXP names_templateSEXP) {
@@ -179,7 +168,6 @@ static const R_CallMethodDef CallEntries[] = {
     {"_arcgisutils_sfc_polygon_impl", (DL_FUNC) &_arcgisutils_sfc_polygon_impl, 1},
     {"_arcgisutils_sfg_multipolygon_inner_impl", (DL_FUNC) &_arcgisutils_sfg_multipolygon_inner_impl, 1},
     {"_arcgisutils_sfg_multipolygon_impl", (DL_FUNC) &_arcgisutils_sfg_multipolygon_impl, 1},
-    {"_arcgisutils_sfc_multipolygon_impl", (DL_FUNC) &_arcgisutils_sfc_multipolygon_impl, 1},
     {"_arcgisutils_transpose_impl", (DL_FUNC) &_arcgisutils_transpose_impl, 2},
     {NULL, NULL, 0}
 };

src/esri-geometry.cpp

@@ -282,21 +282,21 @@ List sfg_multipolygon_impl(List mply) {
 }
 
 
-// [[Rcpp::export]]
-List sfc_multipolygon_impl(List mply) {
+// // [[Rcpp::export]]
+// List sfc_multipolygon_impl(List mply) {
 
-  int n = mply.length();
+//   int n = mply.length();
 
-  // preallocate result list
-  // each MULTIPOLYGON feature
-  List res(n);
+//   // preallocate result list
+//   // each MULTIPOLYGON feature
+//   List res(n);
 
-  for (int i = 0; i < n; i++) {
-    List mpoly = mply[i];
-    res[i] = sfg_multipolygon_impl(mpoly);
-  }
+//   for (int i = 0; i < n; i++) {
+//     List mpoly = mply[i];
+//     res[i] = sfg_multipolygon_impl(mpoly);
+//   }
 
-  return res;
+//   return res;
 
-}
+// }
 

tests/testthat/test-rbind-results.R

@@ -24,22 +24,19 @@ test_that("rbind data.frames", {
 })
 
 test_that("rbind NULL & list(NULL)", {
-
   # should return empty df
   res <- rbind_results(NULL)
-  expect_identical(res, data.frame())
+  expect_identical(res, structure(data.frame(), null_elements = integer()))
 
   # one null
   res <- rbind_results(list(NULL))
-  expect_identical(res, data.frame())
+  expect_identical(res, structure(data.frame(), null_elements = 1L))
 
   # multiple
   res <- rbind_results(list(NULL, NULL))
-  expect_identical(res, data.frame())
+  expect_identical(res, structure(data.frame(), null_elements = 1:2))
 })
 
 test_that("rbind errors on non-df objects", {
   expect_error(rbind_results(list(iris, NULL, "a")))
 })
-
-