Create GeoJSON serializer

DESCRIPTION

@@ -49,7 +49,9 @@ Suggests:
     future,
     rstudioapi,
     spelling,
-    mockery (>= 0.4.2)
+    mockery (>= 0.4.2),
+    geojsonsf,
+    sf
 RoxygenNote: 7.1.1
 Collate:
     'async.R'

NAMESPACE

@@ -76,6 +76,7 @@ export(serializer_csv)
 export(serializer_device)
 export(serializer_feather)
 export(serializer_format)
+export(serializer_geojson)
 export(serializer_headers)
 export(serializer_html)
 export(serializer_htmlwidget)

R/parse-body.R

@@ -386,6 +386,16 @@ parser_json <- function(...) {
   })
 }
 
+#' @describeIn parsers GeoJSON parser. See [geojsonsf::geojson_sf()] for more details.
+#' @export
+parser_geojson <- function(...) {
+  parser_text(function(val) {
+    if (!requireNamespace("geojsonsf", quietly = TRUE)) {
+      stop("`geojsonsf` must be installed for `parser_geojson` to work")
+    }
+    geojsonsf::geojson_sf(val, ...)
+  })
+}
 
 #' @describeIn parsers Helper parser to parse plain text
 #' @param parse_fn function to further decode a text string into an object
@@ -564,6 +574,7 @@ register_parsers_onLoad <- function() {
   # yaml types: https://stackoverflow.com/a/38000954/591574
   register_parser("yaml",    parser_yaml,    fixed = c("text/vnd.yaml", "application/yaml", "application/x-yaml", "text/yaml", "text/x-yaml"))
   register_parser("none",    parser_none,    regex = "*")
+  register_parser("geojson", parser_geojson, fixed = c("application/geo+json", "geo+json"))
 
   parser_all <- function() {
     stop("This function should never be called. It should be handled by `make_parser('all')`")

R/serializer.R

@@ -231,6 +231,17 @@ serializer_unboxed_json <- function(auto_unbox = TRUE, ..., type = "application/
   serializer_json(auto_unbox = auto_unbox, ..., type = type)
 }
 
+#' @describeIn serializers GeoJSON serializer. See also [geojsonsf::sf_geojson()] and [[geojsonsf::sfc_geojson()]].
+#' @export
+serializer_geojson <- function(..., type = "application/geo+json") {
+  serializer_content_type(type, function(val) {
+    if (inherits(val, "sfc")) return(geojsonsf::sfc_geojson(val, ...))
+    if (inherits(val, "sf"))  return(geojsonsf::sf_geojson(val, ...))
+    if (!requireNamespace("geojsonsf", quietly = TRUE)) {
+      stop("`geojsonsf` must be installed for `serializer_geojson` to work")
+    }
+  })
+}
 
 
 
@@ -603,6 +614,7 @@ add_serializers_onLoad <- function() {
   register_serializer("tsv",         serializer_tsv)
   register_serializer("feather",     serializer_feather)
   register_serializer("yaml",        serializer_yaml)
+  register_serializer("geojson",     serializer_geojson)
 
   # text
   register_serializer("text",   serializer_text)

tests/testthat/test-parse-body.R

@@ -109,6 +109,40 @@ test_that("Test feather parser", {
   expect_equal(parsed, r_object)
 })
 
+test_that("Test geojson parser", {
+  skip_if_not_installed("geojsonsf")
+  skip_if_not_installed("sf")
+
+  # Test sf object w/ fields
+  geojson <- '{"type":"FeatureCollection","features":[{"type":"Feature","properties":{"a":3},"geometry":{"type":"Point","coordinates":[1,2]}},{"type":"Feature","properties":{"a":4},"geometry":{"type":"Point","coordinates":[3,4]}}]}'
+  parsed <- parse_body(geojson, "application/geo+json", make_parser("geojson"))
+  expect_equal(parsed, geojsonsf::geojson_sf(geojson))
+
+  # Test sfc
+  geojson <- '[
+  { "type":"Point","coordinates":[0,0]},
+  {"type":"LineString","coordinates":[[0,0],[1,1]]}
+  ]'
+  parsed <- parse_body(geojson, "application/geo+json", make_parser("geojson"))
+  expect_equal(parsed, geojsonsf::geojson_sf(geojson))
+
+  # Test simple sf object
+  geojson <- '{ "type" : "Point", "coordinates" : [0, 0] }'
+  parsed <- parse_body(geojson, "application/geo+json", make_parser("geojson"))
+  expect_equal(parsed, geojsonsf::geojson_sf(geojson))
+
+  # Test geojson file
+  tmp <- tempfile()
+  on.exit({
+    file.remove(tmp)
+  }, add = TRUE)
+
+  writeLines(geojson, tmp)
+  val <- readBin(tmp, "raw", 1000)
+  parsed <- parse_body(val, "application/geo+json", make_parser("geojson"))
+  expect_equal(parsed, geojsonsf::geojson_sf(geojson))
+
+})
 
 test_that("Test multipart output is reduced for argument matching", {
   bin_file <- test_path("files/multipart-file-names.bin")

tests/testthat/test-serializer-geojson.R

@@ -0,0 +1,35 @@
+test_that("GeoJSON serializes properly", {
+  skip_if_not_installed("geojsonsf")
+  skip_if_not_installed("sf")
+
+  # Objects taken from ?st_sf() examples.
+  sfc <- sf::st_sfc(sf::st_point(1:2), sf::st_point(3:4))
+  sf <- sf::st_sf(a = 3:4, sfc)
+
+  # Test sfc
+  val <- serializer_geojson()(sfc, data.frame(), PlumberResponse$new(), stop)
+  expect_equal(val$status, 200L)
+  expect_equal(val$headers$`Content-Type`, "application/geo+json")
+  expect_equal(val$body, geojsonsf::sfc_geojson(sfc))
+
+  # Test sf
+  val <- serializer_geojson()(sf, data.frame(), PlumberResponse$new(), stop)
+  expect_equal(val$status, 200L)
+  expect_equal(val$headers$`Content-Type`, "application/geo+json")
+  expect_equal(val$body, geojsonsf::sf_geojson(sf))
+
+})
+
+test_that("Errors call error handler", {
+  skip_if_not_installed("geojsonsf")
+  skip_if_not_installed("sf")
+
+  errors <- 0
+  errHandler <- function(req, res, err){
+    errors <<- errors + 1
+  }
+
+  expect_equal(errors, 0)
+  serializer_geojson()(parse(text="h$534i} {!"), data.frame(), PlumberResponse$new(), errorHandler = errHandler)
+  expect_equal(errors, 1)
+})