Add serializer_feather() and parser_feather()

DESCRIPTION

@@ -41,7 +41,8 @@ Suggests:
     analogsea (>= 0.7.0),
     later,
     readr,
-    yaml
+    yaml,
+    feather
 Remotes:
     rstudio/swagger
 RoxygenNote: 7.1.1

NAMESPACE

@@ -19,6 +19,7 @@ export(include_md)
 export(include_rmd)
 export(options_plumber)
 export(parser_csv)
+export(parser_feather)
 export(parser_json)
 export(parser_multi)
 export(parser_none)
@@ -62,6 +63,7 @@ export(registered_uis)
 export(serializer_cat)
 export(serializer_content_type)
 export(serializer_csv)
+export(serializer_feather)
 export(serializer_format)
 export(serializer_headers)
 export(serializer_html)

NEWS.md

@@ -55,6 +55,8 @@ both UIs integration are available from https://github.com/meztez/rapidoc/ and h
 
 ### Minor new features and improvements
 
+* Added `serializer_feather()` and `parser_feather()` (#626)
+
 * When `plumb()`ing a file, arguments supplied to parsers and serializers may be values defined earlier in the file. (@meztez, #620)
 
 * Updated Docker files. New Docker repo is now [`rstudio/plumber`](https://hub.docker.com/r/rstudio/plumber/tags). Updates heavily inspired from @mskyttner (#459). (#589)

R/content-types.R

@@ -42,6 +42,7 @@ knownContentTypes <- list(
   dotx='application/vnd.openxmlformats-officedocument.wordprocessingml.template',
   xlam='application/vnd.ms-excel.addin.macroEnabled.12',
   xlsb='application/vnd.ms-excel.sheet.binary.macroEnabled.12',
+  feather='application/feather',
   rds='application/rds',
   tsv="text/tab-separated-values",
   csv="text/csv")

R/parse-body.R

@@ -336,7 +336,7 @@ parser_query <- function() {
 }
 
 
-#' @describeIn parsers JSON parser
+#' @describeIn parsers JSON parser. See [jsonlite::parse_json()] for more details. (Defaults to using `simplifyVectors = TRUE`)
 #' @export
 parser_json <- function(...) {
   parser_text(function(txt_value) {
@@ -359,7 +359,7 @@ parser_text <- function(parse_fn = identity) {
 }
 
 
-#' @describeIn parsers YAML parser
+#' @describeIn parsers YAML parser. See [yaml::yaml.load()] for more details.
 #' @export
 parser_yaml <- function(...) {
   parser_text(function(val) {
@@ -370,7 +370,7 @@ parser_yaml <- function(...) {
   })
 }
 
-#' @describeIn parsers CSV parser
+#' @describeIn parsers CSV parser. See [readr::read_csv()] for more details.
 #' @export
 parser_csv <- function(...) {
   parse_fn <- function(raw_val) {
@@ -385,7 +385,7 @@ parser_csv <- function(...) {
 }
 
 
-#' @describeIn parsers TSV parser
+#' @describeIn parsers TSV parser. See [readr::read_tsv()] for more details.
 #' @export
 parser_tsv <- function(...) {
   parse_fn <- function(raw_val) {
@@ -419,7 +419,7 @@ parser_read_file <- function(read_fn = readLines) {
 }
 
 
-#' @describeIn parsers RDS parser
+#' @describeIn parsers RDS parser. See [readRDS()] for more details.
 #' @export
 parser_rds <- function(...) {
   parser_read_file(function(tmpfile) {
@@ -428,6 +428,18 @@ parser_rds <- function(...) {
   })
 }
 
+#' @describeIn parsers feather parser. See [feather::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")
+    }
+    feather::read_feather(tmpfile, ...)
+  })
+}
+
+
 
 #' @describeIn parsers Octet stream parser. Will add a filename attribute if the filename exists
 #' @export
@@ -477,16 +489,17 @@ parser_none <- function() {
 
 register_parsers_onLoad <- function() {
   # parser alias names for plumbing
-  register_parser("csv",   parser_csv,   fixed = c("application/csv", "application/x-csv", "text/csv", "text/x-csv"))
-  register_parser("json",  parser_json,  fixed = c("application/json", "text/json"))
-  register_parser("multi", parser_multi, fixed = "multipart/form-data")
-  register_parser("octet", parser_octet, fixed = "application/octet-stream")
-  register_parser("query", parser_query, fixed = "application/x-www-form-urlencoded")
-  register_parser("rds",   parser_rds,   fixed = "application/rds")
-  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"))
-  register_parser("yaml",  parser_yaml,  fixed = c("application/yaml", "application/x-yaml", "text/yaml", "text/x-yaml"))
-  register_parser("none",  parser_none,  regex = "*")
+  register_parser("csv",     parser_csv,     fixed = c("application/csv", "application/x-csv", "text/csv", "text/x-csv"))
+  register_parser("json",    parser_json,    fixed = c("application/json", "text/json"))
+  register_parser("multi",   parser_multi,   fixed = "multipart/form-data")
+  register_parser("octet",   parser_octet,   fixed = "application/octet-stream")
+  register_parser("query",   parser_query,   fixed = "application/x-www-form-urlencoded")
+  register_parser("rds",     parser_rds,     fixed = "application/rds")
+  register_parser("feather", parser_feather, fixed = "application/feather")
+  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"))
+  register_parser("yaml",    parser_yaml,    fixed = c("application/yaml", "application/x-yaml", "text/yaml", "text/x-yaml"))
+  register_parser("none",    parser_none,    regex = "*")
 
   parser_all <- function() {
     stop("This function should never be called. It should be handled by `make_parser('all')`")

R/serializer.R

@@ -209,6 +209,26 @@ serializer_rds <- function(version = "2", ascii = FALSE, ...) {
   })
 }
 
+#' @describeIn serializers feather serializer. See [feather::write_feather] for more details.
+#' @export
+serializer_feather <- function() {
+  if (!requireNamespace("feather", quietly = TRUE)) {
+    stop("`feather` must be installed for `serializer_feather` to work")
+  }
+  serializer_content_type("application/feather; charset=UTF-8", function(val) {
+    tmpfile <- tempfile(fileext = ".feather")
+    on.exit({
+      if (file.exists(tmpfile)) {
+        unlink(tmpfile)
+      }
+    }, add = TRUE)
+
+    feather::write_feather(val, tmpfile)
+    readBin(tmpfile, what = "raw", n = file.info(tmpfile)$size)
+  })
+}
+
+
 #' @describeIn serializers YAML serializer. See [yaml::as.yaml()] for more details.
 #' @export
 serializer_yaml <- function(...) {
@@ -312,6 +332,7 @@ add_serializers_onLoad <- function() {
   register_serializer("json",        serializer_json)
   register_serializer("unboxedJSON", serializer_unboxed_json)
   register_serializer("rds",         serializer_rds)
+  register_serializer("feather",     serializer_feather)
   register_serializer("xml",         serializer_xml)
   register_serializer("yaml",        serializer_yaml)
   register_serializer("text",        serializer_text)

tests/testthat/test-parse-body.R

@@ -49,6 +49,8 @@ test_that("Test yaml parser", {
 })
 
 test_that("Test csv parser", {
+  skip_if_not_installed("readr")
+
   tmp <- tempfile()
   on.exit({
     file.remove(tmp)
@@ -67,6 +69,8 @@ test_that("Test csv parser", {
 })
 
 test_that("Test tsv parser", {
+  skip_if_not_installed("readr")
+
   tmp <- tempfile()
   on.exit({
     file.remove(tmp)
@@ -84,6 +88,26 @@ test_that("Test tsv parser", {
   expect_equal(parsed, r_object)
 })
 
+test_that("Test feather parser", {
+  skip_if_not_installed("feather")
+
+  tmp <- tempfile()
+  on.exit({
+    file.remove(tmp)
+  }, add = TRUE)
+
+  r_object <- iris
+  feather::write_feather(r_object, tmp)
+  val <- readBin(tmp, "raw", 10000)
+
+  parsed <- parse_body(val, "application/feather", make_parser("feather"))
+  # convert from feather tibble to data.frame
+  parsed <- as.data.frame(parsed, stringsAsFactors = FALSE)
+  attr(parsed, "spec") <- NULL
+
+  expect_equal(parsed, r_object)
+})
+
 test_that("Test multipart parser", {
   # also tests rds and the octet -> content type conversion
 

tests/testthat/test-serializer-feather.R

@@ -0,0 +1,31 @@
+context("feather serializer")
+
+test_that("feather serializes properly", {
+  skip_if_not_installed("feather")
+
+  d <- data.frame(a=1, b=2, c="hi")
+  val <- serializer_feather()(d, data.frame(), PlumberResponse$new(), stop)
+  expect_equal(val$status, 200L)
+  expect_equal(val$headers$`Content-Type`, "application/feather; charset=UTF-8")
+
+  # 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/feather", make_parser("feather"))
+  # convert from feather 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("feather")
+
+  errors <- 0
+  errHandler <- function(req, res, err){
+    errors <<- errors + 1
+  }
+
+  expect_equal(errors, 0)
+  serializer_feather()(parse(text="hi"), data.frame(), PlumberResponse$new("csv"), errorHandler = errHandler)
+  expect_equal(errors, 1)
+})