tests for uploading and getting metadat

R/api.R

@@ -9,6 +9,14 @@ target_get_version <- function() {
 target_post_dataset <- function(req, res) {
   logger::log_info("Parsing multipart form request")
   parsed <- mime::parse_multipart(req)
+  xcol <- parsed$xcol
+  if (is.null(parsed$file$type) || parsed$file$type != "text/csv") {
+    res$status <- 400L
+    msg <- "Invalid file type; please upload file of type text/csv."
+    error <- list(error = "BAD_REQUEST",
+                  detail = msg)
+    return(list(status = "failure", errors = list(error), data = NULL))
+  }
   file_body <- utils::read.csv(parsed$file$datapath)
   filename <- parsed$file$name
   file_ext <- tools::file_ext(filename)
@@ -25,7 +33,7 @@ target_post_dataset <- function(req, res) {
                   detail = msg)
     return(list(status = "failure", errors = list(error), data = NULL))
   }
-  required_cols <- c("value", "biomarker")
+  required_cols <- c("value", "biomarker", xcol)
   missing_cols <- required_cols[!(required_cols %in% colnames(file_body))]
   if (length(missing_cols) > 0) {
     res$status <- 400L
@@ -36,22 +44,38 @@ target_post_dataset <- function(req, res) {
   }
 
   logger::log_info(paste("Saving dataset", filename, "to disk"))
-  utils::write.csv(file_body, path, row.names = FALSE)
+  dir.create(path)
+  utils::write.csv(file_body, file.path(path, "data"), row.names = FALSE)
+  write(xcol, file.path(path, "xcol"))
   porcelain:::response_success(jsonlite::unbox(filename))
 }
 
 target_get_dataset <- function(name) {
-  dat <- read_dataset(name)
-  cols <- setdiff(colnames(dat), c("value", "biomarker", "day"))
+  logger::log_info(paste("Requesting metadata for dataset:", name))
+  dataset <- read_dataset(name)
+  logger::log_info(paste("Found dataset:", name))
+  dat <- dataset$data
+  xcol <- dataset$xcol
+  cols <- setdiff(colnames(dat), c("value", "biomarker", xcol))
+  if (length(cols) == 0) {
+    logger::log_info("No covariates detected")
+  } else {
+    logger::log_info(paste("Detected covariates:",
+                           paste(cols, collapse = ", ")))
+  }
   biomarkers <- unique(dat$biomarker)
+  logger::log_info(paste("Detected biomarkers:",
+                         paste(biomarkers, collapse = ", ")))
   variables <- list()
   for (col in cols) {
     lvls <- unique(dat[, col])
     if (length(lvls) < 12) {
       variables[[col]] <- list(name = jsonlite::unbox(col), levels = lvls)
     }
   }
-  list(variables = unname(variables), biomarkers = biomarkers)
+  list(variables = unname(variables),
+       biomarkers = biomarkers,
+       xcol = jsonlite::unbox(xcol))
 }
 
 target_get_datasets <- function() {
@@ -62,7 +86,7 @@ target_get_trace <- function(name, biomarker, facet = NULL, trace = NULL) {
   logger::log_info(paste("Requesting data from", name,
                          "with biomarker", biomarker))
   logger::log_info(paste("Filtering by facet variables", facet))
-  dat <- read_dataset(name)
+  dat <- read_dataset(name)$dat
   cols <- colnames(dat)
   # facet_def <- strsplit(facet, ":")
   # facet_var <- facet_def[[1]][1]
@@ -97,9 +121,10 @@ read_dataset <- function(name) {
     porcelain::porcelain_stop(paste("Did not find dataset with name ", name),
                               code = "BAD_REQUEST", status_code = 404L)
   }
-  dat <- utils::read.csv(path)
+  dat <- utils::read.csv(file.path(path, "data"))
   dat$value <- as.numeric(dat$value)
-  dat
+  xcol <- readLines(file.path(path, "xcol"))
+  list(data = dat, xcol = xcol)
 }
 
 model_out <- function(dat) {

R/router.R

@@ -7,9 +7,9 @@ build_routes <- function() {
 
   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())
+            serializer = plumber::serializer_unboxed_json(null = "null"))
   pr$handle(get_dataset())
   pr$handle(get_datasets())
   pr$handle(get_trace())
@@ -42,15 +42,15 @@ get_dataset <- function() {
 get_datasets <- function() {
   porcelain::porcelain_endpoint$new(
     "GET",
-    "/datasets/",
+    "/datasets",
     target_get_datasets,
     returning = porcelain::porcelain_returning_json("DatasetNames"))
 }
 
 get_trace <- function() {
   porcelain::porcelain_endpoint$new(
     "GET",
-    "/dataset/<name>/<biomarker>/",
+    "/dataset/<name>/<biomarker>",
     target_get_trace,
     porcelain::porcelain_input_query(facet = "string", trace = "string"),
     returning = porcelain::porcelain_returning_json("DataSeries"))

inst/schema/DatasetMetadata.schema.json

@@ -14,29 +14,14 @@
         "type": "string"
       }
     },
-    "data": {
-      "type": "array",
-      "items": {
-        "type": "object",
-        "properties": {
-          "biomarker": {
-            "type": "string"
-          },
-          "value": {
-            "type": "number"
-          }
-        },
-        "additionalProperties": true,
-        "required": [
-          "biomarker",
-          "value"
-        ]
-      }
+    "xcol": {
+      "type": "string"
     }
   },
   "additionalProperties": false,
   "required": [
     "variables",
-    "biomarkers"
+    "biomarkers",
+    "xcol"
   ]
 }

inst/schema/ErrorDetail.schema.json

@@ -0,0 +1,14 @@
+{
+  "$schema": "http://json-schema.org/draft-04/schema#",
+  "type": "object",
+  "properties": {
+    "error" : {
+      "type": "string"
+    },
+    "detail": {
+      "type": ["string", "null"]
+    }
+  },
+  "additionalProperties": true,
+  "required": [ "error", "detail" ]
+}

inst/schema/ResponseFailure.schema.json

@@ -0,0 +1,20 @@
+{
+  "$schema": "http://json-schema.org/draft-04/schema#",
+  "type": "object",
+  "properties": {
+    "status": {
+      "enum": ["failure"]
+    },
+    "data": {
+      "type": "null"
+    },
+    "errors": {
+      "type": "array",
+      "items": {
+        "$ref": "ErrorDetail.schema.json"
+      }
+    }
+  },
+  "required": ["status", "data", "errors"],
+  "additionalProperties": true
+}

inst/schema/ResponseSuccess.schema.json

@@ -0,0 +1,16 @@
+{
+  "$schema": "http://json-schema.org/draft-04/schema#",
+  "type": "object",
+  "properties": {
+    "status": {
+      "enum": ["success"]
+    },
+    "data": {
+    },
+    "errors": {
+      "type": "null"
+    }
+  },
+  "required": ["status", "data", "errors"],
+  "additionalProperties": false
+}

tests/testthat/helper.R

@@ -15,28 +15,66 @@ make_req <- function(verb = "GET", path = "/", qs = "", body = "", pr = NULL, ..
 
 local_add_dataset <- function(dat, name, env = parent.frame()) {
   filepath <- file.path("uploads", name)
-  write.csv(dat, file.path("uploads", name))
-  withr::defer(fs::file_delete(filepath), envir = env)
+  dir.create(filepath)
+  write.csv(dat, file.path(filepath, "data"), row.names = FALSE)
+  write("day", file.path(filepath, "xcol"))
+  withr::defer(fs::dir_delete(filepath), envir = env)
   name
 }
 
-local_POST_dataset_request <- function(dat, name, env = parent.frame()) {
+local_POST_dataset_request <- function(dat, filename, xcol = "day",
+                                       env = parent.frame()) {
   EOL <- "\r\n"
   boundary <- "------WebKitFormBoundaryvbfCGA1r00d8B0Vv"
   request_body <- paste0(boundary, EOL,
-                sprintf("Content-Disposition: form-data; name=\"file\"; filename=\"%s\"", name),
-                EOL,
-                "Content-Type: text/csv", EOL, EOL,
-                readr::format_csv(dat), EOL, EOL,
-                boundary, "--")
-  filepath <- file.path("uploads", name)
+                         sprintf("Content-Disposition: form-data; name=\"file\"; filename=\"%s\"", filename),
+                         EOL,
+                         "Content-Type: text/csv", EOL, EOL,
+                         readr::format_csv(dat, eol = EOL), EOL,
+                         boundary, EOL,
+                         "Content-Disposition: form-data; name=\"xcol\"", EOL, EOL,
+                         xcol, EOL,
+                         boundary, "--")
+  filepath <- file.path("uploads", filename)
+  withr::defer({
+    if (fs::file_exists(filepath)) {
+      fs::file_delete(filepath)
+    }
+  }, envir = env)
+
+  make_req("POST", "/dataset",
+           body = request_body,
+           CONTENT_LENGTH = nchar(request_body),
+           CONTENT_TYPE = "multipart/form-data; boundary=----WebKitFormBoundaryvbfCGA1r00d8B0Vv")
+}
+
+local_POST_dataset_request_bad_file <- function(env = parent.frame()) {
+  EOL <- "\r\n"
+  boundary <- "------WebKitFormBoundaryvbfCGA1r00d8B0Vv"
+  request_body <- paste0(boundary, EOL,
+                         sprintf("Content-Disposition: form-data; name=\"file\"; filename=\"%s\"", filename),
+                         EOL,
+                         "Content-Type: image/png", EOL, EOL,
+                         "1234", EOL,
+                         boundary, EOL,
+                         "Content-Disposition: form-data; name=\"xcol\"", EOL, EOL,
+                         xcol, EOL,
+                         boundary, "--")
+  filepath <- file.path("uploads", filename)
   withr::defer({
     if (fs::file_exists(filepath)) {
       fs::file_delete(filepath)
     }
   }, envir = env)
-  make_req("POST", "/dataset/",
+
+  make_req("POST", "/dataset",
            body = request_body,
-           CONTENT_LENGTH = length(request_body),
+           CONTENT_LENGTH = nchar(request_body),
            CONTENT_TYPE = "multipart/form-data; boundary=----WebKitFormBoundaryvbfCGA1r00d8B0Vv")
-}
+}
+
+validate_failure_schema <- function(res) {
+  porcelain:::porcelain_validator("ResponseFailure",
+                                  root = schema_root,
+                                  query = NULL)(res)
+}

tests/testthat/setup.R

@@ -3,3 +3,5 @@ dir.create("uploads")
 
 # Run after all tests
 withr::defer(fs::dir_delete("uploads"), teardown_env())
+
+schema_root <- file.path(system.file("schema", package = "serovizr"))

tests/testthat/test-router.R

@@ -25,24 +25,52 @@ test_that("GET /version", {
   expect_equal(unclass(res), unclass(body$data))
 })
 
-test_that("POST /dataset/", {
+test_that("POST /dataset", {
   router <- build_routes()
-  request <- local_POST_dataset_request(data.frame(biomarker = "ab", value = 1, day = 1:10),
-                                             "testdataset")
-  res_upload <- router$call(request)
-  expect_equal(res_upload$status, 200)
-  body <- jsonlite::fromJSON(res_upload$body)
+  request <- local_POST_dataset_request(data.frame(biomarker = "ab",
+                                                   value = 1,
+                                                   day = 1:10),
+                                        "testdataset")
+  res <- router$call(request)
+  expect_equal(res$status, 200)
+  body <- jsonlite::fromJSON(res$body)
   expect_equal(body$data, "testdataset")
+  porcelain:::porcelain_validator("ResponseSuccess",
+                                  root = schema_root,
+                                  query = NULL)(res$body)
+  porcelain:::porcelain_validator("UploadResult",
+                                  root = schema_root,
+                                  query = NULL)(
+    jsonlite::toJSON(body$data, auto_unbox = TRUE)
+  )
 })
 
-test_that("GET /datasets/", {
+test_that("GET /datasets", {
   local_add_dataset(data.frame(biomarker = "ab", value = 1, day = 1:10),
                     "testdataset")
   local_add_dataset(data.frame(biomarker = "ab", value = 1, day = 1:10),
                     "anotherdataset")
   router <- build_routes()
-  res <- router$request("GET", "/datasets/")
+  res <- router$request("GET", "/datasets")
   expect_equal(res$status, 200)
   body <- jsonlite::fromJSON(res$body)
   expect_equal(body$data, c("anotherdataset", "testdataset"))
 })
+
+test_that("GET /dataset", {
+  local_add_dataset(data.frame(biomarker = c("ab", "ba"),
+                               value = 1,
+                               day = 1:10,
+                               age = "0-5",
+                               sex = c("M", "F")),
+                    "testdataset")
+  router <- build_routes()
+  res <- router$request("GET", "/dataset/testdataset")
+  expect_equal(res$status, 200)
+  body <- jsonlite::fromJSON(res$body)
+  str(body$data$variables)
+  expect_equal(body$data$variables$name, c("age", "sex"))
+  expect_equal(body$data$variables$levels, list(c("0-5"), c("M", "F")))
+  expect_equal(body$data$biomarkers, c("ab", "ba"))
+  expect_equal(body$data$xcol, "day")
+})