Update feather serializer; Add parquet serializer

DESCRIPTION

@@ -10,6 +10,7 @@ Authors@R: c(
   person("Bruno", "Tremblay", role = "ctb", email = "cran@neoxone.com"),
   person("Frans", "van Dunné", role = "ctb", email = "frans@ixpantia.com"),
   person("Sebastiaan", "Vandewoude", role="ctb", email = "sebastiaanvandewoude@gmail.com"),
+  person("Mauricio", "Vargas Sepulveda", role="ctb", email = "mavargas11@uc.cl"),
   person(family = "RStudio", role = c("cph", "fnd")))
 License: MIT + file LICENSE
 BugReports: https://github.com/rstudio/plumber/issues
@@ -44,7 +45,7 @@ Suggests:
     later,
     readr,
     yaml,
-    feather,
+    arrow,
     future,
     rstudioapi,
     spelling,

NAMESPACE

@@ -33,6 +33,7 @@ export(parser_json)
 export(parser_multi)
 export(parser_none)
 export(parser_octet)
+export(parser_parquet)
 export(parser_rds)
 export(parser_read_file)
 export(parser_text)
@@ -83,6 +84,7 @@ export(serializer_html)
 export(serializer_htmlwidget)
 export(serializer_jpeg)
 export(serializer_json)
+export(serializer_parquet)
 export(serializer_pdf)
 export(serializer_png)
 export(serializer_print)

NEWS.md

@@ -5,6 +5,8 @@
 ## New features
 
 * Introduces new GeoJSON serializer and parser. GeoJSON objects are parsed into `sf` objects and `sf` or `sfc` objects will be serialized into GeoJSON. (@josiahparry, #830)
+* Updates feather serializer to use the arrow package
+* Adds parquet serializer by using the arrow package
 
 ## Bug fixes
 

R/content-types.R

@@ -43,6 +43,7 @@ knownContentTypes <- c(
   xlam = "application/vnd.ms-excel.addin.macroEnabled.12",
   xlsb = "application/vnd.ms-excel.sheet.binary.macroEnabled.12",
   feather = "application/feather",
+  parquet = "application/parquet",
   rds = "application/rds",
   tsv = "application/tab-separated-values",
   csv = "application/csv",

R/parse-body.R

@@ -480,18 +480,27 @@ parser_rds <- function(...) {
   })
 }
 
-#' @describeIn parsers feather parser. See [feather::read_feather()] for more details.
+#' @describeIn parsers feather parser. See [arrow::read_feather()] for more details.
 #' @export
 parser_feather <- function(...) {
   parser_read_file(function(tmpfile) {
-    if (!requireNamespace("feather", quietly = TRUE)) {
-      stop("`feather` must be installed for `parser_feather` to work")
+    if (!requireNamespace("arrow", quietly = TRUE)) {
+      stop("`arrow` must be installed for `parser_feather` to work")
     }
-    feather::read_feather(tmpfile, ...)
+    arrow::read_feather(tmpfile, ...)
   })
 }
 
-
+#' @describeIn parsers parquet parser. See [arrow::read_parquet()] for more details.
+#' @export
+parser_parquet <- function(...) {
+  parser_read_file(function(tmpfile) {
+    if (!requireNamespace("arrow", quietly = TRUE)) {
+      stop("`arrow` must be installed for `parser_parquet` to work")
+    }
+    arrow::read_parquet(tmpfile, ...)
+  })
+}
 
 #' @describeIn parsers Octet stream parser. Returns the raw content.
 #' @export
@@ -569,6 +578,7 @@ register_parsers_onLoad <- function() {
   register_parser("form",    parser_form,   fixed = "application/x-www-form-urlencoded")
   register_parser("rds",     parser_rds,     fixed = "application/rds")
   register_parser("feather", parser_feather, fixed = "application/feather")
+  register_parser("parquet", parser_parquet, fixed = "application/parquet")
   register_parser("text",    parser_text,    fixed = "text/plain", regex = "^text/")
   register_parser("tsv",     parser_tsv,     fixed = c("application/tab-separated-values", "text/tab-separated-values"))
   # yaml types: https://stackoverflow.com/a/38000954/591574

R/serializer.R

@@ -263,17 +263,32 @@ serializer_rds <- function(version = "2", ascii = FALSE, ..., type = "applicatio
   })
 }
 
