Skip to content

Commit

Permalink
Merge pull request #46 from ttscience/44-adapting-the-code-to-changes…
Browse files Browse the repository at this point in the history 
…-in-code-coverage

Added new tests for API
  • Loading branch information
@lwalejko
lwalejko authored Feb 9, 2024
2 parents b9486ad + 48b8c75 commit 1b56e5a
Show file tree
Hide file tree
Showing 6 changed files with 587 additions and 256 deletions.
179 changes: 76 additions & 103 deletions R/api_create_study.R
View file
Original file line number Diff line number Diff line change
@@ -1,139 +1,112 @@
api__minimization_pocock <- function( # nolint: cyclocomp_linter.
api__minimization_pocock <- function(
# nolint: cyclocomp_linter.
identifier, name, method, arms, covariates, p, req, res) {
validation_errors <- vector()
collection <- checkmate::makeAssertCollection()

err <- checkmate::check_character(name, min.chars = 1, max.chars = 255)
if (err != TRUE) {
validation_errors <- unbiased:::append_error(
validation_errors, "name", err
)
}
checkmate::assert(
checkmate::check_character(name, min.chars = 1, max.chars = 255),
.var.name = "name",
add = collection
)

err <- checkmate::check_character(identifier, min.chars = 1, max.chars = 12)
if (err != TRUE) {
validation_errors <- unbiased:::append_error(
validation_errors,
"identifier",
err
)
}
checkmate::assert(
checkmate::check_character(identifier, min.chars = 1, max.chars = 12),
.var.name = "identifier",
add = collection
)

err <- checkmate::check_choice(method, choices = c("range", "var", "sd"))
if (err != TRUE) {
validation_errors <- unbiased:::append_error(
validation_errors,
"method",
err
)
}
checkmate::assert(
checkmate::check_choice(method, choices = c("range", "var", "sd")),
.var.name = "method",
add = collection
)

err <-
checkmate::assert(
checkmate::check_list(
arms,
types = "integerish",
any.missing = FALSE,
min.len = 2,
names = "unique"
)
if (err != TRUE) {
validation_errors <- unbiased:::append_error(
validation_errors,
"arms",
err
)
}
),
.var.name = "arms",
add = collection
)

err <-
checkmate::assert(
checkmate::check_list(
covariates,
types = c("numeric", "list", "character"),
any.missing = FALSE,
min.len = 2,
min.len = 1,
names = "unique"
)
if (err != TRUE) {
validation_errors <-
unbiased:::append_error(validation_errors, "covariates", err)
}
),
.var.name = "covariates3",
add = collection
)

