Merge pull request #68 from ttscience/51-get-randomization-list

#51 Issue: get randomization list + tests

R/api_get_randomization_list.R

@@ -0,0 +1,37 @@
+api_get_rand_list <- function(study_id, req, res) {
+  db_connection_pool <- get("db_connection_pool")
+
+  study_id <- req$args$study_id
+
+  is_study <-
+    checkmate::test_true(
+      dplyr::tbl(db_connection_pool, "study") |>
+        dplyr::filter(id == study_id) |>
+        dplyr::collect() |>
+        nrow() > 0
+    )
+
+  if (!is_study) {
+    res$status <- 404
+    return(list(
+      error = "Study not found"
+    ))
+  }
+
+  patients <-
+    dplyr::tbl(db_connection_pool, "patient") |>
+    dplyr::filter(study_id == !!study_id) |>
+    dplyr::left_join(
+      dplyr::tbl(db_connection_pool, "arm") |>
+        dplyr::select(arm_id = id, arm = name),
+      by = "arm_id"
+    ) |>
+    dplyr::select(
+      patient_id = id, arm, used, sys_period
+    ) |>
+    dplyr::collect() |>
+    dplyr::mutate(sys_period = as.character(gsub("\\[\"|\\+00\",\\)", "", sys_period))) |>
+    dplyr::mutate(sys_period = as.POSIXct(sys_period))
+
+  return(patients)
+}

inst/plumber/unbiased_api/study.R

@@ -74,3 +74,18 @@ sentryR::with_captured_calls(function(study_id, req, res) {
     unbiased:::api_get_study_records(study_id, req, res)
   )
 })
+
+#* Get randomization list
+#*
+#* @param study_id:int Study identifier
+#*
+#* @tag read
+#* @get /<study_id:int>/randomization_list
+#* @serializer unboxedJSON
+#*
+
+sentryR::with_captured_calls(function(study_id, req, res) {
+  return(
+    unbiased:::api_get_rand_list(study_id, req, res)
+  )
+})

tests/testthat/fixtures/example_db.yml

@@ -0,0 +1,99 @@
+study:
+  - identifier: 'TEST'
+    name: 'Test Study'
+    method: 'minimisation_pocock'
+    parameters: '{"method": "var", "p": 0.85, "weights": {"gender": 1}}'
+    # Waring: id is set automatically by the database
+    # do not set it manually because sequences will be out of sync
+    # and you will get errors
+    # id: 1
+  - identifier: 'TEST2'
+    name: 'Test Study 2'
+    method: 'minimisation_pocock'
+    parameters: '{"method": "var", "p": 0.85, "weights": {"gender": 1}}'
+    # id: 2
+
+arm:
+  - study_id: 1
+    name: 'placebo'
+    ratio: 2
+    # id: 1
+  - study_id: 1
+    name: 'active'
+    ratio: 1
+    # id: 2
+  - study_id: 2
+    name: 'placebo'
+    ratio: 2
+    # id: 3
+  - study_id: 2
+    name: 'active'
+    ratio: 1
+    # id: 4
+
+stratum:
+  - study_id: 1
+    name: 'gender'
+    value_type: 'factor'
+    # id: 1
+  - study_id: 2
+    name: 'gender'
+    value_type: 'factor'
+    # id: 2
+
+factor_constraint:
+  - stratum_id: 1
+    value: 'F'
+  - stratum_id: 1
+    value: 'M'
+  - stratum_id: 2
+    value: 'F'
+  - stratum_id: 2
+    value: 'M'
+
+patient:
+  - study_id: 1
+    arm_id: 1
+    used: true
+    # id: 1
+  - study_id: 1
+    arm_id: 2
+    used: true
+    # id: 2
+  - study_id: 1
+    arm_id: 2
+    used: true
+    # id: 3
+  - study_id: 1
+    arm_id: 1
+    used: true
+    # id: 4
+  - study_id: 2
+    arm_id: 3
+    used: true
+    # id: 5
+  - study_id: 2
+    arm_id: 4
+    used: true
+    # id: 6
+
+patient_stratum:
+  - patient_id: 1
+    stratum_id: 1
+    fct_value: 'F'
+  - patient_id: 2
+    stratum_id: 1
+    fct_value: 'M'
+  - patient_id: 3
+    stratum_id: 1
+    fct_value: 'F'
+  - patient_id: 4
+    stratum_id: 1
+    fct_value: 'M'
+  - patient_id: 5
+    stratum_id: 2
+    fct_value: 'M'
+  - patient_id: 6
+    stratum_id: 2
+    fct_value: 'F'
+

tests/testthat/test-DB-0.R

