proof of concept for graphs

.gitignore

@@ -1,2 +1,4 @@
 .Rproj.user
 .idea
+uploads
+

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: serovizr
 Title: R API for seroviz app
-Version: 0.0.0.9000
+Version: 0.0.0
 Authors@R: 
     person("Alex", "Hill", , "[email protected]", role = c("aut", "cre"),
            comment = c(ORCID = "0009-0003-8104-1890"))
@@ -12,8 +12,10 @@ RoxygenNote: 7.3.1
 Imports: 
     docopt,
     porcelain,
-    logger
+    logger,
+    Rook
 Remotes:
     reside-ic/porcelain,
 Suggests:
-    lintr (>= 3.1.2),
+    lintr (>= 3.1.2),
+    testthat

R/api.R

@@ -3,12 +3,86 @@ target_get_root <- function() {
 }
 
 target_get_version <- function() {
-  jsonlite::toJSON(as.character(utils::packageVersion("serovizr")), auto_unbox= TRUE)
+  jsonlite::toJSON(as.character(utils::packageVersion("serovizr")), auto_unbox = TRUE)
 }
 
+target_post_dataset <- function(req, res) {
+  parsed <- Rook::Multipart$parse(req)
+  file_body <- read.csv(parsed$file$tempfile)
+  filename <- parsed$file$filename
+  filename <- stringr::str_remove_all(filename, paste0(".", tools::file_ext(filename)))
+  path <- file.path("uploads", filename)
+  if (file.exists(path)) {
+    res$status <- 400L
+    error <- list(error = "BAD_REQUEST", detail = paste("A dataset called", filename,
+                                                        "already exists. Please choose a unique name for this dataset."))
+    return(list(status = "failure", errors = list(error), data = NULL))
+  }
+  required_cols <- c("value", "biomarker")
+  missing_cols <- required_cols[!(required_cols %in% colnames(file_body))]
+  if (length(missing_cols) > 0) {
+    res$status <- 400L
+    error <- list(error = "BAD_REQUEST",
+                  detail = paste("Missing required columns:", paste(missing_cols, collapse = ", ")))
+    return(list(status = "failure", errors = list(error), data = NULL))
+  }
+
+  write.csv(file_body, path, row.names = FALSE)
+  return(filename)
+}
+
+target_get_dataset <- function(name) {
+  dat <- read_dataset(name)
+  cols <- setdiff(colnames(dat), c("value", "biomarker", "day"))
+  list(variables = cols, data = jsonlite::toJSON(dat))
+}
+
+target_get_datasets <- function() {
+  files <- list.files("uploads")
+  jsonlite::toJSON(files)
+}
 