-#' @describeIn serializers feather serializer. See also: [feather::write_feather()]
+#' @describeIn serializers feather serializer. See also: [arrow::write_feather()]
 #' @export
 serializer_feather <- function(type = "application/feather") {
-  if (!requireNamespace("feather", quietly = TRUE)) {
-    stop("`feather` must be installed for `serializer_feather` to work")
+  if (!requireNamespace("arrow", quietly = TRUE)) {
+    stop("`arrow` must be installed for `serializer_feather` to work")
   }
   serializer_write_file(
     fileext = ".feather",
     type = type,
     write_fn = function(val, tmpfile) {
-      feather::write_feather(val, tmpfile)
+      arrow::write_feather(val, tmpfile)
+    }
+  )
+}
+
+#' @describeIn serializers parquet serializer. See also: [arrow::write_parquet()]
+#' @export
+serializer_parquet <- function(type = "application/parquet") {
+  if (!requireNamespace("arrow", quietly = TRUE)) {
+    stop("`arrow` must be installed for `serializer_parquet` to work")
+  }
+  serializer_write_file(
+    fileext = ".parquet",
+    type = type,
+    write_fn = function(val, tmpfile) {
+      arrow::write_parquet(val, tmpfile)
     }
   )
 }
@@ -614,6 +629,7 @@ add_serializers_onLoad <- function() {
   register_serializer("csv",         serializer_csv)
   register_serializer("tsv",         serializer_tsv)
   register_serializer("feather",     serializer_feather)
+  register_serializer("parquet",     serializer_parquet)
   register_serializer("yaml",        serializer_yaml)
   register_serializer("geojson",     serializer_geojson)
 

tests/testthat/test-parse-body.R

@@ -90,15 +90,15 @@ test_that("Test tsv parser", {
 })
 
 test_that("Test feather parser", {
-  skip_if_not_installed("feather")
+  skip_if_not_installed("arrow")
 
   tmp <- tempfile()
   on.exit({
     file.remove(tmp)
   }, add = TRUE)
 
   r_object <- iris
-  feather::write_feather(r_object, tmp)
+  arrow::write_feather(r_object, tmp)
   val <- readBin(tmp, "raw", 10000)
 
   parsed <- parse_body(val, "application/feather", make_parser("feather"))
@@ -109,6 +109,26 @@ test_that("Test feather parser", {
   expect_equal(parsed, r_object)
 })
 
+test_that("Test parquet parser", {
+  skip_if_not_installed("arrow")
+
+  tmp <- tempfile()
+  on.exit({
+    file.remove(tmp)
+  }, add = TRUE)
+
+  r_object <- iris
+  arrow::write_parquet(r_object, tmp)
+  val <- readBin(tmp, "raw", 10000)
+
+  parsed <- parse_body(val, "application/parquet", make_parser("parquet"))
+  # convert from parquet tibble to data.frame
+  parsed <- as.data.frame(parsed, stringsAsFactors = FALSE)
+  attr(parsed, "spec") <- NULL
+
+  expect_equal(parsed, r_object)
+})
+
 test_that("Test geojson parser", {
   skip_if_not_installed("geojsonsf")
   skip_if_not_installed("sf")

tests/testthat/test-serializer-feather.R

@@ -1,7 +1,7 @@
 context("feather serializer")
 
 test_that("feather serializes properly", {
-  skip_if_not_installed("feather")
+  skip_if_not_installed("arrow")
 
   d <- data.frame(a=1, b=2, c="hi")
   val <- serializer_feather()(d, data.frame(), PlumberResponse$new(), stop)
@@ -18,7 +18,7 @@ test_that("feather serializes properly", {
 })
 
 test_that("Errors call error handler", {
-  skip_if_not_installed("feather")
+  skip_if_not_installed("arrow")
 
   errors <- 0
   errHandler <- function(req, res, err){
@@ -31,7 +31,7 @@ test_that("Errors call error handler", {
 })
 
 test_that("Errors are rendered correctly with debug TRUE", {
-  skip_if_not_installed("feather")
+  skip_if_not_installed("arrow")
 
   pr <- pr() %>% pr_get("/", function() stop("myerror"), serializer = serializer_feather()) %>% pr_set_debug(TRUE)
   capture.output(res <- pr$serve(make_req(pr = pr), PlumberResponse$new("csv")))

tests/testthat/test-serializer-parquet.R

@@ -0,0 +1,40 @@
+context("parquet serializer")
+
+test_that("parquet serializes properly", {
+  skip_if_not_installed("arrow")
+
+  d <- data.frame(a=1, b=2, c="hi")
+  val <- serializer_parquet()(d, data.frame(), PlumberResponse$new(), stop)
+  expect_equal(val$status, 200L)
+  expect_equal(val$headers$`Content-Type`, "application/parquet")
+
+  # can test  by doing a full round trip if we believe the parser works via `test-parse-body.R`
+  parsed <- parse_body(val$body, "application/parquet", make_parser("parquet"))
+  # convert from parquet tibble to data.frame
+  parsed <- as.data.frame(parsed, stringsAsFactors = FALSE)
+  attr(parsed, "spec") <- NULL
+
+  expect_equal(parsed, d)
+})
+
+test_that("Errors call error handler", {
+  skip_if_not_installed("arrow")
+
+  errors <- 0
+  errHandler <- function(req, res, err){
+    errors <<- errors + 1
+  }
+
+  expect_equal(errors, 0)
+  serializer_parquet()(parse(text="hi"), data.frame(), PlumberResponse$new("csv"), errorHandler = errHandler)
+  expect_equal(errors, 1)
+})
+
+test_that("Errors are rendered correctly with debug TRUE", {
+  skip_if_not_installed("arrow")
+
+  pr <- pr() %>% pr_get("/", function() stop("myerror"), serializer = serializer_parquet()) %>% pr_set_debug(TRUE)
+  capture.output(res <- pr$serve(make_req(pr = pr), PlumberResponse$new("csv")))
+
+  expect_match(res$body, "Error in (function () : myerror", fixed = TRUE)
+})