@@ -11,7 +11,7 @@ test_that("database contains base tables", {
   conn <- pool::localCheckout(
     get("db_connection_pool", envir = globalenv())
   )
-  with_db_fixtures("fixtures/example_study.yml")
+  with_db_fixtures("fixtures/example_db.yml")
   expect_contains(
     DBI::dbListTables(conn),
     c(versioned_tables, nonversioned_tables)
@@ -22,7 +22,7 @@ test_that("database contains history tables", {
   conn <- pool::localCheckout(
     get("db_connection_pool", envir = globalenv())
   )
-  with_db_fixtures("fixtures/example_study.yml")
+  with_db_fixtures("fixtures/example_db.yml")
   expect_contains(
     DBI::dbListTables(conn),
     glue::glue("{versioned_tables}_history")

tests/testthat/test-DB-study.R

@@ -4,7 +4,7 @@ pool <- get("db_connection_pool", envir = globalenv())
 
 test_that("it is enough to provide a name, an identifier, and a method id", {
   conn <- pool::localCheckout(pool)
-  with_db_fixtures("fixtures/example_study.yml")
+  with_db_fixtures("fixtures/example_db.yml")
   testthat::expect_no_error({
     dplyr::tbl(conn, "study") |>
       dplyr::rows_append(
@@ -23,7 +23,7 @@ new_study_id <- as.integer(1)
 
 test_that("deleting archivizes a study", {
   conn <- pool::localCheckout(pool)
-  with_db_fixtures("fixtures/example_study.yml")
+  with_db_fixtures("fixtures/example_db.yml")
   testthat::expect_no_error({
     dplyr::tbl(conn, "study") |>
       dplyr::rows_delete(
@@ -48,7 +48,7 @@ test_that("deleting archivizes a study", {
 
 test_that("can't push arm with negative ratio", {
   conn <- pool::localCheckout(pool)
-  with_db_fixtures("fixtures/example_study.yml")
+  with_db_fixtures("fixtures/example_db.yml")
   testthat::expect_error(
     {
       dplyr::tbl(conn, "arm") |>
@@ -67,7 +67,7 @@ test_that("can't push arm with negative ratio", {
 
 test_that("can't push stratum other than factor or numeric", {
   conn <- pool::localCheckout(pool)
-  with_db_fixtures("fixtures/example_study.yml")
+  with_db_fixtures("fixtures/example_db.yml")
   testthat::expect_error(
     {
       tbl(conn, "stratum") |>
@@ -86,7 +86,7 @@ test_that("can't push stratum other than factor or numeric", {
 
 test_that("can't push stratum level outside of defined levels", {
   conn <- pool::localCheckout(pool)
-  with_db_fixtures("fixtures/example_study.yml")
+  with_db_fixtures("fixtures/example_db.yml")
   # create a new patient
   return <-
     testthat::expect_no_error({
@@ -135,7 +135,7 @@ test_that("can't push stratum level outside of defined levels", {
 
 test_that("numerical constraints are enforced", {
   conn <- pool::localCheckout(pool)
-  with_db_fixtures("fixtures/example_study.yml")
+  with_db_fixtures("fixtures/example_db.yml")
   added_patient_id <- as.integer(1)
   return <-
     testthat::expect_no_error({

tests/testthat/test-E2E-get-study.R

@@ -4,7 +4,7 @@ test_that("correct request to reads studies with the structure of the returned r
   conn <- pool::localCheckout(
     get("db_connection_pool", envir = globalenv())
   )
-  with_db_fixtures("fixtures/example_study.yml")
+  with_db_fixtures("fixtures/example_db.yml")
 
   response <- request(api_url) |>
     req_url_path("study", "") |>
@@ -40,7 +40,7 @@ test_that("correct request to reads studies with the structure of the returned r
   testthat::expect_equal(length(response_body), n_studies)
 })
 
-test_that("correct request to reads records for chosen study_id with the structure of the returned result", {
+test_that("requests to reads records for chosen study_id with the structure of the returned result", {
   response <- request(api_url) |>
     req_url_path("study", "minimisation_pocock") |>
     req_method("POST") |>
@@ -110,3 +110,59 @@ test_that("correct request to reads records for chosen study_id with the structu
 
   testthat::expect_equal(response_study_id$status, 404)
 })
+
+test_that("correct request to reads randomization list with the structure of the returned result", {
+  source("./test-helpers.R")
+
+  conn <- pool::localCheckout(
+    get("db_connection_pool", envir = globalenv())
+  )
+
+  with_db_fixtures("fixtures/example_db.yml")
+
+  response <-
+    request(api_url) |>
+    req_url_path("/study/1/randomization_list") |>
+    req_method("GET") |>
+    req_perform()
+
+  response_body <-
+    response |>
+    resp_body_json()
+
+  testthat::expect_equal(response$status_code, 200)
+
+  checkmate::expect_names(
+    names(response_body[[1]]),
+    identical.to = c("patient_id", "arm", "used", "sys_period")
+  )
+
+  checkmate::expect_set_equal(
+    x = response_body |>
+      dplyr::bind_rows() |>
+      dplyr::pull(patient_id),
+    y = c(1, 2, 3, 4)
+  )
+})
+
+test_that("incorrect input study_id to reads randomization list", {
+  source("./test-helpers.R")
+
+  conn <- pool::localCheckout(
+    get("db_connection_pool", envir = globalenv())
+  )
+  with_db_fixtures("fixtures/example_db.yml")
+
+  response <-
+    tryCatch(
+      {
+        request(api_url) |>
+          req_url_path("study/100/randomization_list") |>
+          req_method("GET") |>
+          req_perform()
+      },
+      error = function(e) e
+    )
+
+  testthat::expect_equal(response$status, 404)
+})