-target_post_dataset <- function() {
-  function(data) {
-    # validate CSV and save to file
+target_get_trace <- function(name, biomarker, facet, trace = "age") {
+  dat <- read_dataset(name)
+  cols <- colnames(dat)
+  # facet_def <- strsplit(facet, ":")
+  # facet_var <- facet_def[[1]][1]
+  # facet_level <- facet_def[[1]][2]
+  # if (!(facet_var %in% cols)) {
+  #   porcelain::porcelain_stop(paste("Column", facet_var, "not found in data"),
+  #                             code = "BAD_REQUEST", status_code = 400L)
+  # }
+  # dat <- dat[dat[facet_var] == facet_level & dat["biomarker"] == biomarker,]
+  dat <- dat[dat["biomarker"] == biomarker,]
+  dat$value <- log(dat$value)
+  groups <- split(dat, eval(parse(text = paste("~", trace))))
+  model_result <- lapply(groups, model_out)
+  raw <- lapply(groups, data_out)
+  list(model = model_result, raw = raw)
+}
+
+read_dataset <- function(name) {
+  path <- file.path("uploads", name)
+  if (!file.exists(path)) {
+    porcelain::porcelain_stop(paste("Did not find dataset with name ", name),
+                              code = "BAD_REQUEST", status_code = 404L)
   }
+  dat <- read.csv(path)
+  dat$value <- as.numeric(dat$value)
+  dat
+}
+
+model_out <- function(dat) {
+  if (nrow(dat) > 1000) {
+    m <- mgcv::gam(value ~ s(day, bs = "cs"), data = dat, method = "REML")
+  } else {
+    m <- stats::loess(value ~ day, data = dat, span = 0.75)
+  }
+  range <- range(dat$day, na.rm = TRUE)
+  xseq <- range[1]:range[2]
+  list(x = xseq, y = predict(m, tibble::data_frame(day = xseq)))
+}
+
+data_out <- function(dat) {
+  list(x = dat$day, y = dat$value)
 }

R/router.R

@@ -1,10 +1,20 @@
 build_routes <- function() {
   pr <- porcelain::porcelain$new(validate = TRUE)
+  pr$registerHook(stage = "preserialize", function(data, req, res, value) {
+    res$setHeader("Access-Control-Allow-Origin", "http://localhost:3000")
+    value
+  })
+
   pr$handle(get_root())
   pr$handle(get_version())
-  pr$handle(post_dataset())
+  pr$handle("POST", "/dataset/", function(req, res) target_post_dataset(req, res),
+            serializer = plumber::serializer_unboxed_json())
+  pr$handle(get_dataset())
+  pr$handle(get_datasets())
+  pr$handle(get_trace())
 }
 
+
 get_root <- function() {
   porcelain::porcelain_endpoint$new("GET",
                                     "/",
@@ -19,10 +29,23 @@ get_version <- function() {
                                     returning = porcelain::porcelain_returning_json("Version"))
 }
 
-post_dataset <- function() {
+get_dataset <- function() {
+  porcelain::porcelain_endpoint$new(
+    "GET", "/dataset/<name>",
+    target_get_dataset,
+    returning = porcelain::porcelain_returning_json())
+}
+
+get_datasets <- function() {
+  porcelain::porcelain_endpoint$new(
+    "GET", "/datasets/",
+    target_get_datasets,
+    returning = porcelain::porcelain_returning_json("Datasets"))
+}
+
+get_trace <- function() {
   porcelain::porcelain_endpoint$new(
-    "POST", "/dataset/",
-    target_post_dataset(),
-    porcelain::porcelain_input_body_binary("data", "application/csv"),
-    returning = porcelain::porcelain_returning_json("Data"))
+    "GET", "/dataset/<name>/<biomarker>/<facet>",
+    target_get_trace,
+    returning = porcelain::porcelain_returning_json())
 }

README.md

@@ -9,15 +9,27 @@
 R API for the SeroViz app. Based on the [porcelain](https://github.com/reside-ic/porcelain) framework.
 
 ## Developing
-
 Install dependencies with:
 
-``` r
+```r
 remotes::install_deps(".", dependencies = TRUE)
 ```
 
-## Deploying
+Start the API locally by running:
+
+```r
+devtools::load_all()
+serovizr:::main()
+```
 
+## Testing
+Run tests with:
+
+```r
+devtools::test()
+```
+
+## Deploying
 To build a Docker image:
 
 ``` r

inst/schema/Data.schema.json

@@ -1,20 +1,36 @@
 {
   "$schema": "http://json-schema.org/draft-04/schema#",
-  "type": "array",
-  "items": {
-    "type": "object",
-    "properties": {
-      "biomarker": {
+  "type": "object",
+  "properties": {
+    "variables": {
+      "type": "array",
+      "items": {
         "type": "string"
-      },
-      "value": {
-        "type": "number"
       }
     },
-    "additionalProperties": true,
-    "required": [
-      "biomarker",
-      "value"
-    ]
-  }
+    "data": {
+      "type": "array",
+      "items": {
+        "type": "object",
+        "properties": {
+          "biomarker": {
+            "type": "string"
+          },
+          "value": {
+            "type": "number"
+          }
+        },
+        "additionalProperties": true,
+        "required": [
+          "biomarker",
+          "value"
+        ]
+      }
+    }
+  },
+  "additionalProperties": false,
+  "required": [
+    "data",
+    "variables"
+  ]
 }

inst/schema/Datasets.schema.json

@@ -0,0 +1,7 @@
+{
+  "$schema": "http://json-schema.org/draft-04/schema#",
+  "type": "array",
+  "items": {
+    "type": "string"
+  }
+}

tests/testthat/test-router.R

@@ -0,0 +1,26 @@
+test_that("root endpoint", {
+  res <- target_get_root()
+  expect_equal(res, jsonlite::unbox("Welcome to serovizr"))
+
+  endpoint <- get_root()
+  res_endpoint <- endpoint$run()
+  expect_equal(res_endpoint$status_code, 200)
+  expect_equal(res_endpoint$content_type, "application/json")
+  expect_equal(res_endpoint$data, res)
+
+  router <- build_routes()
+  res_api <- router$request("GET", "/")
+  expect_equal(res_api$status, 200)
+  expect_equal(res_api$body, res_endpoint$body)
+})
+
+test_that("version endpoint", {
+  res <- jsonlite::fromJSON(target_get_version())
+  expect_equal(res, as.character(packageVersion("serovizr")))
+
+  router <- build_routes()
+  res_api <- router$request("GET", "/version")
+  expect_equal(res_api$status, 200)
+  body <- jsonlite::fromJSON(res_api$body)
+  expect_equal(res, body$data)
+})

tests/testthat/test-upload-dataset.R

@@ -0,0 +1,10 @@
+test_that("returns error", {
+  res <- jsonlite::fromJSON(target_post_dataset())
+  expect_equal(res, as.character(packageVersion("serovizr")))
+
+  router <- build_routes()
+  res_api <- router$request("POST", "/dataset/")
+  expect_equal(res_api$status, 200)
+  body <- jsonlite::fromJSON(res_api$body)
+  expect_equal(res, body$data)
+})

tests/testtthat.R

@@ -0,0 +1,4 @@
+library(testthat)
+library(serovizr)
+
+test_check("mintr")