diff --git a/R/api_get_randomization_list.R b/R/api_get_randomization_list.R new file mode 100644 index 0000000..2babe95 --- /dev/null +++ b/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) +} diff --git a/inst/plumber/unbiased_api/study.R b/inst/plumber/unbiased_api/study.R index 93fa34e..dad162e 100644 --- a/inst/plumber/unbiased_api/study.R +++ b/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 //randomization_list +#* @serializer unboxedJSON +#* + +sentryR::with_captured_calls(function(study_id, req, res) { + return( + unbiased:::api_get_rand_list(study_id, req, res) + ) +}) diff --git a/tests/testthat/fixtures/example_db.yml b/tests/testthat/fixtures/example_db.yml new file mode 100644 index 0000000..45b054e --- /dev/null +++ b/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' + diff --git a/tests/testthat/fixtures/example_study.yml b/tests/testthat/fixtures/example_study.yml deleted file mode 100644 index 083c9f6..0000000 --- a/tests/testthat/fixtures/example_study.yml +++ /dev/null @@ -1,42 +0,0 @@ -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 - -arm: - - study_id: 1 - name: 'placebo' - ratio: 2 - # id: 1 - - study_id: 1 - name: 'active' - ratio: 1 - # id: 2 - -stratum: - - study_id: 1 - name: 'gender' - value_type: 'factor' - # id: 1 - -factor_constraint: - - stratum_id: 1 - value: 'F' - - stratum_id: 1 - value: 'M' - -patient: - - study_id: 1 - arm_id: 1 - used: true - # id: 1 - -patient_stratum: - - patient_id: 1 - stratum_id: 1 - fct_value: 'F' diff --git a/tests/testthat/test-DB-0.R b/tests/testthat/test-DB-0.R index ffa510d..1d81bee 100644 --- a/tests/testthat/test-DB-0.R +++ b/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") diff --git a/tests/testthat/test-DB-study.R b/tests/testthat/test-DB-study.R index 54c05a5..9e4ee15 100644 --- a/tests/testthat/test-DB-study.R +++ b/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({ diff --git a/tests/testthat/test-E2E-get-study.R b/tests/testthat/test-E2E-get-study.R index 038c111..d88e63c 100644 --- a/tests/testthat/test-E2E-get-study.R +++ b/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) +})