response <- list()
for (c_name in names(covariates)) {
c_content <- covariates[[c_name]]

err <- checkmate::check_list(
c_content,
any.missing = FALSE,
len = 2,
checkmate::assert(
checkmate::check_list(
c_content,
any.missing = FALSE,
len = 2,
),
.var.name = "covariates1",
add = collection
)
if (err != TRUE) {
validation_errors <-
unbiased:::append_error(
validation_errors,
glue::glue("covariates[{c_name}]"),
err
)
}
err <- checkmate::check_names(
names(c_content),
permutation.of = c("weight", "levels"),

checkmate::assert(
checkmate::check_names(
names(c_content),
permutation.of = c("weight", "levels"),
),
.var.name = "covariates2",
add = collection
)
if (err != TRUE) {
validation_errors <-
unbiased:::append_error(
validation_errors,
glue::glue("covariates[{c_name}]"),
err
)
}

# check covariate weight
err <- checkmate::check_numeric(c_content$weight,
lower = 0,
finite = TRUE,
len = 1,
null.ok = FALSE
checkmate::assert(
checkmate::check_numeric(c_content$weight,
lower = 0,
finite = TRUE,
len = 1,
null.ok = FALSE
),
.var.name = "weight",
add = collection
)
if (err != TRUE) {
validation_errors <-
unbiased:::append_error(
validation_errors,
glue::glue("covariates[{c_name}][weight]"),
err
)
}

err <- checkmate::check_character(c_content$levels,
min.chars = 1,
min.len = 2,
unique = TRUE

checkmate::assert(
checkmate::check_character(c_content$levels,
min.chars = 1,
min.len = 2,
unique = TRUE
),
.var.name = "levels",
add = collection
)
if (err != TRUE) {
validation_errors <-
unbiased:::append_error(
validation_errors,
glue::glue("covariates[{c_name}][levels]"),
err
)
}
}

# check probability
p <- as.numeric(p)
err <- checkmate::check_numeric(p, lower = 0, upper = 1, len = 1)
if (err != TRUE) {
validation_errors <-
unbiased:::append_error(
validation_errors,
"p",
err
)
}
checkmate::assert(
checkmate::check_numeric(p,
lower = 0, upper = 1, len = 1,
any.missing = FALSE, null.ok = FALSE
),
.var.name = "p",
add = collection
)


if (length(validation_errors) > 0) {
if (length(collection$getMessages()) > 0) {
res$status <- 400
return(list(
error = "Input validation failed",
validation_errors = validation_errors
error = "There was a problem with the input data to create the study",
validation_errors = collection$getMessages()
))
}

Expand Down Expand Up @@ -167,7 +140,7 @@ api__minimization_pocock <- function( # nolint: cyclocomp_linter.
if (!is.null(r$error)) {
res$status <- 503
return(list(
error = "There was a problem creating the study",
error = "There was a problem saving created study to the database",
details = r$error
))
}
Expand Down
158 changes: 77 additions & 81 deletions R/api_randomize.R
View file
Original file line number Diff line number Diff line change
@@ -1,84 +1,3 @@
api__randomize_patient <- function(study_id, current_state, req, res) {
collection <- checkmate::makeAssertCollection()

db_connection_pool <- get("db_connection_pool")

# Check whether study with study_id exists
checkmate::assert(
checkmate::check_subset(
x = req$args$study_id,
choices = dplyr::tbl(db_connection_pool, "study") |>
dplyr::select(id) |>
dplyr::pull()
),
.var.name = "Study ID",
add = collection
)

# Retrieve study details, especially the ones about randomization
method_randomization <-
dplyr::tbl(db_connection_pool, "study") |>
dplyr::filter(.data$id == study_id) |>
dplyr::select(method) |>
dplyr::pull()

checkmate::assert(
checkmate::check_scalar(method_randomization, null.ok = FALSE),
.var.name = "Randomization method",
add = collection
)

if (length(collection$getMessages()) > 0) {
res$status <- 400
return(list(
error = "Study input validation failed",
validation_errors = collection$getMessages()
))
}

# Dispatch based on randomization method to parse parameters
params <-
switch(method_randomization,
minimisation_pocock = tryCatch(
{
do.call(
parse_pocock_parameters,
list(db_connection_pool, study_id, current_state)
)
},
error = function(e) {
res$status <- 400
res$body <- glue::glue("Error message: {conditionMessage(e)}")
logger::log_error("Error: {err}", err = e)
}
)
)

arm_name <-
switch(method_randomization,
minimisation_pocock = tryCatch(
{
do.call(unbiased:::randomize_minimisation_pocock, params)
},
error = function(e) {
res$status <- 400
res$body <- glue::glue("Error message: {conditionMessage(e)}")
logger::log_error("Error: {err}", err = e)
}
)
)

arm <- dplyr::tbl(db_connection_pool, "arm") |>
dplyr::filter(study_id == !!study_id & .data$name == arm_name) |>
dplyr::select(arm_id = "id", "name", "ratio") |>
dplyr::collect()

unbiased:::save_patient(study_id, arm$arm_id) |>
dplyr::mutate(arm_name = arm$name) |>
dplyr::rename(patient_id = "id") |>
as.list()
}

parse_pocock_parameters <-
function(db_connetion_pool, study_id, current_state) {
parameters <-
Expand Down Expand Up @@ -129,3 +48,80 @@ parse_pocock_parameters <-

return(params)
}

api__randomize_patient <- function(study_id, current_state, req, res) {
collection <- checkmate::makeAssertCollection()

db_connection_pool <- get("db_connection_pool")

# Check whether study with study_id exists
checkmate::assert(
checkmate::check_subset(
x = req$args$study_id,
choices = dplyr::tbl(db_connection_pool, "study") |>
dplyr::select(id) |>
dplyr::pull()
),
.var.name = "study_id",
add = collection
)

# Retrieve study details, especially the ones about randomization
method_randomization <-
dplyr::tbl(db_connection_pool, "study") |>
dplyr::filter(id == study_id) |>
dplyr::select("method") |>
dplyr::pull()

checkmate::assert(
checkmate::check_scalar(method_randomization, null.ok = FALSE),
.var.name = "method_randomization",
add = collection
)

if (length(collection$getMessages()) > 0) {
res$status <- 400
return(list(
error = "There was a problem with the randomization preparation",
validation_errors = collection$getMessages()
))
}

# Dispatch based on randomization method to parse parameters
params <-
switch(method_randomization,
minimisation_pocock = do.call(
parse_pocock_parameters, list(db_connection_pool, study_id, current_state)
)
)

arm_name <-
switch(method_randomization,
minimisation_pocock = do.call(
unbiased:::randomize_minimisation_pocock, params
)
)

arm <- dplyr::tbl(db_connection_pool, "arm") |>
dplyr::filter(study_id == !!study_id & .data$name == arm_name) |>
dplyr::select("arm_id" = "id", "name", "ratio") |>
dplyr::collect()

randomized_patient <- unbiased:::save_patient(study_id, arm$arm_id)

if (!is.null(randomized_patient$error)) {
res$status <- 503
return(list(
error = "There was a problem saving randomized patient to the database",
details = randomized_patient$error
))
} else {
randomized_patient <-
randomized_patient |>
dplyr::mutate(arm_name = arm$name) |>
dplyr::rename(patient_id = id) |>
as.list()

return(randomized_patient)
}
}
Loading

0 comments on commit 1b56e5a

Please sign in to comment.