diff --git a/.devcontainer/Dockerfile b/.devcontainer/Dockerfile index 02fffe9..392966e 100644 --- a/.devcontainer/Dockerfile +++ b/.devcontainer/Dockerfile @@ -6,8 +6,16 @@ RUN apt update && apt-get install -y --no-install-recommends \ # sodium libsodium-dev \ # RPostgres - libpq-dev libssl-dev postgresql-client + libpq-dev libssl-dev postgresql-client \ + # R_X11 + libxt-dev RUN pip install watchdog[watchmedo] ENV RENV_CONFIG_SANDBOX_ENABLED=FALSE + +# Install database migration tool +RUN curl -L https://packagecloud.io/golang-migrate/migrate/gpgkey | apt-key add - && \ + echo "deb https://packagecloud.io/golang-migrate/migrate/ubuntu/ focal main" > /etc/apt/sources.list.d/migrate.list && \ + apt-get update && \ + apt-get install -y migrate diff --git a/.devcontainer/docker-compose.yml b/.devcontainer/docker-compose.yml index e6c3cb5..a341a70 100644 --- a/.devcontainer/docker-compose.yml +++ b/.devcontainer/docker-compose.yml @@ -41,9 +41,7 @@ services: - "5454:80" db: - build: - context: .. - dockerfile: Dockerfile.postgres + image: ghcr.io/ttscience/postgres-temporal-tables/postgres-temporal-tables:latest restart: unless-stopped volumes: - postgres-data:/var/lib/postgresql/data diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml deleted file mode 100644 index 08a141c..0000000 --- a/.github/workflows/R-CMD-check.yaml +++ /dev/null @@ -1,36 +0,0 @@ -# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples -# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help -on: - push: - branches: [main, devel] - pull_request: - branches: [main, devel] - -name: Tests - -jobs: - R-CMD-check: - runs-on: ubuntu-latest - - name: Ubuntu (latest) - - strategy: - fail-fast: false - - env: - GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - R_KEEP_PKG_SOURCE: yes - - steps: - - uses: actions/checkout@v3 - - - uses: r-lib/actions/setup-pandoc@v2 - - - name: Build API image - run: docker build -t unbiased --build-arg github_sha=${{ github.sha }} . - - - name: Build custom PostgreSQL image - run: docker build -t temporal_postgres -f Dockerfile.postgres . - - - name: Run tests - run: docker compose -f "docker-compose.test.yaml" up --abort-on-container-exit --exit-code-from tests diff --git a/.github/workflows/document.yaml b/.github/workflows/document.yaml new file mode 100644 index 0000000..8ac7bab --- /dev/null +++ b/.github/workflows/document.yaml @@ -0,0 +1,42 @@ +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +on: + push: + paths: ["R/**"] + +name: Document + +jobs: + document: + runs-on: ubuntu-latest + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + steps: + - name: Checkout repo + uses: actions/checkout@v4 + with: + fetch-depth: 0 + + - name: Setup R + uses: r-lib/actions/setup-r@v2 + with: + use-public-rspm: true + + - name: Install dependencies + uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::roxygen2 + needs: roxygen2 + + - name: Document + run: roxygen2::roxygenise() + shell: Rscript {0} + + - name: Commit and push changes + run: | + git config --local user.name "$GITHUB_ACTOR" + git config --local user.email "$GITHUB_ACTOR@users.noreply.github.com" + git add man/\* NAMESPACE DESCRIPTION + git commit -m "Update documentation" || echo "No changes to commit" + git pull --ff-only + git push origin diff --git a/.github/workflows/lint.yaml b/.github/workflows/lint.yaml new file mode 100644 index 0000000..5d4cb21 --- /dev/null +++ b/.github/workflows/lint.yaml @@ -0,0 +1,32 @@ +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +on: + push: + branches: [main, devel] + pull_request: + branches: [main, devel] + +name: lint + +jobs: + lint: + runs-on: ubuntu-latest + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + steps: + - uses: actions/checkout@v4 + + - uses: r-lib/actions/setup-r@v2 + with: + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::lintr, local::. + needs: lint + + - name: Lint + run: lintr::lint_package() + shell: Rscript {0} + env: + LINTR_ERROR_ON_LINT: true diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml new file mode 100644 index 0000000..9efc03f --- /dev/null +++ b/.github/workflows/test-coverage.yaml @@ -0,0 +1,79 @@ +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +on: + push: + branches: [main, devel] + pull_request: + branches: [main, devel] + +name: test-coverage + +jobs: + test-coverage: + runs-on: ubuntu-latest + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + POSTGRES_DB: postgres + POSTGRES_HOST: 127.0.0.1 + POSTGRES_PORT: 5432 + POSTGRES_USER: postgres + POSTGRES_PASSWORD: postgres + + services: + postgres: + image: ghcr.io/ttscience/postgres-temporal-tables/postgres-temporal-tables:latest + env: + POSTGRES_PASSWORD: postgres + options: >- + --health-cmd pg_isready + --health-interval 10s + --health-timeout 5s + --health-retries 5 + ports: + - 5432:5432 + + steps: + - uses: actions/checkout@v2 + with: + fetch-depth: 1 + + - uses: r-lib/actions/setup-r@v2 + with: + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::covr + needs: coverage + + - name: Install migrate + run: | + curl -L https://packagecloud.io/golang-migrate/migrate/gpgkey | \ + sudo apt-key add - && \ + echo "deb https://packagecloud.io/golang-migrate/migrate/ubuntu/ focal main" | \ + sudo tee /etc/apt/sources.list.d/migrate.list && \ + sudo apt-get update && \ + sudo apt-get install -y migrate + + - name: Test coverage + run: | + covr::codecov( + quiet = FALSE, + clean = FALSE, + install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package") + ) + shell: Rscript {0} + + - name: Show testthat output + if: always() + run: | + ## -------------------------------------------------------------------- + find ${{ runner.temp }}/package -name 'testthat.Rout*' -exec cat '{}' \; || true + shell: bash + + - name: Upload test results + if: failure() + uses: actions/upload-artifact@v3 + with: + name: coverage-test-failures + path: ${{ runner.temp }}/package diff --git a/DESCRIPTION b/DESCRIPTION index c2b6c56..e1ea907 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -47,5 +47,5 @@ RdMacros: mathjaxr Config/testthat/edition: 3 Encoding: UTF-8 Roxygen: list(markdown = TRUE) -RoxygenNote: 7.2.3 +RoxygenNote: 7.3.1 URL: https://ttscience.github.io/unbiased/ diff --git a/Dockerfile b/Dockerfile index 095b19b..1407623 100644 --- a/Dockerfile +++ b/Dockerfile @@ -9,7 +9,14 @@ RUN apt update && apt-get install -y --no-install-recommends \ # sodium libsodium-dev \ # RPostgres - libpq-dev libssl-dev postgresql-client + libpq-dev libssl-dev postgresql-client \ + curl gnupg2 + +# Install database migration tool +RUN curl -L https://packagecloud.io/golang-migrate/migrate/gpgkey | apt-key add - && \ + echo "deb https://packagecloud.io/golang-migrate/migrate/ubuntu/ focal main" > /etc/apt/sources.list.d/migrate.list && \ + apt-get update && \ + apt-get install -y migrate ENV RENV_CONFIG_SANDBOX_ENABLED=FALSE @@ -33,5 +40,4 @@ EXPOSE 3838 ARG github_sha ENV GITHUB_SHA=${github_sha} -CMD ["R", "-e", "unbiased::run_unbiased()"] - +CMD ["R", "-e", "unbiased::run_unbiased()"] \ No newline at end of file diff --git a/Dockerfile.postgres b/Dockerfile.postgres deleted file mode 100644 index b30d73b..0000000 --- a/Dockerfile.postgres +++ /dev/null @@ -1,15 +0,0 @@ -# Start with the official PostgreSQL image based on Debian -FROM postgres:16 - -# Run package updates and install necessary packages -RUN apt-get update \ - # Install PostgreSQL development headers and PGXN client - && apt-get install -y \ - postgresql-server-dev-16 \ - pgxnclient \ - make \ - gcc \ - # Install the 'temporal_tables' extension using PGXN - && pgxn install temporal_tables \ - # Clear apt cache to reduce image size - && rm -rf /var/lib/apt/lists/* diff --git a/NAMESPACE b/NAMESPACE index c96d202..18be837 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,11 +1,9 @@ # Generated by roxygen2: do not edit by hand -export(list_studies) +export(create_db_connection_pool) export(randomize_minimisation_pocock) export(randomize_simple) -export(read_study_details) export(run_unbiased) -export(study_exists) import(checkmate) import(dplyr) import(mathjaxr) diff --git a/R/api_create_study.R b/R/api_create_study.R new file mode 100644 index 0000000..a6a0157 --- /dev/null +++ b/R/api_create_study.R @@ -0,0 +1,183 @@ +api__minimization_pocock <- function( # nolint: cyclocomp_linter. + identifier, name, method, arms, covariates, p, req, res) { + validation_errors <- vector() + + err <- checkmate::check_character(name, min.chars = 1, max.chars = 255) + if (err != TRUE) { + validation_errors <- unbiased:::append_error( + validation_errors, "name", err + ) + } + + err <- checkmate::check_character(identifier, min.chars = 1, max.chars = 12) + if (err != TRUE) { + validation_errors <- unbiased:::append_error( + validation_errors, + "identifier", + err + ) + } + + err <- checkmate::check_choice(method, choices = c("range", "var", "sd")) + if (err != TRUE) { + validation_errors <- unbiased:::append_error( + validation_errors, + "method", + err + ) + } + + err <- + 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 + ) + } + + err <- + checkmate::check_list( + covariates, + types = c("numeric", "list", "character"), + any.missing = FALSE, + min.len = 2, + names = "unique" + ) + if (err != TRUE) { + validation_errors <- + unbiased:::append_error(validation_errors, "covariates", err) + } + + response <- list() + for (c_name in names(covariates)) { + c_content <- covariates[[c_name]] + + err <- checkmate::check_list( + c_content, + any.missing = FALSE, + len = 2, + ) + 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"), + ) + 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 + ) + 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 + ) + 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 + ) + } + + if (length(validation_errors) > 0) { + res$status <- 400 + return(list( + error = "Input validation failed", + validation_errors = validation_errors + )) + } + + similar_studies <- unbiased:::get_similar_studies(name, identifier) + + strata <- purrr::imap(covariates, function(covariate, name) { + list( + name = name, + levels = covariate$levels, + value_type = "factor" + ) + }) + weights <- lapply(covariates, function(covariate) covariate$weight) + + # Write study to DB ------------------------------------------------------- + r <- unbiased:::create_study( + name = name, + identifier = identifier, + method = "minimisation_pocock", + parameters = list( + method = method, + p = p, + weights = weights + ), + arms = arms, + strata = strata + ) + + # Response ---------------------------------------------------------------- + + if (!is.null(r$error)) { + res$status <- 503 + return(list( + error = "There was a problem creating the study", + details = r$error + )) + } + + response <- list( + study = r$study + ) + if (nrow(similar_studies) >= 1) { + response <- c(response, list(similar_studies = similar_studies)) + } + + return(response) +} diff --git a/R/api_randomize.R b/R/api_randomize.R new file mode 100644 index 0000000..9cb6e31 --- /dev/null +++ b/R/api_randomize.R @@ -0,0 +1,131 @@ +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 <- + dplyr::tbl(db_connetion_pool, "study") |> + dplyr::filter(id == study_id) |> + dplyr::select(parameters) |> + dplyr::pull() + + parameters <- jsonlite::fromJSON(parameters) + + if (!checkmate::test_list(parameters, null.ok = FALSE)) { + message <- checkmate::test_list(parameters, null.ok = FALSE) + res$status <- 400 + res$body <- + list( + error = glue::glue( + "Parse validation failed. 'Parameters' must be a list: {message}" + ) + ) + + return(res) + } + + ratio_arms <- + dplyr::tbl(db_connetion_pool, "arm") |> + dplyr::filter(study_id == !!study_id) |> + dplyr::select("name", "ratio") |> + dplyr::collect() + + params <- list( + arms = ratio_arms$name, + current_state = tibble::as_tibble(current_state), + ratio = setNames(ratio_arms$ratio, ratio_arms$name), + method = parameters$method, + p = parameters$p, + weights = parameters$weights |> unlist() + ) + + if (!checkmate::test_list(params, null.ok = FALSE)) { + message <- checkmate::test_list(params, null.ok = FALSE) + res$status <- 400 + res$body <- + list(error = glue::glue( + "Parse validation failed. Input parameters must be a list: {message}" + )) + return(res) + } + + return(params) + } diff --git a/inst/plumber/unbiased_api/study-repository.R b/R/db.R similarity index 71% rename from inst/plumber/unbiased_api/study-repository.R rename to R/db.R index 0375cde..8bca246 100644 --- a/inst/plumber/unbiased_api/study-repository.R +++ b/R/db.R @@ -1,6 +1,33 @@ #' Defines methods for interacting with the study in the database +#' Create a database connection pool +#' +#' This function creates a connection pool to a PostgreSQL database. It uses +#' environment variables to get the necessary connection parameters. If the +#' connection fails, it will retry up to 5 times with a delay of 2 seconds +#' between each attempt. +#' +#' @return A pool object representing the connection pool to the database. +#' @export +#' +#' @examples +#' \dontrun{ +#' pool <- create_db_connection_pool() +#' } +create_db_connection_pool <- purrr::insistently(function() { + pool::dbPool( + RPostgres::Postgres(), + dbname = Sys.getenv("POSTGRES_DB"), + host = Sys.getenv("POSTGRES_HOST"), + port = Sys.getenv("POSTGRES_PORT", 5432), + user = Sys.getenv("POSTGRES_USER"), + password = Sys.getenv("POSTGRES_PASSWORD") + ) +}, rate = purrr::rate_delay(2, max_times = 5)) + + get_similar_studies <- function(name, identifier) { + db_connection_pool <- get("db_connection_pool") similar <- dplyr::tbl(db_connection_pool, "study") |> dplyr::select(id, name, identifier) |> @@ -11,7 +38,8 @@ get_similar_studies <- function(name, identifier) { create_study <- function( name, identifier, method, parameters, arms, strata) { - connection <- pool::poolCheckout(db_connection_pool) + db_connection_pool <- get("db_connection_pool", envir = .GlobalEnv) + connection <- pool::localCheckout(db_connection_pool) r <- tryCatch( { @@ -36,7 +64,7 @@ create_study <- function( study$parameters <- jsonlite::fromJSON(study$parameters) arm_records <- arms |> - purrr::imap(\(x, name) list(name=name, ratio=x)) |> + purrr::imap(\(x, name) list(name = name, ratio = x)) |> purrr::map(tibble::as_tibble) |> purrr::list_c() arm_records$study_id <- study$id @@ -102,7 +130,7 @@ create_study <- function( list(study = study) }, error = function(cond) { - logger::log_error("Error creating study: {cond}", cond=cond) + logger::log_error("Error creating study: {cond}", cond = cond) DBI::dbRollback(connection) list(error = conditionMessage(cond)) } @@ -111,7 +139,8 @@ create_study <- function( r } -save_patient <- function(study_id, arm_id){ +save_patient <- function(study_id, arm_id) { + db_connection_pool <- get("db_connection_pool") randomized_patient <- DBI::dbGetQuery( db_connection_pool, "INSERT INTO patient (arm_id, study_id) @@ -122,4 +151,3 @@ save_patient <- function(study_id, arm_id){ return(randomized_patient) } - diff --git a/R/randomize-minimisation-pocock.R b/R/randomize-minimisation-pocock.R index c9537e0..1f01816 100644 --- a/R/randomize-minimisation-pocock.R +++ b/R/randomize-minimisation-pocock.R @@ -1,26 +1,27 @@ #' Compare rows of two dataframes #' -#' Takes dataframe B (presumably with one row / patient) and compares it to all -#' rows of A (presumably already randomized patietns) +#' Takes dataframe all_patients (presumably with one row / patient) and +#' compares it to all rows of new_patients (presumably already randomized +#' patients) #' -#' @param A data.frame with all patients -#' @param B data.frame with new patient +#' @param all_patients data.frame with all patients +#' @param new_patients data.frame with new patient #' -#' @return data.frame with columns as in A and B, filled with TRUE if there is -#' match in covariate and FALSE if not -compare_rows <- function(A, B) { +#' @return data.frame with columns as in all_patients and new_patients, +#' filled with TRUE if there is match in covariate and FALSE if not +compare_rows <- function(all_patients, new_patients) { # Find common column names - common_cols <- intersect(names(A), names(B)) + common_cols <- intersect(names(all_patients), names(new_patients)) # Compare each common column of A with B comparisons <- lapply(common_cols, function(col) { - A[[col]] == B[[col]] + all_patients[[col]] == new_patients[[col]] }) # Combine the comparisons into a new dataframe - C <- data.frame(comparisons) - names(C) <- common_cols - tibble::as_tibble(C) + comparison_df <- data.frame(comparisons) + names(comparison_df) <- common_cols + tibble::as_tibble(comparison_df) } @@ -31,15 +32,16 @@ compare_rows <- function(A, B) { #' The `randomize_dynamic` function implements the dynamic randomization #' algorithm using the minimization method proposed by Pocock (Pocock and Simon, #' 1975). It requires defining basic study parameters: the number of arms (K), -#' number of covariates (C), patient allocation ratios (\(a_{k}\)) (where k = 1,2,…., K), -#' weights for the covariates (\(w_{i}\)) (where i = 1,2,…., C), and the maximum probability (p) -#' of assigning a patient to the group with the smallest total unbalance multiplied by -#' the respective weights (\(G_{k}\)). As the total unbalance for the first patient is the same -#' regardless of the assigned arm, this patient is randomly allocated to a given -#' arm. Subsequent patients are randomized based on the calculation of the -#' unbalance depending on the selected method: "range", "var" (variance), or -#' "sd" (standard deviation). In the case of two arms, the "range" method is -#' equivalent to the "sd" method. +#' number of covariates (C), patient allocation ratios (\(a_{k}\)) +#' (where k = 1,2,…., K), weights for the covariates (\(w_{i}\)) +#' (where i = 1,2,…., C), and the maximum probability (p) of assigning a patient +#' to the group with the smallest total unbalance multiplied by +#' the respective weights (\(G_{k}\)). As the total unbalance for the first +#' patient is the same regardless of the assigned arm, this patient is randomly +#' allocated to a given arm. Subsequent patients are randomized based on the +#' calculation of the unbalance depending on the selected method: "range", +#' "var" (variance), or "sd" (standard deviation). In the case of two arms, +#' the "range" method is equivalent to the "sd" method. #' #' Initially, the algorithm creates a matrix of results comparing a newly #' randomized patient with the current balance of patients based on the defined @@ -53,12 +55,16 @@ compare_rows <- function(A, B) { #' Based on the number of defined arms, the minimum value of (\(G_{k}\)) #' (defined as the weighted sum of the level-based imbalance) selects the arm to #' which the patient will be assigned with a predefined probability (p). The -#' probability that a patient will be assigned to any other arm will then be equal (1-p)/(K-1) +#' probability that a patient will be assigned to any other arm will then be +#' equal (1-p)/(K-1) #' for each of the remaining arms. -#' @references Pocock, S. J., & Simon, R. (1975). Minimization: A new method of assigning patients to treatment and control groups in clinical trials. -#' @references Minirand Package: Man Jin, Adam Polis, Jonathan Hartzel. (https://CRAN.R-project.org/package=Minirand) -#' @note This function's implementation is a refactored adaptation of the codebase from the 'Minirand' package. +#' @references Pocock, S. J., & Simon, R. (1975). Minimization: A new method +#' of assigning patients to treatment and control groups in clinical trials. +#' @references Minirand Package: Man Jin, Adam Polis, Jonathan Hartzel. +#' (https://CRAN.R-project.org/package=Minirand) +#' @note This function's implementation is a refactored adaptation +#' of the codebase from the 'Minirand' package. #' #' @inheritParams randomize_simple #' @@ -81,33 +87,39 @@ compare_rows <- function(A, B) { #' n_at_the_moment <- 10 #' arms <- c("control", "active low", "active high") #' sex <- sample(c("F", "M"), -#' n_at_the_moment + 1, -#' replace = TRUE, -#' prob = c(0.4, 0.6) +#' n_at_the_moment + 1, +#' replace = TRUE, +#' prob = c(0.4, 0.6) #' ) #' diabetes <- #' sample(c("diabetes", "no diabetes"), -#' n_at_the_moment + 1, -#' replace = TRUE, -#' prob = c(0.2, 0.8) +#' n_at_the_moment + 1, +#' replace = TRUE, +#' prob = c(0.2, 0.8) #' ) #' arm <- #' sample(arms, -#' n_at_the_moment, -#' replace = TRUE, -#' prob = c(0.4, 0.4, 0.2) +#' n_at_the_moment, +#' replace = TRUE, +#' prob = c(0.4, 0.4, 0.2) #' ) |> #' c("") #' covar_df <- tibble::tibble(sex, diabetes, arm) #' covar_df #' #' randomize_minimisation_pocock(arms = arms, current_state = covar_df) -#' randomize_minimisation_pocock(arms = arms, current_state = covar_df, -#' ratio = c("control" = 1, -#' "active low" = 2, -#' "active high" = 2), -#' weights = c("sex" = 0.5, -#' "diabetes" = 1)) +#' randomize_minimisation_pocock( +#' arms = arms, current_state = covar_df, +#' ratio = c( +#' "control" = 1, +#' "active low" = 2, +#' "active high" = 2 +#' ), +#' weights = c( +#' "sex" = 0.5, +#' "diabetes" = 1 +#' ) +#' ) #' #' @export randomize_minimisation_pocock <- @@ -117,17 +129,28 @@ randomize_minimisation_pocock <- ratio, method = "var", p = 0.85) { - # Assertions checkmate::assert_character( arms, min.len = 2, min.chars = 1, - unique = TRUE) + unique = TRUE + ) + + # Define a custom range function + custom_range <- function(x) { + max(x, na.rm = TRUE) - min(x, na.rm = TRUE) + } + + supported_methods <- list( + "range" = custom_range, + "var" = var, + "sd" = sd + ) checkmate::assert_choice( method, - choices = c("range", "var", "sd") + choices = names(supported_methods), ) checkmate::assert_tibble( current_state, @@ -142,7 +165,8 @@ randomize_minimisation_pocock <- ) checkmate::assert_character( current_state$arm[nrow(current_state)], - max.chars = 0, .var.name = "Last value of 'arm'") + max.chars = 0, .var.name = "Last value of 'arm'" + ) n_covariates <- (ncol(current_state) - 1) @@ -160,8 +184,9 @@ randomize_minimisation_pocock <- names(ratio) <- arms } if (rlang::is_missing(weights)) { - weights <- rep(1/n_covariates, n_covariates) - names(weights) <- colnames(current_state)[colnames(current_state) != "arm"] + weights <- rep(1 / n_covariates, n_covariates) + names(weights) <- + colnames(current_state)[colnames(current_state) != "arm"] } checkmate::assert_numeric( @@ -197,11 +222,10 @@ randomize_minimisation_pocock <- lower = 0, upper = 1, null.ok = FALSE - ) + ) # Computations n_at_the_moment <- nrow(current_state) - 1 - covariate_names <- names(current_state)[names(current_state) != "arm"] if (n_at_the_moment == 0) { return(randomize_simple(arms, ratio)) @@ -218,29 +242,32 @@ randomize_minimisation_pocock <- dplyr::bind_rows(.id = "arm") |> # make sure that every arm has a metric, even if not present in data yet tidyr::complete(arm = arms) |> - dplyr::mutate(dplyr::across(dplyr::where(is.numeric), - ~ tidyr::replace_na(.x, 0))) - - # Define a custom range function - range <- function(x) { - max(x, na.rm = TRUE) - min(x, na.rm = TRUE) - } + dplyr::mutate(dplyr::across( + dplyr::where(is.numeric), + ~ tidyr::replace_na(.x, 0) + )) imbalance <- sapply(arms, function(x) { arms_similarity |> # compute scenario where each arm (x) gets new subject - dplyr::mutate(dplyr::across(dplyr::where(is.numeric), - ~ dplyr::if_else(arm == x, .x + 1, .x) * - ratio[arm])) |> + dplyr::mutate(dplyr::across( + dplyr::where(is.numeric), + ~ dplyr::if_else(arm == x, .x + 1, .x) * + ratio[arm] + )) |> # compute dispersion across each covariate - dplyr::summarise(dplyr::across(dplyr::where(is.numeric), - ~ get(method)(.x))) |> + dplyr::summarise(dplyr::across( + dplyr::where(is.numeric), + ~ supported_methods[[method]](.x) + )) |> # multiply each covariate dispersion by covariate weight - dplyr::mutate(dplyr::across(dplyr::everything(), - ~ . * weights[dplyr::cur_column()])) |> + dplyr::mutate(dplyr::across( + dplyr::everything(), + ~ . * weights[dplyr::cur_column()] + )) |> # sum all covariate outcomes dplyr::summarize(total = sum(dplyr::c_across(dplyr::everything()))) |> - dplyr::pull(total) + dplyr::pull("total") }) high_prob_arms <- names(which(imbalance == min(imbalance))) @@ -255,7 +282,8 @@ randomize_minimisation_pocock <- prob = c( rep( p / length(high_prob_arms), - length(high_prob_arms)), + length(high_prob_arms) + ), rep( (1 - p) / length(low_prob_arms), length(low_prob_arms) diff --git a/R/randomize-simple.R b/R/randomize-simple.R index 441565b..a8b558a 100644 --- a/R/randomize-simple.R +++ b/R/randomize-simple.R @@ -28,7 +28,8 @@ randomize_simple <- function(arms, ratio) { arms, any.missing = FALSE, unique = TRUE, - min.chars = 1) + min.chars = 1 + ) checkmate::assert_integerish( ratio, diff --git a/R/run-api.R b/R/run-api.R new file mode 100644 index 0000000..9030be7 --- /dev/null +++ b/R/run-api.R @@ -0,0 +1,40 @@ +#' Run API +#' +#' @description +#' Starts \pkg{unbiased} API. +#' +#' @param host `character(1)`\cr +#' Host URL. +#' @param port `integer(1)`\cr +#' Port to serve API under. +#' +#' @return Function called to serve the API in the caller thread. +#' +#' @export +run_unbiased <- function() { + host <- Sys.getenv("UNBIASED_HOST", "0.0.0.0") + port <- as.integer(Sys.getenv("UNBIASED_PORT", "3838")) + assign("db_connection_pool", + unbiased:::create_db_connection_pool(), + envir = globalenv() + ) + + on.exit({ + db_connection_pool <- get("db_connection_pool", envir = globalenv()) + pool::poolClose(db_connection_pool) + assign("db_connection_pool", NULL, envir = globalenv()) + }) + + # if "inst" directory is not present, we assume that the package is installed + # and inst directory content is copied to the root directory + # so we can use plumb_api method + if (!dir.exists("inst")) { + plumber::plumb_api("unbiased", "unbiased_api") |> + plumber::pr_run(host = host, port = port) + } else { + # otherwise we assume that we are in the root directory of the repository + # and we can use plumb method to run the API from the plumber.R file + plumber::plumb("./inst/plumber/unbiased_api/plumber.R") |> + plumber::pr_run(host = host, port = port) + } +} diff --git a/R/run_api.R b/R/run_api.R deleted file mode 100644 index 17aa312..0000000 --- a/R/run_api.R +++ /dev/null @@ -1,34 +0,0 @@ -#' Run API -#' -#' @description -#' Starts \pkg{unbiased} API. -#' -#' @param host `character(1)`\cr -#' Host URL. -#' @param port `integer(1)`\cr -#' Port to serve API under. -#' -#' @return Function called to serve the API in the caller thread. -#' -#' @export -run_unbiased <- function(host = "0.0.0.0", port = 3838, ...) { - assign("db_connection_pool", create_db_connection_pool(), envir = globalenv()) - on.exit({ - pool::poolClose(db_connection_pool) - assign("db_connection_pool", NULL, envir = globalenv()) - }) - - plumber::plumb_api("unbiased", "unbiased_api") |> - plumber::pr_run(host = host, port = port, ...) -} - -run_unbiased_local <- function(host = "0.0.0.0", port = 3838, ...) { - assign("db_connection_pool", create_db_connection_pool(), envir = globalenv()) - on.exit({ - pool::poolClose(db_connection_pool) - assign("db_connection_pool", NULL, envir = globalenv()) - }) - - plumber::plumb("./inst/plumber/unbiased_api/plumber.R") |> - plumber::pr_run(host = host, port = port, ...) -} diff --git a/R/run_db.R b/R/run_db.R deleted file mode 100644 index d664911..0000000 --- a/R/run_db.R +++ /dev/null @@ -1,12 +0,0 @@ -# db_connection_pool <- NULL - -create_db_connection_pool <- purrr::insistently(function() { - pool::dbPool( - RPostgres::Postgres(), - dbname = Sys.getenv("POSTGRES_DB"), - host = Sys.getenv("POSTGRES_HOST"), - port = Sys.getenv("POSTGRES_PORT", 5432), - user = Sys.getenv("POSTGRES_USER"), - password = Sys.getenv("POSTGRES_PASSWORD") - ) -}, rate = purrr::rate_delay(2, max_times = 5)) diff --git a/R/study-details.R b/R/study-details.R deleted file mode 100644 index 595c59e..0000000 --- a/R/study-details.R +++ /dev/null @@ -1,58 +0,0 @@ -#' Read study details -#' -#' @description -#' Queries the DB for the study parameters, including declared arms and strata. -#' -#' @param study_id `integer(1)`\cr -#' ID of the study. -#' -#' @return A tibble with study details, containing potentially complex columns, -#' like `arms`. -#' -#' @export -read_study_details <- function(study_id) { - arms <- tbl(db_connection_pool, "arm") |> - filter(study_id == !!study_id) |> - select(name, ratio) |> - collect() - - strata <- tbl(db_connection_pool, "stratum") |> - filter(study_id == !!study_id) |> - select(id, name, value_type) |> - collect() |> - mutate(values = list(read_stratum_values(id, value_type)), .by = id) |> - select(-id) - - tbl(db_connection_pool, "study") |> - filter(id == !!study_id) |> - select(id, name, identifier, method_id, parameters) |> - left_join( - tbl(db_connection_pool, "method") |> - select(id, method = name), - join_by(method_id == id) - ) |> - select(-method_id) |> - collect() |> - mutate( - parameters = list(jsonlite::fromJSON(parameters)), - arms = list(arms), - strata = list(strata) - ) -} - -read_stratum_values <- function(stratum_id, value_type) { - switch( - value_type, - "factor" = { - tbl(db_connection_pool, "factor_constraint") |> - filter(stratum_id == !!stratum_id) |> - pull(value) - }, - "numeric" = { - tbl(db_connection_pool, "numeric_constraint") |> - filter(stratum_id == !!stratum_id) |> - select(min_value, max_value) |> - collect() - } - ) -} diff --git a/R/study-list.R b/R/study-list.R deleted file mode 100644 index b21375f..0000000 --- a/R/study-list.R +++ /dev/null @@ -1,32 +0,0 @@ -#' List available studies -#' -#' @description -#' Queries the DB for the basic information about existing studies. -#' -#' @return A tibble with basic study info, including ID. -#' -#' @export -list_studies <- function() { - tbl(db_connection_pool, "study") |> - select(id, identifier, name, timestamp) |> - arrange(desc(timestamp)) |> - collect() -} - -#' Validate study existence -#' -#' @description -#' Checks the database for the existence of given ID. -#' -#' @param study_id `integer(1)`\cr -#' ID of the study. -#' -#' @return `TRUE` or `FALSE`, depending whether given ID exists in the DB. -#' -#' @export -study_exists <- function(study_id) { - row_id <- tbl(db_connection_pool, "study") |> - filter(id == !!study_id) |> - pull(id) - test_int(row_id) -} diff --git a/inst/plumber/unbiased_api/validation-utils.R b/R/validation-utils.R similarity index 100% rename from inst/plumber/unbiased_api/validation-utils.R rename to R/validation-utils.R diff --git a/README.md b/README.md index 1dc73f6..5eadab3 100644 --- a/README.md +++ b/README.md @@ -1,2 +1,57 @@ # unbiased API for clinical trial randomization + +## Configuration + +The Unbiased API server can be configured using environment variables. The following environment variables need to be set for the server to start: + +- `POSTGRES_DB`: The name of the PostgreSQL database to connect to. +- `POSTGRES_HOST`: The host of the PostgreSQL database. This could be a hostname, such as `localhost` or `database.example.com`, or an IP address. +- `POSTGRES_PORT`: The port on which the PostgreSQL database is listening. Defaults to `5432` if not provided. +- `POSTGRES_USER`: The username for authentication with the PostgreSQL database. +- `POSTGRES_PASSWORD`: The password for authentication with the PostgreSQL database. +- `UNBIASED_HOST`: The host on which the API will run. Defaults to `0.0.0.0` if not provided. +- `UNBIASED_PORT`: The port on which the API will listen. Defaults to `3838` if not provided. + +## Running Tests + +Unbiased provides an extensive collection of tests to ensure correct functionality. + +### Executing Tests from an R Interactive Session + +To execute tests using an interactive R session, run the following commands: + +```R +devtools::load_all() +testthat::test_package("unbiased") +``` + +Make sure that `devtools` package is installed in your environment. + +Ensure that the necessary database connection environment variables are set before running these tests. You can set environment variables using methods such as `Sys.setenv`. + +Running these tests will start the Unbiased API on a random port. + +### Executing Tests from the Command Line + +Use the helper script `run_tests.sh` to execute tests from the command line. Remember to set the database connection environment variables before running the tests. + +### Running Tests with Docker Compose + +Docker Compose can be used to build the Unbiased Docker image and execute all tests. This can be done using the provided `docker-compose.test.yml` file. This method ensures a consistent testing environment and simplifies the setup process. + +```bash +docker compose -f docker-compose.test.yml build +docker compose -f docker-compose.test.yml run tests +``` + +### Code Coverage + +Unbiased supports code coverage analysis through the `covr` package. This allows you to measure the effectiveness of your tests by showing which parts of your R code in the `R` directory are actually being tested. + +To calculate code coverage, you will need to install the `covr` package. Once installed, you can use the following methods: + +- `covr::report()`: This method runs all tests and generates a detailed coverage report in HTML format. +- `covr::package_coverage()`: This method provides a simpler, text-based code coverage report. + +Alternatively, you can use the provided `run_tests_with_coverage.sh` script to run Unbiased tests with code coverage. \ No newline at end of file diff --git a/autoreload_polling.sh b/autoreload_polling.sh new file mode 100644 index 0000000..a0b9b3d --- /dev/null +++ b/autoreload_polling.sh @@ -0,0 +1,20 @@ +#!/bin/bash + +set -e + +COMMAND=$1 + +echo "Running $COMMAND" + +watchmedo auto-restart \ + --patterns="*.R;*.txt" \ + --ignore-patterns="renv" \ + --recursive \ + --directory="./R" \ + --directory="./inst" \ + --directory="./tests" \ + --debounce-interval 1 \ + --debug-force-polling \ + -v \ + --no-restart-on-command-exit \ + "$@" \ No newline at end of file diff --git a/clear_db.sh b/clear_db.sh deleted file mode 100755 index 6764408..0000000 --- a/clear_db.sh +++ /dev/null @@ -1,13 +0,0 @@ -#!/bin/bash - -set -e - -export PGPASSWORD="$POSTGRES_PASSWORD" - -# Clear the database -psql -v ON_ERROR_STOP=1 \ - --host "$POSTGRES_HOST" \ - --port "${POSTGRES_PORT:-5432}" \ - --username "$POSTGRES_USER" \ - --dbname "$POSTGRES_DB" \ - -c "DROP SCHEMA public CASCADE; CREATE SCHEMA public;" diff --git a/docker-compose.test.yaml b/docker-compose.test.yaml deleted file mode 100644 index 1dc9bb3..0000000 --- a/docker-compose.test.yaml +++ /dev/null @@ -1,53 +0,0 @@ -version: "3.9" -services: - postgres: - image: temporal_postgres - build: - context: . - dockerfile: Dockerfile.postgres - container_name: unbiased_postgres - environment: - - POSTGRES_PASSWORD=postgres - networks: - - test_net - volumes: - - type: bind - source: ./inst/postgres/ - target: /docker-entrypoint-initdb.d/ - api: - image: unbiased - build: - context: . - dockerfile: Dockerfile - container_name: unbiased_api - depends_on: - - postgres - environment: - - POSTGRES_DB=postgres - - POSTGRES_HOST=postgres - - POSTGRES_PORT=5432 - - POSTGRES_USER=postgres - - POSTGRES_PASSWORD=postgres - networks: - - test_net - tests: - # image: unbiased - build: - context: . - dockerfile: Dockerfile - container_name: unbiased_tests - depends_on: - - api - environment: - - CI=true - - POSTGRES_DB=postgres - - POSTGRES_HOST=postgres - - POSTGRES_PORT=5432 - - POSTGRES_USER=postgres - - POSTGRES_PASSWORD=postgres - networks: - - test_net - command: R -e "testthat::test_package('unbiased')" - -networks: - test_net: diff --git a/docker-compose.test.yml b/docker-compose.test.yml new file mode 100644 index 0000000..a44b094 --- /dev/null +++ b/docker-compose.test.yml @@ -0,0 +1,19 @@ +version: "3.9" +services: + postgres: + image: ghcr.io/ttscience/postgres-temporal-tables/postgres-temporal-tables:latest + environment: + - POSTGRES_PASSWORD=postgres + tests: + build: + context: . + dockerfile: Dockerfile + depends_on: + - postgres + environment: + - POSTGRES_DB=postgres + - POSTGRES_HOST=postgres + - POSTGRES_PORT=5432 + - POSTGRES_USER=postgres + - POSTGRES_PASSWORD=postgres + command: R -e "testthat::test_package('unbiased')" diff --git a/entrypoint.sh b/entrypoint.sh deleted file mode 100755 index d3370c3..0000000 --- a/entrypoint.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/bin/bash - -set -e - -echo "Running unbiased" - -# R -e "devtools::install(quick = TRUE, upgrade = FALSE); unbiased::run_unbiased()" -R -e "devtools::load_all(); unbiased:::run_unbiased_local()" diff --git a/inst/db/migrations/000001_initialize_temporal_tables_extension.down.sql b/inst/db/migrations/000001_initialize_temporal_tables_extension.down.sql new file mode 100644 index 0000000..a7ff547 --- /dev/null +++ b/inst/db/migrations/000001_initialize_temporal_tables_extension.down.sql @@ -0,0 +1 @@ +DROP EXTENSION temporal_tables; diff --git a/inst/db/migrations/000001_initialize_temporal_tables_extension.up.sql b/inst/db/migrations/000001_initialize_temporal_tables_extension.up.sql new file mode 100644 index 0000000..0f70cfe --- /dev/null +++ b/inst/db/migrations/000001_initialize_temporal_tables_extension.up.sql @@ -0,0 +1 @@ +CREATE EXTENSION temporal_tables; diff --git a/inst/db/migrations/20240129082653_create_tables.down.sql b/inst/db/migrations/20240129082653_create_tables.down.sql new file mode 100644 index 0000000..18deffd --- /dev/null +++ b/inst/db/migrations/20240129082653_create_tables.down.sql @@ -0,0 +1,8 @@ +DROP TABLE patient_stratum; +DROP TABLE patient; +DROP TABLE numeric_constraint; +DROP TABLE factor_constraint; +DROP TABLE stratum_level; +DROP TABLE stratum; +DROP TABLE arm; +DROP TABLE study; \ No newline at end of file diff --git a/inst/db/migrations/20240129082653_create_tables.up.sql b/inst/db/migrations/20240129082653_create_tables.up.sql new file mode 100644 index 0000000..3ef3774 --- /dev/null +++ b/inst/db/migrations/20240129082653_create_tables.up.sql @@ -0,0 +1,174 @@ +CREATE TABLE study ( + id SERIAL PRIMARY KEY, + identifier VARCHAR(12) NOT NULL, + name VARCHAR(255) NOT NULL, + method VARCHAR(255) NOT NULL, + parameters JSONB, + timestamp TIMESTAMPTZ NOT NULL DEFAULT now(), + sys_period TSTZRANGE NOT NULL +); + +COMMENT ON TABLE study IS 'Stores information about various studies conducted.'; +COMMENT ON COLUMN study.id IS 'An auto-incrementing primary key uniquely identifying each study.'; +COMMENT ON COLUMN study.identifier IS 'A unique, short textual identifier for the study (max 12 characters).'; +COMMENT ON COLUMN study.name IS 'Provides the full name or title of the study.'; +COMMENT ON COLUMN study.method IS 'A randomization method name.'; +COMMENT ON COLUMN study.parameters IS 'JSONB column to store parameters related to the study.'; +COMMENT ON COLUMN study.timestamp IS 'Timestamp of when the record was created, defaults to current time.'; +COMMENT ON COLUMN study.sys_period IS 'TSTZRANGE type used for temporal versioning to track the validity period of each record.'; + +CREATE TABLE arm ( + id SERIAL PRIMARY KEY, + study_id INT NOT NULL, + name VARCHAR(255) NOT NULL, + ratio INT NOT NULL DEFAULT 1, + sys_period TSTZRANGE NOT NULL, + CONSTRAINT arm_study + FOREIGN KEY (study_id) + REFERENCES study (id) ON DELETE CASCADE, + CONSTRAINT uc_arm_study + UNIQUE (id, study_id), + CONSTRAINT ratio_positive + CHECK (ratio > 0) +); + +COMMENT ON TABLE arm IS 'Represents the treatment arms within each study.'; +COMMENT ON COLUMN arm.id IS 'An auto-incrementing primary key that uniquely identifies each arm.'; +COMMENT ON COLUMN arm.study_id IS 'A foreign key that links each arm to its corresponding study.'; +COMMENT ON COLUMN arm.name IS 'Provides a descriptive name for the treatment arm.'; +COMMENT ON COLUMN arm.ratio IS 'Specifies the proportion of patients allocated to this arm. It defaults to 1 and must always be positive.'; +COMMENT ON COLUMN arm.sys_period IS 'TSTZRANGE type used for temporal versioning to track the validity period of each record.'; + +CREATE TABLE stratum ( + id SERIAL PRIMARY KEY, + study_id INT NOT NULL, + name VARCHAR(255) NOT NULL, + value_type VARCHAR(12), + sys_period TSTZRANGE NOT NULL, + CONSTRAINT fk_study + FOREIGN KEY (study_id) + REFERENCES study (id) ON DELETE CASCADE, + CONSTRAINT chk_value_type + CHECK (value_type IN ('factor', 'numeric')) +); + +COMMENT ON TABLE stratum IS 'Defines the strata for patient categorization within each study.'; + +COMMENT ON COLUMN stratum.id IS 'An auto-incrementing primary key that uniquely identifies each stratum.'; +COMMENT ON COLUMN stratum.study_id IS 'A foreign key that links the stratum to a specific study.'; +COMMENT ON COLUMN stratum.name IS 'Provides a descriptive name for the stratum, such as a particular demographic or clinical characteristic.'; +COMMENT ON COLUMN stratum.value_type IS 'Indicates the type of value the stratum represents, limited to two types: ''factor'' or ''numeric''. ''factor'' represents categorical data, while ''numeric'' represents numerical data. This distinction is crucial as it informs the data validation logic applied in the system.'; +COMMENT ON COLUMN stratum.sys_period IS 'TSTZRANGE type used for temporal versioning to track the validity period of each record.'; + +CREATE TABLE stratum_level ( + stratum_id INT NOT NULL, + level VARCHAR(255) NOT NULL, + CONSTRAINT fk_stratum_level + FOREIGN KEY (stratum_id) + REFERENCES stratum (id) ON DELETE CASCADE, + CONSTRAINT uc_stratum_level + UNIQUE (stratum_id, level) +); +COMMENT ON TABLE stratum_level IS 'Keeps allowed stratum factor levels.'; + +COMMENT ON COLUMN stratum_level.stratum_id IS 'A foreign key that links the stratum level to a specific stratum.'; +COMMENT ON COLUMN stratum_level.level IS 'Level label, has to be unique within stratum.'; + +CREATE TABLE factor_constraint ( + stratum_id INT NOT NULL, + value VARCHAR(255) NOT NULL, + sys_period TSTZRANGE NOT NULL, + CONSTRAINT factor_stratum + FOREIGN KEY (stratum_id) + REFERENCES stratum (id) ON DELETE CASCADE, + CONSTRAINT uc_stratum_value + UNIQUE (stratum_id, value) +); + +COMMENT ON TABLE factor_constraint IS 'Defines constraints for strata of the ''factor'' type in studies. This table stores allowable values for each factor stratum, ensuring data consistency and integrity.'; + +COMMENT ON COLUMN factor_constraint.stratum_id IS 'A foreign key that links the constraint to a specific stratum in the ''stratum'' table.'; +COMMENT ON COLUMN factor_constraint.value IS 'Represents the specific allowable value for the factor stratum. This could be a categorical label like ''male'' or ''female'' for a gender stratum, for example.'; +COMMENT ON COLUMN factor_constraint.sys_period IS 'TSTZRANGE type used for temporal versioning to track the validity period of each record.'; + +CREATE TABLE numeric_constraint ( + stratum_id INT NOT NULL, + min_value FLOAT, + max_value FLOAT, + sys_period TSTZRANGE NOT NULL, + CONSTRAINT numeric_stratum + FOREIGN KEY (stratum_id) + REFERENCES stratum (id) ON DELETE CASCADE, + CONSTRAINT uc_stratum + UNIQUE (stratum_id), + CONSTRAINT chk_min_max + -- NULL is ok in checks, no need to test for it + CHECK (min_value <= max_value) +); + +COMMENT ON TABLE numeric_constraint IS 'Specifies constraints for strata of the ''numeric'' type in studies. This table defines the permissible range (minimum and maximum values) for each numeric stratum.'; + +COMMENT ON COLUMN numeric_constraint.stratum_id IS 'A foreign key that links the constraint to a specific numeric stratum in the ''stratum'' table.'; +COMMENT ON COLUMN numeric_constraint.min_value IS 'Defines the minimum allowable value for the stratum''s numeric values. Can be NULL, indicating that there is no lower bound.'; +COMMENT ON COLUMN numeric_constraint.max_value IS 'Defines the maximum allowable value for the stratum''s numeric values. Can be NULL, indicating that there is no upper bound.'; +COMMENT ON COLUMN numeric_constraint.sys_period IS 'TSTZRANGE type used for temporal versioning to track the validity period of each record.'; + +CREATE TABLE patient ( + id SERIAL PRIMARY KEY, + study_id INT NOT NULL, + arm_id INT, + used BOOLEAN NOT NULL DEFAULT false, + -- timestamp TIMESTAMPTZ NOT NULL DEFAULT now(), + sys_period TSTZRANGE NOT NULL, + CONSTRAINT patient_arm_study + FOREIGN KEY (arm_id, study_id) + REFERENCES arm (id, study_id) ON DELETE CASCADE, + CONSTRAINT used_with_arm + CHECK (NOT used OR arm_id IS NOT NULL) +); + + +COMMENT ON TABLE patient IS 'Represents individual patients participating in the studies.'; +COMMENT ON COLUMN patient.id IS 'An auto-incrementing primary key that uniquely identifies each patient.'; +COMMENT ON COLUMN patient.study_id IS 'A foreign key linking the patient to a specific study.'; +COMMENT ON COLUMN patient.arm_id IS 'An optional foreign key that links the patient to a specific treatment arm within the study.'; +COMMENT ON COLUMN patient.used IS 'A boolean flag indicating the state of the patient in the randomization process.'; +COMMENT ON COLUMN patient.sys_period IS 'Type TSTZRANGE, used for temporal versioning to track the validity period of each record.'; +COMMENT ON CONSTRAINT patient_arm_study ON patient IS 'Ensures referential integrity between patients, studies, and arms. It also cascades deletions to maintain consistency when a study or arm is deleted.'; +COMMENT ON CONSTRAINT used_with_arm ON patient IS 'Ensures logical consistency by allowing ''used'' to be true only if the patient is assigned to an arm (i.e., ''arm_id'' is not NULL). This prevents scenarios where a patient is marked as used but not assigned to any treatment arm.'; + + +CREATE TABLE patient_stratum ( + patient_id INT NOT NULL, + stratum_id INT NOT NULL, + fct_value VARCHAR(255), + num_value FLOAT, + sys_period TSTZRANGE NOT NULL, + CONSTRAINT fk_patient + FOREIGN KEY (patient_id) + REFERENCES patient (id) ON DELETE CASCADE, + CONSTRAINT fk_stratum_2 + FOREIGN KEY (stratum_id) + REFERENCES stratum (id) ON DELETE CASCADE, + CONSTRAINT chk_value_exists + -- Either factor or numeric value must be given + CHECK (fct_value IS NOT NULL OR num_value IS NOT NULL), + CONSTRAINT chk_one_value_only + -- Can't give both factor and numeric value + CHECK (fct_value IS NULL OR num_value IS NULL), + CONSTRAINT uc_patient_stratum + UNIQUE (patient_id, stratum_id) +); + + +COMMENT ON TABLE patient_stratum IS 'Associates patients with specific strata and records the corresponding stratum values.'; +COMMENT ON COLUMN patient_stratum.patient_id IS 'A foreign key that links to the ''patient'' table, identifying the patient.'; +COMMENT ON COLUMN patient_stratum.stratum_id IS 'A foreign key that links to the ''stratum'' table, identifying the stratum to which the patient belongs.'; +COMMENT ON COLUMN patient_stratum.fct_value IS 'Stores the categorical (factor) value for the patient in the corresponding stratum, if applicable.'; +COMMENT ON COLUMN patient_stratum.num_value IS 'Stores the numerical value for the patient in the corresponding stratum, if applicable.'; +COMMENT ON COLUMN patient_stratum.sys_period IS 'Type TSTZRANGE, used for temporal versioning to track the validity period of each record.'; +COMMENT ON CONSTRAINT fk_patient ON patient_stratum IS 'Links each patient-stratum pairing to the respective tables.'; +COMMENT ON CONSTRAINT fk_stratum_2 ON patient_stratum IS 'Links each patient-stratum pairing to the respective tables.'; +COMMENT ON CONSTRAINT chk_value_exists ON patient_stratum IS 'Ensures that either a factor or numeric value is provided for each record, aligning with the nature of the stratum.'; +COMMENT ON CONSTRAINT chk_one_value_only ON patient_stratum IS 'Ensures that each record has either a factor or a numeric value, but not both, maintaining the integrity of the data by ensuring it matches the stratum type (factor or numeric).'; +COMMENT ON CONSTRAINT uc_patient_stratum ON patient_stratum IS 'Ensures that each patient-stratum pairing is unique.'; diff --git a/inst/db/migrations/20240129082842_main_data_validation.down.sql b/inst/db/migrations/20240129082842_main_data_validation.down.sql new file mode 100644 index 0000000..4ffef4b --- /dev/null +++ b/inst/db/migrations/20240129082842_main_data_validation.down.sql @@ -0,0 +1,14 @@ +DROP TRIGGER patient_num_constraint ON patient_stratum; +DROP FUNCTION check_num_patient(); + +DROP TRIGGER patient_fct_constraint ON patient_stratum; +DROP FUNCTION check_fct_patient(); + +DROP TRIGGER patient_stratum_study_constraint ON patient_stratum; +DROP FUNCTION check_patient_stratum_study(); + +DROP TRIGGER stratum_num_constraint ON numeric_constraint; +DROP FUNCTION check_num_stratum(); + +DROP TRIGGER stratum_fct_constraint ON factor_constraint; +DROP FUNCTION check_fct_stratum(); \ No newline at end of file diff --git a/inst/db/migrations/20240129082842_main_data_validation.up.sql b/inst/db/migrations/20240129082842_main_data_validation.up.sql new file mode 100644 index 0000000..7d89f55 --- /dev/null +++ b/inst/db/migrations/20240129082842_main_data_validation.up.sql @@ -0,0 +1,134 @@ +-- Stratum constraint checks + +CREATE FUNCTION check_fct_stratum() +RETURNS trigger AS $$ +BEGIN + IF NOT EXISTS ( + SELECT 1 FROM stratum + -- Checks that column value is correct + WHERE id = NEW.stratum_id AND value_type = 'factor' + ) THEN + RAISE EXCEPTION 'Can''t set factor constraint for non-factor stratum.'; + END IF; + RETURN NEW; +END; +$$ LANGUAGE plpgsql; + +CREATE TRIGGER stratum_fct_constraint +BEFORE INSERT ON factor_constraint +FOR EACH ROW +EXECUTE PROCEDURE check_fct_stratum(); + + +CREATE FUNCTION check_num_stratum() +RETURNS trigger AS $$ +BEGIN + IF NOT EXISTS ( + SELECT 1 FROM stratum + -- Checks that column value is correct + WHERE id = NEW.stratum_id AND value_type = 'numeric' + ) THEN + RAISE EXCEPTION 'Can''t set numeric constraint for non-numeric stratum.'; + END IF; + RETURN NEW; +END; +$$ LANGUAGE plpgsql; + +CREATE TRIGGER stratum_num_constraint +BEFORE INSERT ON numeric_constraint +FOR EACH ROW +EXECUTE PROCEDURE check_num_stratum(); + +-- Patient stratum value checks + +-- Ensure that patients and strata are assigned to the same study. +CREATE FUNCTION check_patient_stratum_study() +RETURNS trigger AS $$ +BEGIN + DECLARE + patient_study INT := ( + SELECT study_id FROM patient + WHERE id = NEW.patient_id + ); + stratum_study INT := ( + SELECT study_id FROM stratum + WHERE id = NEW.stratum_id + ); + BEGIN + IF (patient_study <> stratum_study) THEN + RAISE EXCEPTION 'Stratum and patient must be assigned to the same study.'; + END IF; + END; + RETURN NEW; +END; +$$ LANGUAGE plpgsql; + +CREATE TRIGGER patient_stratum_study_constraint +BEFORE INSERT ON patient_stratum +FOR EACH ROW +EXECUTE PROCEDURE check_patient_stratum_study(); + +-- Validate and enforce factor stratum values. +CREATE FUNCTION check_fct_patient() +RETURNS trigger AS $$ +BEGIN + IF EXISTS ( + SELECT 1 FROM stratum + WHERE id = NEW.stratum_id AND value_type = 'factor' + ) THEN + IF (NEW.fct_value IS NULL) THEN + RAISE EXCEPTION 'Factor stratum requires a factor value.'; + END IF; + IF NOT EXISTS ( + SELECT 1 FROM factor_constraint + WHERE stratum_id = NEW.stratum_id AND value = NEW.fct_value + ) THEN + RAISE EXCEPTION 'Factor value not specified as allowed.'; + END IF; + END IF; + RETURN NEW; +END; +$$ LANGUAGE plpgsql; + +CREATE TRIGGER patient_fct_constraint +BEFORE INSERT ON patient_stratum +FOR EACH ROW +EXECUTE PROCEDURE check_fct_patient(); + +-- Validate and enforce numeric stratum values within specified constraints. +CREATE FUNCTION check_num_patient() +RETURNS trigger AS $$ +BEGIN + IF EXISTS ( + SELECT 1 FROM stratum + WHERE id = NEW.stratum_id AND value_type = 'numeric' + ) THEN + IF (NEW.num_value IS NULL) THEN + RAISE EXCEPTION 'Numeric stratum requires a numeric value.'; + END IF; + DECLARE + min_value FLOAT := ( + SELECT min_value FROM numeric_constraint + WHERE stratum_id = NEW.stratum_id + ); + max_value FLOAT := ( + SELECT max_value FROM numeric_constraint + WHERE stratum_id = NEW.stratum_id + ); + BEGIN + IF (min_value IS NOT NULL AND NEW.num_value < min_value) THEN + RAISE EXCEPTION 'New value is lower than minimum allowed value.'; + END IF; + IF (max_value IS NOT NULL AND NEW.num_value > max_value) THEN + RAISE EXCEPTION 'New value is greater than maximum allowed value.'; + END IF; + END; + END IF; + RETURN NEW; +END; +$$ LANGUAGE plpgsql; + +CREATE TRIGGER patient_num_constraint +BEFORE INSERT ON patient_stratum +FOR EACH ROW +EXECUTE PROCEDURE check_num_patient(); diff --git a/inst/db/migrations/20240129084925_versioning.down.sql b/inst/db/migrations/20240129084925_versioning.down.sql new file mode 100644 index 0000000..73a9d56 --- /dev/null +++ b/inst/db/migrations/20240129084925_versioning.down.sql @@ -0,0 +1,20 @@ +DROP TRIGGER patient_stratum_versioning ON patient_stratum; +DROP TABLE patient_stratum_history; + +DROP TRIGGER patient_versioning ON patient; +DROP TABLE patient_history; + +DROP TRIGGER num_constraint_versioning ON numeric_constraint; +DROP TABLE numeric_constraint_history; + +DROP TRIGGER fct_constraint_versioning ON factor_constraint; +DROP TABLE factor_constraint_history; + +DROP TRIGGER stratum_versioning ON stratum; +DROP TABLE stratum_history; + +DROP TRIGGER arm_versioning ON arm; +DROP TABLE arm_history; + +DROP TRIGGER study_versioning ON study; +DROP TABLE study_history; \ No newline at end of file diff --git a/inst/postgres/03-versioning.sql b/inst/db/migrations/20240129084925_versioning.up.sql similarity index 100% rename from inst/postgres/03-versioning.sql rename to inst/db/migrations/20240129084925_versioning.up.sql diff --git a/inst/plumber/unbiased_api/minimisation_pocock.R b/inst/plumber/unbiased_api/minimisation_pocock.R deleted file mode 100644 index 481de82..0000000 --- a/inst/plumber/unbiased_api/minimisation_pocock.R +++ /dev/null @@ -1,282 +0,0 @@ -#* Initialize a study with Pocock's minimisation randomization -#* -#* Set up a new study for randomization defining it's parameters -#* -#* -#* @param identifier:object Study code, at most 12 characters. -#* @param name:object Full study name. -#* @param method:object Function used to compute within-arm variability, must be one of: sd, var, range -#* @param p:object Proportion of randomness (0, 1) in the randomization vs determinism (e.g. 0.85 equals 85% deterministic) -#* @param arms:object Arm names (character) with their ratios (integer). -#* @param covariates:object Covariate names (character), allowed levels (character) and covariate weights (double). -#* -#* @tag initialize -#* -#* @post /minimisation_pocock -#* @serializer unboxedJSON -#* -function(identifier, name, method, arms, covariates, p, req, res) { - source("study-repository.R") - source("validation-utils.R") - validation_errors <- vector() - - err <- checkmate::check_character(name, min.chars = 1, max.chars = 255) - if (err != TRUE) { - validation_errors <- append_error( - validation_errors, "name", err - ) - } - - err <- checkmate::check_character(identifier, min.chars = 1, max.chars = 12) - if (err != TRUE) { - validation_errors <- append_error( - validation_errors, - "identifier", - err - ) - } - - err <- checkmate::check_choice(method, choices = c("range", "var", "sd")) - if (err != TRUE) { - validation_errors <- append_error( - validation_errors, - "method", - err - ) - } - - err <- - checkmate::check_list( - arms, - types = "integerish", - any.missing = FALSE, - min.len = 2, - names = "unique" - ) - if (err != TRUE) { - validation_errors <- append_error( - validation_errors, - "arms", - err - ) - } - - err <- - checkmate::check_list( - covariates, - types = c("numeric", "list", "character"), - any.missing = FALSE, - min.len = 2, - names = "unique" - ) - if (err != TRUE) { - validation_errors <- - append_error(validation_errors, "covariates", err) - } - - response <- list() - for (c_name in names(covariates)) { - c_content <- covariates[[c_name]] - - err <- checkmate::check_list( - c_content, - any.missing = FALSE, - len = 2, - ) - if (err != TRUE) { - validation_errors <- - append_error( - validation_errors, - glue::glue("covariates[{c_name}]"), - err - ) - } - err <- checkmate::check_names( - names(c_content), - permutation.of = c("weight", "levels"), - ) - if (err != TRUE) { - validation_errors <- - 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 - ) - if (err != TRUE) { - validation_errors <- - 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 - ) - if (err != TRUE) { - validation_errors <- - 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 <- - append_error( - validation_errors, - "p", - err - ) - } - - if (length(validation_errors) > 0) { - res$status <- 400 - return(list( - error = "Input validation failed", - validation_errors = validation_errors - )) - } - - similar_studies <- get_similar_studies(name, identifier) - - strata <- purrr::imap(covariates, function(covariate, name) { - list( - name = name, - levels = covariate$levels, - value_type = "factor" - ) - }) - weights <- lapply(covariates, function(covariate) covariate$weight) - - # Write study to DB ------------------------------------------------------- - r <- create_study( - name = name, - identifier = identifier, - method = "minimisation_pocock", - parameters = list( - method = method, - p = p, - weights = weights - ), - arms = arms, - strata = strata - ) - - # Response ---------------------------------------------------------------- - - if (!is.null(r$error)) { - res$status <- 503 - return(list( - error = "There was a problem creating the study", - details = r$error - )) - } - - response <- list( - study = r$study - ) - if (nrow(similar_studies) >= 1) { - response <- c(response, list(similar_studies = similar_studies)) - } - - return(response) -} - -#* Randomize one patient -#* -#* -#* @param study_id:int Study identifier -#* @param current_state:object -#* -#* @tag randomize -#* @post //patient -#* @serializer unboxedJSON -#* - -function(study_id, current_state, req, res) { - collection <- checkmate::makeAssertCollection() - - # 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 = "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 - source("parse_pocock.R") - 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, - # simple = do.call(unbiased:::randomize_simple, params), - 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 & name == arm_name) |> - dplyr::select(arm_id = id, name, ratio) |> - dplyr::collect() - - save_patient(study_id, arm$arm_id) |> - dplyr::mutate(arm_name = arm$name) |> - dplyr::rename(patient_id = id) |> - as.list() -} - diff --git a/inst/plumber/unbiased_api/parse_pocock.R b/inst/plumber/unbiased_api/parse_pocock.R deleted file mode 100644 index 9d8334d..0000000 --- a/inst/plumber/unbiased_api/parse_pocock.R +++ /dev/null @@ -1,62 +0,0 @@ -#' Parse parameters for Pocock randomization method -#' -#' Function to parse and process parameters for the Pocock randomization method. -#' -#' @return params List of parameters - - -parse_pocock_parameters <- function(db_connetion_pool, study_id, current_state){ - parameters <- - dplyr::tbl(db_connetion_pool, "study") |> - dplyr::filter(id == study_id) |> - dplyr::select(parameters) |> - dplyr::pull() - - parameters <- jsonlite::fromJSON(parameters) - - if (!checkmate::test_list(parameters, null.ok = FALSE)){ - message <- checkmate::test_list(parameters, null.ok = FALSE) - res$status <- 400 - res$body <- - c( - response, - list( - error = glue::glue("Parse validation failed. 'Parameters' must be a list: {message}") - ) - ) - return(res) - } - - # do testowania - # parameters <- jsonlite::fromJSON('{"method": "var", "p": 0.85, "weights": {"gender": 1, "age_group" : 2, "height" : 1}}') - - ratio_arms <- - dplyr::tbl(db_connetion_pool, "arm") |> - dplyr::filter(study_id == !!study_id) |> - dplyr::select(name, ratio) |> - dplyr::collect() - - params <- list( - arms = ratio_arms$name, - current_state = tibble::as_tibble(current_state), - ratio = setNames(ratio_arms$ratio, ratio_arms$name), - method = parameters$method, - p = parameters$p, - weights = parameters$weights |> unlist() - ) - - if (!checkmate::test_list(params, null.ok = FALSE)){ - message <- checkmate::test_list(params, null.ok = FALSE) - res$status <- 400 - res$body <- - c( - response, - list( - error = glue::glue("Parse validation failed. Input parameters must be a list: {message}") - ) - ) - return(res) - } - - return(params) -} diff --git a/inst/plumber/unbiased_api/plumber.R b/inst/plumber/unbiased_api/plumber.R index 542f51e..3f2b07d 100644 --- a/inst/plumber/unbiased_api/plumber.R +++ b/inst/plumber/unbiased_api/plumber.R @@ -1,20 +1,30 @@ #* @apiTitle Unbiased -#* @apiDescription This API provides a diverse range of randomization algorithms specifically designed for use in clinical trials. It supports dynamic strategies such as the minimization method, as well as simpler approaches including standard and block randomization. The main goal of this API is to ensure seamless integration with electronic Case Report Form (eCRF) systems, facilitating efficient patient allocation management in clinical trials. -#* @apiContact list(name = "GitHub", url = "https://ttscience.github.io/unbiased/") -#* @apiLicense list(name = "MIT", url = "https://github.com/ttscience/unbiased/LICENSE.md") +#* @apiDescription This API provides a diverse range of randomization +#* algorithms specifically designed for use in clinical trials. It supports +#* dynamic strategies such as the minimization method, as well as simpler +#* approaches including standard and block randomization. The main goal of +#* this API is to ensure seamless integration with electronic Case Report +#* Form (eCRF) systems, facilitating efficient patient allocation management +#* in clinical trials. +#* @apiContact list(name = "GitHub", +#* url = "https://ttscience.github.io/unbiased/") +#* @apiLicense list(name = "MIT", +#* url = "https://github.com/ttscience/unbiased/LICENSE.md") #* @apiVersion 0.0.0.9003 -#* @apiTag initialize Endpoints that initialize study with chosen randomization method and parameters. -#* @apiTag randomize Endpoints that randomize individual patients after the study was created. +#* @apiTag initialize Endpoints that initialize study with chosen +#* randomization method and parameters. +#* @apiTag randomize Endpoints that randomize individual patients after the +#* study was created. #* @apiTag other Other endpoints (helpers etc.). #* #* @plumber function(api) { meta <- plumber::pr("meta.R") - minimisation_pocock <- plumber::pr("minimisation_pocock.R") + study <- plumber::pr("study.R") api |> plumber::pr_mount("/meta", meta) |> - plumber::pr_mount("/study", minimisation_pocock) |> + plumber::pr_mount("/study", study) |> plumber::pr_set_api_spec(function(spec) { spec$ paths$ @@ -67,9 +77,11 @@ function(api) { paths$`/study/{study_id}/patient`$ post$requestBody$content$`application/json`$ schema$properties$current_state$example <- - tibble::tibble("sex" = c("female", "male"), - "weight" = c("61-80 kg", "81 kg or more"), - "arm" = c("placebo", "")) + tibble::tibble( + "sex" = c("female", "male"), + "weight" = c("61-80 kg", "81 kg or more"), + "arm" = c("placebo", "") + ) spec }) } @@ -93,4 +105,3 @@ function(req) { plumber::forward() } - diff --git a/inst/plumber/unbiased_api/study.R b/inst/plumber/unbiased_api/study.R new file mode 100644 index 0000000..f613b4e --- /dev/null +++ b/inst/plumber/unbiased_api/study.R @@ -0,0 +1,44 @@ +#* Initialize a study with Pocock's minimisation randomization +#* +#* Set up a new study for randomization defining its parameters +#* +#* +#* @param identifier:object Study code, at most 12 characters. +#* @param name:object Full study name. +#* @param method:object Function used to compute within-arm variability, +#* must be one of: sd, var, range +#* @param p:object Proportion of randomness (0, 1) in the randomization vs +#* determinism (e.g. 0.85 equals 85% deterministic) +#* @param arms:object Arm names (character) with their ratios (integer). +#* @param covariates:object Covariate names (character), allowed levels +#* (character) and covariate weights (double). +#* +#* @tag initialize +#* +#* @post /minimisation_pocock +#* @serializer unboxedJSON +#* +function(identifier, name, method, arms, covariates, p, req, res) { + return( + unbiased:::api__minimization_pocock( + identifier, name, method, arms, covariates, p, req, res + ) + ) +} + +#* Randomize one patient +#* +#* +#* @param study_id:int Study identifier +#* @param current_state:object +#* +#* @tag randomize +#* @post //patient +#* @serializer unboxedJSON +#* + +function(study_id, current_state, req, res) { + return( + unbiased:::api__randomize_patient(study_id, current_state, req, res) + ) +} diff --git a/inst/postgres/00-metadata.sql b/inst/postgres/00-metadata.sql deleted file mode 100644 index 2d5a30e..0000000 --- a/inst/postgres/00-metadata.sql +++ /dev/null @@ -1,11 +0,0 @@ --- Create a table for storing application settings -CREATE EXTENSION temporal_tables; - -CREATE TABLE settings ( - key TEXT NOT NULL, - value TEXT NOT NULL -); - --- Insert initial schema version setting if it doesn't exist -INSERT INTO settings (key, value) -VALUES ('schema_version', '0.0.0.9003'); diff --git a/inst/postgres/01-initialize.sql b/inst/postgres/01-initialize.sql deleted file mode 100644 index 62022c9..0000000 --- a/inst/postgres/01-initialize.sql +++ /dev/null @@ -1,337 +0,0 @@ --- Table: study --- Purpose: Stores information about various studies conducted. --- 'id' is an auto-incrementing primary key uniquely identifying each study. --- 'identifier' is a unique, short textual identifier for the study (max 12 characters). --- 'name' provides the full name or title of the study. --- 'method' is a randomization method name --- 'sys_period' is of type TSTZRANGE, used for temporal versioning to track the validity period of each record. -CREATE TABLE study ( - id SERIAL PRIMARY KEY, - identifier VARCHAR(12) NOT NULL, - name VARCHAR(255) NOT NULL, - method VARCHAR(255) NOT NULL, - parameters JSONB, - timestamp TIMESTAMPTZ NOT NULL DEFAULT now(), - sys_period TSTZRANGE NOT NULL -); - --- Table: arm --- Purpose: Represents the treatment arms within each study. --- 'id' is an auto-incrementing primary key that uniquely identifies each arm. --- 'study_id' is a foreign key that links each arm to its corresponding study. --- 'name' provides a descriptive name for the treatment arm. --- 'ratio' specifies the proportion of patients allocated to this arm. It defaults to 1 and must always be positive. --- 'sys_period' is of type TSTZRANGE, used for temporal versioning to track the validity period of each record. --- The 'arm_study' foreign key constraint ensures that each arm is associated with a valid study. --- The 'uc_arm_study' unique constraint ensures that each combination of 'id' and 'study_id' is unique, --- which is important for maintaining data integrity across studies. --- The 'ratio_positive' check constraint ensures that the ratio is always greater than 0, --- maintaining logical consistency in the patient allocation process. -CREATE TABLE arm ( - id SERIAL PRIMARY KEY, - study_id INT NOT NULL, - name VARCHAR(255) NOT NULL, - ratio INT NOT NULL DEFAULT 1, - sys_period TSTZRANGE NOT NULL, - CONSTRAINT arm_study - FOREIGN KEY (study_id) - REFERENCES study (id) ON DELETE CASCADE, - CONSTRAINT uc_arm_study - UNIQUE (id, study_id), - CONSTRAINT ratio_positive - CHECK (ratio > 0) -); - --- Table: stratum --- Purpose: Defines the strata for patient categorization within each study. --- 'id' is an auto-incrementing primary key that uniquely identifies each stratum. --- 'study_id' is a foreign key that links the stratum to a specific study. --- 'name' provides a descriptive name for the stratum, such as a particular demographic or clinical characteristic. --- 'value_type' indicates the type of value the stratum represents, limited to two types: 'factor' or 'numeric'. --- 'factor' represents categorical data, while 'numeric' represents numerical data. --- This distinction is crucial as it informs the data validation logic applied in the system. --- 'sys_period' is of type TSTZRANGE, used for temporal versioning to track the validity period of each record. --- The 'fk_study' foreign key constraint ensures that each stratum is associated with a valid study and cascades deletions. --- The 'chk_value_type' check constraint ensures that the 'value_type' field only contains allowed values ('factor' or 'numeric'), --- enforcing data integrity and consistency in the type of stratum values. --- Subsequent validation checks in the system (like 'check_fct_stratum') use the 'value_type' field to ensure data integrity, --- by verifying that constraints on data (factor or numeric) align with the stratum type. -CREATE TABLE stratum ( - id SERIAL PRIMARY KEY, - study_id INT NOT NULL, - name VARCHAR(255) NOT NULL, - value_type VARCHAR(12), - sys_period TSTZRANGE NOT NULL, - CONSTRAINT fk_study - FOREIGN KEY (study_id) - REFERENCES study (id) ON DELETE CASCADE, - CONSTRAINT chk_value_type - CHECK (value_type IN ('factor', 'numeric')) -); - --- Table: stratum_level --- Purpose: Keeps allowed stratum factor levels --- 'id' is an auto-incrementing primary key that uniquely identifies each stratum. --- 'level' level label, has to be unique within stratum -CREATE TABLE stratum_level ( - stratum_id INT NOT NULL, - level VARCHAR(255) NOT NULL, - CONSTRAINT fk_stratum_level - FOREIGN KEY (stratum_id) - REFERENCES stratum (id) ON DELETE CASCADE, - CONSTRAINT uc_stratum_level - UNIQUE (stratum_id, level) -); - --- Table: factor_constraint --- Purpose: Defines constraints for strata of the 'factor' type in studies. --- This table stores allowable values for each factor stratum, ensuring data consistency and integrity. --- 'stratum_id' is a foreign key that links the constraint to a specific stratum in the 'stratum' table. --- 'value' represents the specific allowable value for the factor stratum. --- This could be a categorical label like 'male' or 'female' for a gender stratum, for example. --- 'sys_period' is of type TSTZRANGE, used for temporal versioning to track the validity period of each record. --- The 'factor_stratum' foreign key constraint ensures that each constraint is associated with a valid factor type stratum. --- The 'uc_stratum_value' unique constraint ensures that each combination of 'stratum_id' and 'value' is unique within the table. --- This prevents duplicate entries for the same stratum and value, maintaining the integrity of the constraint data. -CREATE TABLE factor_constraint ( - stratum_id INT NOT NULL, - value VARCHAR(255) NOT NULL, - sys_period TSTZRANGE NOT NULL, - CONSTRAINT factor_stratum - FOREIGN KEY (stratum_id) - REFERENCES stratum (id) ON DELETE CASCADE, - CONSTRAINT uc_stratum_value - UNIQUE (stratum_id, value) -); - --- Table: numeric_constraint --- Purpose: Specifies constraints for strata of the 'numeric' type in studies. --- This table defines the permissible range (minimum and maximum values) for each numeric stratum. --- 'stratum_id' is a foreign key that links the constraint to a specific numeric stratum in the 'stratum' table. --- 'min_value' and 'max_value' define the allowable range for the stratum's numeric values. --- For example, if the stratum represents age, 'min_value' and 'max_value' might define the age range for a study group. --- Either of these columns can be NULL, indicating that there is no lower or upper bound, respectively. --- 'sys_period' is of type TSTZRANGE, used for temporal versioning to track the validity period of each record. --- The 'numeric_stratum' foreign key constraint ensures that each constraint is associated with a valid numeric type stratum. --- The 'uc_stratum' unique constraint ensures that there is only one constraint entry per 'stratum_id'. --- The 'chk_min_max' check constraint ensures that 'min_value' is always less than or equal to 'max_value', --- maintaining logical consistency. If either value is NULL, the check constraint still holds valid as per SQL standards. -CREATE TABLE numeric_constraint ( - stratum_id INT NOT NULL, - min_value FLOAT, - max_value FLOAT, - sys_period TSTZRANGE NOT NULL, - CONSTRAINT numeric_stratum - FOREIGN KEY (stratum_id) - REFERENCES stratum (id) ON DELETE CASCADE, - CONSTRAINT uc_stratum - UNIQUE (stratum_id), - CONSTRAINT chk_min_max - -- NULL is ok in checks, no need to test for it - CHECK (min_value <= max_value) -); - --- Table: patient --- Purpose: Represents individual patients participating in the studies. --- 'id' is an auto-incrementing primary key that uniquely identifies each patient. --- 'study_id' is a foreign key linking the patient to a specific study. --- 'arm_id' is an optional foreign key that links the patient to a specific treatment arm within the study. --- For instance, in methods like simple randomization, 'arm_id' is assigned as patients are randomized. --- Conversely, in methods such as block randomization, 'arm_id' might be pre-assigned based on a predetermined randomization list. --- This flexible approach allows for accommodating various randomization methods and their unique requirements. --- 'used' is a boolean flag indicating the state of the patient in the randomization process. --- In methods like simple randomization, patients are entered into this table only when they are randomized, --- meaning 'used' will always be true for these entries, as there are no pre-plans in this method. --- For other methods, such as block randomization, 'used' is utilized to mark patients as 'used' --- according to a pre-planned randomization list, accommodating pre-assignment in these scenarios. --- This design allows the system to adapt to different randomization strategies effectively. --- 'sys_period' is of type TSTZRANGE, used for temporal versioning to track the validity period of each record. --- The 'patient_arm_study' foreign key constraint ensures referential integrity between patients, studies, and arms. --- It also cascades deletions to maintain consistency when a study or arm is deleted. --- The 'used_with_arm' check constraint ensures logical consistency by allowing 'used' to be true only if the patient --- is assigned to an arm (i.e., 'arm_id' is not NULL). --- This prevents scenarios where a patient is marked as used but not assigned to any treatment arm. -CREATE TABLE patient ( - id SERIAL PRIMARY KEY, - study_id INT NOT NULL, - arm_id INT, - used BOOLEAN NOT NULL DEFAULT false, - -- timestamp TIMESTAMPTZ NOT NULL DEFAULT now(), - sys_period TSTZRANGE NOT NULL, - CONSTRAINT patient_arm_study - FOREIGN KEY (arm_id, study_id) - REFERENCES arm (id, study_id) ON DELETE CASCADE, - CONSTRAINT used_with_arm - CHECK (NOT used OR arm_id IS NOT NULL) -); - --- Table: patient_stratum --- Purpose: Associates patients with specific strata and records the corresponding stratum values. --- 'patient_id' is a foreign key that links to the 'patient' table, identifying the patient. --- 'stratum_id' is a foreign key that links to the 'stratum' table, identifying the stratum to which the patient belongs. --- 'fct_value' stores the categorical (factor) value for the patient in the corresponding stratum, if applicable. --- 'num_value' stores the numerical value for the patient in the corresponding stratum, if applicable. --- For example, if a stratum represents a demographic category, 'fct_value' might be used; --- if it represents a measurable characteristic like age, 'num_value' might be used. --- 'sys_period' is of type TSTZRANGE, used for temporal versioning to track the validity period of each record. --- The 'fk_patient' and 'fk_stratum_2' foreign key constraints link each patient-stratum pairing to the respective tables. --- The 'chk_value_exists' check constraint ensures that either a factor or numeric value is provided for each record, --- aligning with the nature of the stratum. --- The 'chk_one_value_only' check constraint ensures that each record has either a factor or a numeric value, but not both, --- maintaining the integrity of the data by ensuring it matches the stratum type (factor or numeric). -CREATE TABLE patient_stratum ( - patient_id INT NOT NULL, - stratum_id INT NOT NULL, - fct_value VARCHAR(255), - num_value FLOAT, - sys_period TSTZRANGE NOT NULL, - CONSTRAINT fk_patient - FOREIGN KEY (patient_id) - REFERENCES patient (id) ON DELETE CASCADE, - CONSTRAINT fk_stratum_2 - FOREIGN KEY (stratum_id) - REFERENCES stratum (id) ON DELETE CASCADE, - CONSTRAINT chk_value_exists - -- Either factor or numeric value must be given - CHECK (fct_value IS NOT NULL OR num_value IS NOT NULL), - CONSTRAINT chk_one_value_only - -- Can't give both factor and numeric value - CHECK (fct_value IS NULL OR num_value IS NULL), - CONSTRAINT uc_patient_stratum - UNIQUE (patient_id, stratum_id) -); - --- Stratum constraint checks - -CREATE OR REPLACE FUNCTION check_fct_stratum() -RETURNS trigger AS $$ -BEGIN - IF NOT EXISTS ( - SELECT 1 FROM stratum - -- Checks that column value is correct - WHERE id = NEW.stratum_id AND value_type = 'factor' - ) THEN - RAISE EXCEPTION 'Can''t set factor constraint for non-factor stratum.'; - END IF; - RETURN NEW; -END; -$$ LANGUAGE plpgsql; - -CREATE TRIGGER stratum_fct_constraint -BEFORE INSERT ON factor_constraint -FOR EACH ROW -EXECUTE PROCEDURE check_fct_stratum(); - - -CREATE OR REPLACE FUNCTION check_num_stratum() -RETURNS trigger AS $$ -BEGIN - IF NOT EXISTS ( - SELECT 1 FROM stratum - -- Checks that column value is correct - WHERE id = NEW.stratum_id AND value_type = 'numeric' - ) THEN - RAISE EXCEPTION 'Can''t set numeric constraint for non-numeric stratum.'; - END IF; - RETURN NEW; -END; -$$ LANGUAGE plpgsql; - -CREATE TRIGGER stratum_num_constraint -BEFORE INSERT ON numeric_constraint -FOR EACH ROW -EXECUTE PROCEDURE check_num_stratum(); - --- Patient stratum value checks - --- Ensure that patients and strata are assigned to the same study. -CREATE OR REPLACE FUNCTION check_patient_stratum_study() -RETURNS trigger AS $$ -BEGIN - DECLARE - patient_study INT := ( - SELECT study_id FROM patient - WHERE id = NEW.patient_id - ); - stratum_study INT := ( - SELECT study_id FROM stratum - WHERE id = NEW.stratum_id - ); - BEGIN - IF (patient_study <> stratum_study) THEN - RAISE EXCEPTION 'Stratum and patient must be assigned to the same study.'; - END IF; - END; - RETURN NEW; -END; -$$ LANGUAGE plpgsql; - -CREATE TRIGGER patient_stratum_study_constraint -BEFORE INSERT ON patient_stratum -FOR EACH ROW -EXECUTE PROCEDURE check_patient_stratum_study(); - --- Validate and enforce factor stratum values. -CREATE OR REPLACE FUNCTION check_fct_patient() -RETURNS trigger AS $$ -BEGIN - IF EXISTS ( - SELECT 1 FROM stratum - WHERE id = NEW.stratum_id AND value_type = 'factor' - ) THEN - IF (NEW.fct_value IS NULL) THEN - RAISE EXCEPTION 'Factor stratum requires a factor value.'; - END IF; - IF NOT EXISTS ( - SELECT 1 FROM factor_constraint - WHERE stratum_id = NEW.stratum_id AND value = NEW.fct_value - ) THEN - RAISE EXCEPTION 'Factor value not specified as allowed.'; - END IF; - END IF; - RETURN NEW; -END; -$$ LANGUAGE plpgsql; - -CREATE TRIGGER patient_fct_constraint -BEFORE INSERT ON patient_stratum -FOR EACH ROW -EXECUTE PROCEDURE check_fct_patient(); - --- Validate and enforce numeric stratum values within specified constraints. -CREATE OR REPLACE FUNCTION check_num_patient() -RETURNS trigger AS $$ -BEGIN - IF EXISTS ( - SELECT 1 FROM stratum - WHERE id = NEW.stratum_id AND value_type = 'numeric' - ) THEN - IF (NEW.num_value IS NULL) THEN - RAISE EXCEPTION 'Numeric stratum requires a numeric value.'; - END IF; - DECLARE - min_value FLOAT := ( - SELECT min_value FROM numeric_constraint - WHERE stratum_id = NEW.stratum_id - ); - max_value FLOAT := ( - SELECT max_value FROM numeric_constraint - WHERE stratum_id = NEW.stratum_id - ); - BEGIN - IF (min_value IS NOT NULL AND NEW.num_value < min_value) THEN - RAISE EXCEPTION 'New value is lower than minimum allowed value.'; - END IF; - IF (max_value IS NOT NULL AND NEW.num_value > max_value) THEN - RAISE EXCEPTION 'New value is greater than maximum allowed value.'; - END IF; - END; - END IF; - RETURN NEW; -END; -$$ LANGUAGE plpgsql; - -CREATE TRIGGER patient_num_constraint -BEFORE INSERT ON patient_stratum -FOR EACH ROW -EXECUTE PROCEDURE check_num_patient(); diff --git a/inst/postgres/90-examples.sql b/inst/postgres/90-examples.sql deleted file mode 100644 index 7b2f98b..0000000 --- a/inst/postgres/90-examples.sql +++ /dev/null @@ -1,29 +0,0 @@ -INSERT INTO study (identifier, name, method, parameters) -VALUES ('TEST', 'Badanie testowe', 'minimise_pocock', '{"method": "var", "p": 0.85, "weights": {"gender": 1}}'); - - -INSERT INTO arm (study_id, name, ratio) -VALUES (1, 'placebo', 2), - (1, 'active', 1); - -INSERT INTO stratum (study_id, name, value_type) -VALUES (1, 'gender', 'factor'); - -INSERT INTO factor_constraint (stratum_id, value) -VALUES (1, 'F'), (1, 'M'); - -INSERT INTO patient (study_id, arm_id) -VALUES (1, 1); - -INSERT INTO patient_stratum (patient_id, stratum_id, fct_value) -VALUES (1, 1, 'F'); - -UPDATE patient -SET used = true -WHERE id = 1; - --- Trigger properly raises an error here -/* -INSERT INTO numeric_constraint (stratum_id) -VALUES (1); -*/ diff --git a/man/compare_rows.Rd b/man/compare_rows.Rd index ed3a414..da314a0 100644 --- a/man/compare_rows.Rd +++ b/man/compare_rows.Rd @@ -4,18 +4,19 @@ \alias{compare_rows} \title{Compare rows of two dataframes} \usage{ -compare_rows(A, B) +compare_rows(all_patients, new_patients) } \arguments{ -\item{A}{data.frame with all patients} +\item{all_patients}{data.frame with all patients} -\item{B}{data.frame with new patient} +\item{new_patients}{data.frame with new patient} } \value{ -data.frame with columns as in A and B, filled with TRUE if there is -match in covariate and FALSE if not +data.frame with columns as in all_patients and new_patients, +filled with TRUE if there is match in covariate and FALSE if not } \description{ -Takes dataframe B (presumably with one row / patient) and compares it to all -rows of A (presumably already randomized patietns) +Takes dataframe all_patients (presumably with one row / patient) and +compares it to all rows of new_patients (presumably already randomized +patients) } diff --git a/man/create_db_connection_pool.Rd b/man/create_db_connection_pool.Rd new file mode 100644 index 0000000..9a76532 --- /dev/null +++ b/man/create_db_connection_pool.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/db.R +\name{create_db_connection_pool} +\alias{create_db_connection_pool} +\title{Defines methods for interacting with the study in the database +Create a database connection pool} +\usage{ +create_db_connection_pool(...) +} +\value{ +A pool object representing the connection pool to the database. +} +\description{ +This function creates a connection pool to a PostgreSQL database. It uses +environment variables to get the necessary connection parameters. If the +connection fails, it will retry up to 5 times with a delay of 2 seconds +between each attempt. +} +\examples{ +\dontrun{ +pool <- create_db_connection_pool() +} +} diff --git a/man/get_similar_studies.Rd b/man/get_similar_studies.Rd deleted file mode 100644 index f56af93..0000000 --- a/man/get_similar_studies.Rd +++ /dev/null @@ -1,11 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/study-repository.R -\name{get_similar_studies} -\alias{get_similar_studies} -\title{Defines methods for interacting with the study in the database} -\usage{ -get_similar_studies(name, identifier) -} -\description{ -Defines methods for interacting with the study in the database -} diff --git a/man/list_studies.Rd b/man/list_studies.Rd deleted file mode 100644 index c11cbb3..0000000 --- a/man/list_studies.Rd +++ /dev/null @@ -1,14 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/study-list.R -\name{list_studies} -\alias{list_studies} -\title{List available studies} -\usage{ -list_studies() -} -\value{ -A tibble with basic study info, including ID. -} -\description{ -Queries the DB for the basic information about existing studies. -} diff --git a/man/randomize_minimisation_pocock.Rd b/man/randomize_minimisation_pocock.Rd index f2e2341..d71f807 100644 --- a/man/randomize_minimisation_pocock.Rd +++ b/man/randomize_minimisation_pocock.Rd @@ -46,15 +46,16 @@ name of the arm assigned to the patient The \code{randomize_dynamic} function implements the dynamic randomization algorithm using the minimization method proposed by Pocock (Pocock and Simon, 1975). It requires defining basic study parameters: the number of arms (K), -number of covariates (C), patient allocation ratios (\(a_{k}\)) (where k = 1,2,…., K), -weights for the covariates (\(w_{i}\)) (where i = 1,2,…., C), and the maximum probability (p) -of assigning a patient to the group with the smallest total unbalance multiplied by -the respective weights (\(G_{k}\)). As the total unbalance for the first patient is the same -regardless of the assigned arm, this patient is randomly allocated to a given -arm. Subsequent patients are randomized based on the calculation of the -unbalance depending on the selected method: "range", "var" (variance), or -"sd" (standard deviation). In the case of two arms, the "range" method is -equivalent to the "sd" method. +number of covariates (C), patient allocation ratios (\(a_{k}\)) +(where k = 1,2,…., K), weights for the covariates (\(w_{i}\)) +(where i = 1,2,…., C), and the maximum probability (p) of assigning a patient +to the group with the smallest total unbalance multiplied by +the respective weights (\(G_{k}\)). As the total unbalance for the first +patient is the same regardless of the assigned arm, this patient is randomly +allocated to a given arm. Subsequent patients are randomized based on the +calculation of the unbalance depending on the selected method: "range", +"var" (variance), or "sd" (standard deviation). In the case of two arms, +the "range" method is equivalent to the "sd" method. } \details{ Initially, the algorithm creates a matrix of results comparing a newly @@ -69,47 +70,57 @@ of three methods (“sd”, “range”, “var”). Based on the number of defined arms, the minimum value of (\(G_{k}\)) (defined as the weighted sum of the level-based imbalance) selects the arm to which the patient will be assigned with a predefined probability (p). The -probability that a patient will be assigned to any other arm will then be equal (1-p)/(K-1) +probability that a patient will be assigned to any other arm will then be +equal (1-p)/(K-1) for each of the remaining arms. } \note{ -This function's implementation is a refactored adaptation of the codebase from the 'Minirand' package. +This function's implementation is a refactored adaptation +of the codebase from the 'Minirand' package. } \examples{ n_at_the_moment <- 10 arms <- c("control", "active low", "active high") sex <- sample(c("F", "M"), - n_at_the_moment + 1, - replace = TRUE, - prob = c(0.4, 0.6) + n_at_the_moment + 1, + replace = TRUE, + prob = c(0.4, 0.6) ) diabetes <- sample(c("diabetes", "no diabetes"), - n_at_the_moment + 1, - replace = TRUE, - prob = c(0.2, 0.8) + n_at_the_moment + 1, + replace = TRUE, + prob = c(0.2, 0.8) ) arm <- sample(arms, - n_at_the_moment, - replace = TRUE, - prob = c(0.4, 0.4, 0.2) + n_at_the_moment, + replace = TRUE, + prob = c(0.4, 0.4, 0.2) ) |> c("") covar_df <- tibble::tibble(sex, diabetes, arm) covar_df randomize_minimisation_pocock(arms = arms, current_state = covar_df) -randomize_minimisation_pocock(arms = arms, current_state = covar_df, - ratio = c("control" = 1, - "active low" = 2, - "active high" = 2), - weights = c("sex" = 0.5, - "diabetes" = 1)) +randomize_minimisation_pocock( + arms = arms, current_state = covar_df, + ratio = c( + "control" = 1, + "active low" = 2, + "active high" = 2 + ), + weights = c( + "sex" = 0.5, + "diabetes" = 1 + ) +) } \references{ -Pocock, S. J., & Simon, R. (1975). Minimization: A new method of assigning patients to treatment and control groups in clinical trials. +Pocock, S. J., & Simon, R. (1975). Minimization: A new method +of assigning patients to treatment and control groups in clinical trials. -Minirand Package: Man Jin, Adam Polis, Jonathan Hartzel. (https://CRAN.R-project.org/package=Minirand) +Minirand Package: Man Jin, Adam Polis, Jonathan Hartzel. +(https://CRAN.R-project.org/package=Minirand) } diff --git a/man/read_study_details.Rd b/man/read_study_details.Rd deleted file mode 100644 index 1659dac..0000000 --- a/man/read_study_details.Rd +++ /dev/null @@ -1,19 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/study-details.R -\name{read_study_details} -\alias{read_study_details} -\title{Read study details} -\usage{ -read_study_details(study_id) -} -\arguments{ -\item{study_id}{\code{integer(1)}\cr -ID of the study.} -} -\value{ -A tibble with study details, containing potentially complex columns, -like \code{arms}. -} -\description{ -Queries the DB for the study parameters, including declared arms and strata. -} diff --git a/man/run_unbiased.Rd b/man/run_unbiased.Rd index b6a1478..a7f87f4 100644 --- a/man/run_unbiased.Rd +++ b/man/run_unbiased.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/run_api.R +% Please edit documentation in R/run-api.R \name{run_unbiased} \alias{run_unbiased} \title{Run API} \usage{ -run_unbiased(host = "0.0.0.0", port = 3838, ...) +run_unbiased() } \arguments{ \item{host}{\code{character(1)}\cr diff --git a/man/study_exists.Rd b/man/study_exists.Rd deleted file mode 100644 index 66196fc..0000000 --- a/man/study_exists.Rd +++ /dev/null @@ -1,18 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/study-list.R -\name{study_exists} -\alias{study_exists} -\title{Validate study existence} -\usage{ -study_exists(study_id) -} -\arguments{ -\item{study_id}{\code{integer(1)}\cr -ID of the study.} -} -\value{ -\code{TRUE} or \code{FALSE}, depending whether given ID exists in the DB. -} -\description{ -Checks the database for the existence of given ID. -} diff --git a/migrate_db.sh b/migrate_db.sh new file mode 100644 index 0000000..e4d342a --- /dev/null +++ b/migrate_db.sh @@ -0,0 +1,12 @@ +#!/bin/bash + +set -e + +echo "Running database migrations" + +echo "Using database $POSTGRES_DB" + +DB_CONNECTION_STRING="postgres://$POSTGRES_USER:$POSTGRES_PASSWORD@$POSTGRES_HOST:$POSTGRES_PORT/$POSTGRES_DB?sslmode=disable" + +# Run the migrations, pass command line arguments to the migration tool +migrate -database "$DB_CONNECTION_STRING" -path ./inst/db/migrations "$@" \ No newline at end of file diff --git a/populate_db.sh b/populate_db.sh deleted file mode 100755 index ad9d1e4..0000000 --- a/populate_db.sh +++ /dev/null @@ -1,16 +0,0 @@ -#!/bin/bash - -set -e - -export PGPASSWORD="$POSTGRES_PASSWORD" - -# List all sql files in inst/postgres directory and execute them in alphabetical order -for f in inst/postgres/*.sql; do - echo "Executing $f" - psql -v ON_ERROR_STOP=1 \ - --host "$POSTGRES_HOST" \ - --port "${POSTGRES_PORT:-5432}" \ - --username "$POSTGRES_USER" \ - --dbname "$POSTGRES_DB" \ - -f "$f" -done \ No newline at end of file diff --git a/renv.lock b/renv.lock index 92b9151..f303d39 100644 --- a/renv.lock +++ b/renv.lock @@ -126,6 +126,13 @@ ], "Hash": "40415719b5a479b87949f3aa0aee737c" }, + "brew": { + "Package": "brew", + "Version": "1.0-10", + "Source": "Repository", + "Repository": "RSPM", + "Hash": "8f4a384e19dccd8c65356dc096847b76" + }, "brio": { "Package": "brio", "Version": "1.1.3", @@ -201,6 +208,23 @@ ], "Hash": "89e6d8219950eac806ae0c489052048a" }, + "clipr": { + "Package": "clipr", + "Version": "0.8.0", + "Source": "Repository", + "Repository": "RSPM", + "Requirements": [ + "utils" + ], + "Hash": "3f038e5ac7f41d4ac41ce658c85e3042" + }, + "commonmark": { + "Package": "commonmark", + "Version": "1.9.0", + "Source": "Repository", + "Repository": "RSPM", + "Hash": "d691c61bff84bd63c383874d2d0c3307" + }, "cpp11": { "Package": "cpp11", "Version": "0.4.6", @@ -223,6 +247,20 @@ ], "Hash": "e8a1e41acf02548751f45c718d55aa6a" }, + "credentials": { + "Package": "credentials", + "Version": "2.0.1", + "Source": "Repository", + "Repository": "RSPM", + "Requirements": [ + "askpass", + "curl", + "jsonlite", + "openssl", + "sys" + ], + "Hash": "c7844b32098dcbd1c59cbd8dddb4ecc6" + }, "curl": { "Package": "curl", "Version": "5.1.0", @@ -275,6 +313,40 @@ ], "Hash": "6b9602c7ebbe87101a9c8edb6e8b6d21" }, + "devtools": { + "Package": "devtools", + "Version": "2.4.5", + "Source": "Repository", + "Repository": "RSPM", + "Requirements": [ + "R", + "cli", + "desc", + "ellipsis", + "fs", + "lifecycle", + "memoise", + "miniUI", + "pkgbuild", + "pkgdown", + "pkgload", + "profvis", + "rcmdcheck", + "remotes", + "rlang", + "roxygen2", + "rversions", + "sessioninfo", + "stats", + "testthat", + "tools", + "urlchecker", + "usethis", + "utils", + "withr" + ], + "Hash": "ea5bc8b4a6a01e4f12d98b58329930bb" + }, "diffobj": { "Package": "diffobj", "Version": "0.3.5", @@ -419,16 +491,57 @@ ], "Hash": "15e9634c0fcd294799e9b2e929ed1b86" }, + "gert": { + "Package": "gert", + "Version": "2.0.1", + "Source": "Repository", + "Repository": "RSPM", + "Requirements": [ + "askpass", + "credentials", + "openssl", + "rstudioapi", + "sys", + "zip" + ], + "Hash": "f70d3fe2d9e7654213a946963d1591eb" + }, + "gh": { + "Package": "gh", + "Version": "1.4.0", + "Source": "Repository", + "Repository": "RSPM", + "Requirements": [ + "R", + "cli", + "gitcreds", + "httr2", + "ini", + "jsonlite", + "rlang" + ], + "Hash": "03533b1c875028233598f848fda44c4c" + }, + "gitcreds": { + "Package": "gitcreds", + "Version": "0.1.2", + "Source": "Repository", + "Repository": "RSPM", + "Requirements": [ + "R" + ], + "Hash": "ab08ac61f3e1be454ae21911eb8bc2fe" + }, "glue": { "Package": "glue", - "Version": "1.6.2", + "Version": "1.7.0", "Source": "Repository", - "Repository": "CRAN", + "Repository": "RSPM", "Requirements": [ "R", "methods" ], - "Hash": "4f2596dfb05dac67b9dc558e5c6fba2e" + "Hash": "e0b3a53876554bd45879e596cdb10a52" }, "highr": { "Package": "highr", @@ -472,6 +585,21 @@ ], "Hash": "2d7b3857980e0e0d0a1fd6f11928ab0f" }, + "htmlwidgets": { + "Package": "htmlwidgets", + "Version": "1.6.4", + "Source": "Repository", + "Repository": "RSPM", + "Requirements": [ + "grDevices", + "htmltools", + "jsonlite", + "knitr", + "rmarkdown", + "yaml" + ], + "Hash": "04291cc45198225444a397606810ac37" + }, "httpuv": { "Package": "httpuv", "Version": "1.6.11", @@ -523,6 +651,13 @@ ], "Hash": "e2b30f1fc039a0bab047dd52bb20ef71" }, + "ini": { + "Package": "ini", + "Version": "0.3.1", + "Source": "Repository", + "Repository": "RSPM", + "Hash": "6154ec2223172bce8162d4153cda21f7" + }, "jquerylib": { "Package": "jquerylib", "Version": "0.1.4", @@ -644,6 +779,18 @@ ], "Hash": "18e9c28c1d3ca1560ce30658b22ce104" }, + "miniUI": { + "Package": "miniUI", + "Version": "0.1.1.1", + "Source": "Repository", + "Repository": "RSPM", + "Requirements": [ + "htmltools", + "shiny", + "utils" + ], + "Hash": "fec5f52652d60615fdb3957b3d74324a" + }, "openssl": { "Package": "openssl", "Version": "2.1.1", @@ -827,6 +974,21 @@ ], "Hash": "3efbd8ac1be0296a46c55387aeace0f3" }, + "profvis": { + "Package": "profvis", + "Version": "0.3.8", + "Source": "Repository", + "Repository": "RSPM", + "Requirements": [ + "R", + "htmlwidgets", + "purrr", + "rlang", + "stringr", + "vctrs" + ], + "Hash": "aa5a3864397ce6ae03458f98618395a1" + }, "promises": { "Package": "promises", "Version": "1.2.1", @@ -890,6 +1052,28 @@ ], "Hash": "5e3c5dc0b071b21fa128676560dbe94d" }, + "rcmdcheck": { + "Package": "rcmdcheck", + "Version": "1.4.0", + "Source": "Repository", + "Repository": "RSPM", + "Requirements": [ + "R6", + "callr", + "cli", + "curl", + "desc", + "digest", + "pkgbuild", + "prettyunits", + "rprojroot", + "sessioninfo", + "utils", + "withr", + "xopen" + ], + "Hash": "8f25ebe2ec38b1f2aef3b0d2ef76f6c4" + }, "rematch2": { "Package": "rematch2", "Version": "2.1.2", @@ -900,6 +1084,20 @@ ], "Hash": "76c9e04c712a05848ae7a23d2f170a40" }, + "remotes": { + "Package": "remotes", + "Version": "2.4.2.1", + "Source": "Repository", + "Repository": "RSPM", + "Requirements": [ + "R", + "methods", + "stats", + "tools", + "utils" + ], + "Hash": "63d15047eb239f95160112bcadc4fcb9" + }, "renv": { "Package": "renv", "Version": "1.0.0", @@ -912,14 +1110,14 @@ }, "rlang": { "Package": "rlang", - "Version": "1.1.2", + "Version": "1.1.3", "Source": "Repository", "Repository": "RSPM", "Requirements": [ "R", "utils" ], - "Hash": "50a6dbdc522936ca35afc5e2082ea91b" + "Hash": "42548638fae05fd9a9b5f3f437fbbbe2" }, "rmarkdown": { "Package": "rmarkdown", @@ -945,6 +1143,32 @@ ], "Hash": "d65e35823c817f09f4de424fcdfa812a" }, + "roxygen2": { + "Package": "roxygen2", + "Version": "7.3.1", + "Source": "Repository", + "Repository": "RSPM", + "Requirements": [ + "R", + "R6", + "brew", + "cli", + "commonmark", + "cpp11", + "desc", + "knitr", + "methods", + "pkgload", + "purrr", + "rlang", + "stringi", + "stringr", + "utils", + "withr", + "xml2" + ], + "Hash": "c25fe7b2d8cba73d1b63c947bf7afdb9" + }, "rprojroot": { "Package": "rprojroot", "Version": "2.0.3", @@ -955,6 +1179,25 @@ ], "Hash": "1de7ab598047a87bba48434ba35d497d" }, + "rstudioapi": { + "Package": "rstudioapi", + "Version": "0.15.0", + "Source": "Repository", + "Repository": "RSPM", + "Hash": "5564500e25cffad9e22244ced1379887" + }, + "rversions": { + "Package": "rversions", + "Version": "2.1.2", + "Source": "Repository", + "Repository": "RSPM", + "Requirements": [ + "curl", + "utils", + "xml2" + ], + "Hash": "a9881dfed103e83f9de151dc17002cd1" + }, "sass": { "Package": "sass", "Version": "0.4.8", @@ -969,6 +1212,53 @@ ], "Hash": "168f9353c76d4c4b0a0bbf72e2c2d035" }, + "sessioninfo": { + "Package": "sessioninfo", + "Version": "1.2.2", + "Source": "Repository", + "Repository": "RSPM", + "Requirements": [ + "R", + "cli", + "tools", + "utils" + ], + "Hash": "3f9796a8d0a0e8c6eb49a4b029359d1f" + }, + "shiny": { + "Package": "shiny", + "Version": "1.8.0", + "Source": "Repository", + "Repository": "RSPM", + "Requirements": [ + "R", + "R6", + "bslib", + "cachem", + "commonmark", + "crayon", + "ellipsis", + "fastmap", + "fontawesome", + "glue", + "grDevices", + "htmltools", + "httpuv", + "jsonlite", + "later", + "lifecycle", + "methods", + "mime", + "promises", + "rlang", + "sourcetools", + "tools", + "utils", + "withr", + "xtable" + ], + "Hash": "3a1f41807d648a908e3c7f0334bf85e6" + }, "sodium": { "Package": "sodium", "Version": "1.3.0", @@ -976,6 +1266,16 @@ "Repository": "RSPM", "Hash": "bd436c1e48dc1982125e4d955017724e" }, + "sourcetools": { + "Package": "sourcetools", + "Version": "0.1.7-1", + "Source": "Repository", + "Repository": "RSPM", + "Requirements": [ + "R" + ], + "Hash": "5f5a7629f956619d519205ec475fe647" + }, "stringi": { "Package": "stringi", "Version": "1.7.12", @@ -1151,6 +1451,51 @@ ], "Hash": "5ac22900ae0f386e54f1c307eca7d843" }, + "urlchecker": { + "Package": "urlchecker", + "Version": "1.0.1", + "Source": "Repository", + "Repository": "RSPM", + "Requirements": [ + "R", + "cli", + "curl", + "tools", + "xml2" + ], + "Hash": "409328b8e1253c8d729a7836fe7f7a16" + }, + "usethis": { + "Package": "usethis", + "Version": "2.2.2", + "Source": "Repository", + "Repository": "RSPM", + "Requirements": [ + "R", + "cli", + "clipr", + "crayon", + "curl", + "desc", + "fs", + "gert", + "gh", + "glue", + "jsonlite", + "lifecycle", + "purrr", + "rappdirs", + "rlang", + "rprojroot", + "rstudioapi", + "stats", + "utils", + "whisker", + "withr", + "yaml" + ], + "Hash": "60e51f0b94d0324dc19e44110098fa9f" + }, "utf8": { "Package": "utf8", "Version": "1.2.3", @@ -1212,16 +1557,15 @@ }, "withr": { "Package": "withr", - "Version": "2.5.2", + "Version": "3.0.0", "Source": "Repository", "Repository": "RSPM", "Requirements": [ "R", "grDevices", - "graphics", - "stats" + "graphics" ], - "Hash": "4b25e70111b7d644322e9513f403a272" + "Hash": "d31b6c62c10dcf11ec530ca6b0dd5d35" }, "xfun": { "Package": "xfun", @@ -1247,12 +1591,42 @@ ], "Hash": "1d0336142f4cd25d8d23cd3ba7a8fb61" }, + "xopen": { + "Package": "xopen", + "Version": "1.0.0", + "Source": "Repository", + "Repository": "RSPM", + "Requirements": [ + "R", + "processx" + ], + "Hash": "6c85f015dee9cc7710ddd20f86881f58" + }, + "xtable": { + "Package": "xtable", + "Version": "1.8-4", + "Source": "Repository", + "Repository": "RSPM", + "Requirements": [ + "R", + "stats", + "utils" + ], + "Hash": "b8acdf8af494d9ec19ccb2481a9b11c2" + }, "yaml": { "Package": "yaml", "Version": "2.3.8", "Source": "Repository", "Repository": "RSPM", "Hash": "29240487a071f535f5e5d5a323b7afbd" + }, + "zip": { + "Package": "zip", + "Version": "2.3.1", + "Source": "Repository", + "Repository": "RSPM", + "Hash": "fcc4bd8e6da2d2011eb64a5e5cc685ab" } } } diff --git a/renv/.dockerignore b/renv/.dockerignore new file mode 100644 index 0000000..0ec0cbb --- /dev/null +++ b/renv/.dockerignore @@ -0,0 +1,7 @@ +library/ +local/ +cellar/ +lock/ +python/ +sandbox/ +staging/ diff --git a/run_tests.sh b/run_tests.sh new file mode 100644 index 0000000..39ef2f9 --- /dev/null +++ b/run_tests.sh @@ -0,0 +1,6 @@ +#!/bin/bash + +set -e +echo "Running tests" + +R --quiet --no-save -e "devtools::load_all(); testthat::test_package('unbiased')" diff --git a/run_tests_with_coverage.sh b/run_tests_with_coverage.sh new file mode 100644 index 0000000..f2d272d --- /dev/null +++ b/run_tests_with_coverage.sh @@ -0,0 +1,7 @@ +#!/bin/bash + +set -e + +echo "Running tests" + +R --quiet --no-save -e "devtools::load_all(); covr::package_coverage()" diff --git a/start_unbiased_api.sh b/start_unbiased_api.sh new file mode 100644 index 0000000..991cccc --- /dev/null +++ b/start_unbiased_api.sh @@ -0,0 +1,7 @@ +#!/bin/bash + +set -e + +echo "Running unbiased" + +R --quiet --no-save -e "devtools::load_all(); unbiased:::run_unbiased()" diff --git a/tests/testthat/.gitignore b/tests/testthat/.gitignore new file mode 100644 index 0000000..6a5a9b5 --- /dev/null +++ b/tests/testthat/.gitignore @@ -0,0 +1 @@ +testthat-problems.rds \ No newline at end of file diff --git a/tests/testthat/fixtures/example_study.yml b/tests/testthat/fixtures/example_study.yml new file mode 100644 index 0000000..083c9f6 --- /dev/null +++ b/tests/testthat/fixtures/example_study.yml @@ -0,0 +1,42 @@ +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/setup-CI.R b/tests/testthat/setup-CI.R deleted file mode 100644 index 4d76a08..0000000 --- a/tests/testthat/setup-CI.R +++ /dev/null @@ -1,3 +0,0 @@ -is_CI <- function() { - isTRUE(as.logical(Sys.getenv("CI"))) -} diff --git a/tests/testthat/setup-DB.R b/tests/testthat/setup-DB.R deleted file mode 100644 index 50d2e3f..0000000 --- a/tests/testthat/setup-DB.R +++ /dev/null @@ -1,14 +0,0 @@ -if (is_CI()) { - # Define connection ---- - db_pool <- create_db_connection_pool() - conn <- pool::poolCheckout(db_pool) - - # Close DB connection upon exiting - withr::defer( - { - pool::poolReturn(conn) - pool::poolClose(db_pool) - }, - teardown_env() - ) -} diff --git a/tests/testthat/setup-api.R b/tests/testthat/setup-api.R deleted file mode 100644 index 081b53e..0000000 --- a/tests/testthat/setup-api.R +++ /dev/null @@ -1,46 +0,0 @@ -library(checkmate) -library(dplyr) -library(dbplyr) -library(httr2) - -api_url <- "http://api:3838" - -if (!isTRUE(as.logical(Sys.getenv("CI")))) { - withr::local_envvar( - # Extract current SHA and set it as a temporary env var - list(GITHUB_SHA = system("git rev-parse HEAD", intern = TRUE)) - ) - - # Overwrite API URL if not on CI - api_url <- "http://localhost:3838" - api_path <- tempdir() - - # Start the API - api <- callr::r_bg(\(path) { - # 1. Set path to `path` - # 2. Build a plumber API - plumber::plumb_api("unbiased", "unbiased_api") |> - plumber::pr_run(port = 3838) - }, args = list(path = api_path)) - - # Wait until started - while (!api$is_alive()) { - Sys.sleep(.2) - } - - # Close API upon exiting - withr::defer( - { - api$kill() - }, - teardown_env() - ) -} - -# Retry a request until the API starts -request(api_url) |> - # Endpoint that should be always available - req_url_path("meta", "sha") |> - req_method("GET") |> - req_retry(max_tries = 5) |> - req_perform() diff --git a/tests/testthat/setup-testing-environment.R b/tests/testthat/setup-testing-environment.R new file mode 100644 index 0000000..c09cd7b --- /dev/null +++ b/tests/testthat/setup-testing-environment.R @@ -0,0 +1,274 @@ +library(checkmate) +library(dplyr) +library(dbplyr) +library(httr2) + +run_psql <- function(statement) { + withr::local_envvar( + PGPASSWORD = Sys.getenv("POSTGRES_PASSWORD") + ) + + # Construct the command + command <- paste( + "psql", + "--host", shQuote(Sys.getenv("POSTGRES_HOST")), + "--port", shQuote(Sys.getenv("POSTGRES_PORT")), + "--username", shQuote(Sys.getenv("POSTGRES_USER")), + "--dbname", shQuote(Sys.getenv("POSTGRES_DB")), + "--command", shQuote(statement), + sep = " " + ) + + system(command, intern = TRUE) +} + +run_migrations <- function() { + # Construct the connection string + user <- Sys.getenv("POSTGRES_USER") + password <- Sys.getenv("POSTGRES_PASSWORD") + host <- Sys.getenv("POSTGRES_HOST") + port <- Sys.getenv("POSTGRES_PORT", "5432") + db <- Sys.getenv("POSTGRES_DB") + + print( + glue::glue( + "Running migrations on database {db} at {host}:{port}" + ) + ) + + migrations_path <- glue::glue( + "{root_repo_directory}/inst/db/migrations" + ) + if (!dir.exists(migrations_path)) { + # If the migrations directory does not exist + # we will assume that the package is installed + # and inst directory content is copied to the root directory + migrations_path <- glue::glue( + "{root_repo_directory}/db/migrations" + ) + } + + db_connection_string <- + glue::glue( + "postgres://{user}:{password}@{host}:{port}/{db}?sslmode=disable" + ) + command <- "migrate" + args <- c( + "-database", + db_connection_string, + "-path", + migrations_path, + "up" + ) + + system2(command, args) +} + +create_database <- function(db_name) { + # make sure we are not creating the database that we are using for connection + assert( + db_name != Sys.getenv("POSTGRES_DB"), + "Cannot create the database that is used for connection" + ) + print( + glue::glue( + "Creating database {db_name}" + ) + ) + run_psql( + glue::glue( + "CREATE DATABASE {db_name}" + ) + ) +} + +drop_database <- function(db_name) { + # make sure we are not dropping the database that we are using for connection + assert( + db_name != Sys.getenv("POSTGRES_DB"), + "Cannot drop the database that is used for connection" + ) + # first, terminate all connections to the database + print( + glue::glue( + "Terminating all connections to the database {db_name}" + ) + ) + run_psql( + glue::glue( + "SELECT pg_terminate_backend(pg_stat_activity.pid) + FROM pg_stat_activity + WHERE pg_stat_activity.datname = '{db_name}' + AND pid <> pg_backend_pid();" + ) + ) + print( + glue::glue( + "Dropping database {db_name}" + ) + ) + run_psql( + glue::glue( + "DROP DATABASE {db_name}" + ) + ) +} + +setup_test_db_connection_pool <- function(envir = parent.frame()) { + # We will create a connection pool to the database + # and store it in the global environment + # so that we can use it in the tests + # without having to pass it around + db_connection_pool <- unbiased:::create_db_connection_pool() + assign("db_connection_pool", db_connection_pool, envir = globalenv()) + withr::defer( + { + print("Closing database connection pool") + db_connection_pool$close() + assign("db_connection_pool", NULL, envir = globalenv()) + }, + envir = envir + ) +} + + +# We will always run the API on the localhost +# and on a random port +api_host <- "127.0.0.1" +api_port <- httpuv::randomPort() + +api_url <- glue::glue("http://{api_host}:{api_port}") +print(glue::glue("API URL: {api_url}")) + +# make sure we are in the root directory of the repository +# this is necessary to run the database migrations +# as well as to run the plumber API +current_working_dir <- getwd() +root_repo_directory <- + glue::glue(current_working_dir, "/../../") |> + normalizePath() +setwd(root_repo_directory) + +# append __test suffix to the database name +# we will use this as a convention to create a test database +# we have to avoid messing with the original database +db_name <- Sys.getenv("POSTGRES_DB") +db_name_test <- glue::glue("{db_name}__test") + +# create the test database using connection with the original database +create_database(db_name_test) + +# now that the database is created, we can set the environment variable +# to the test database name +# we will be working on the test database from now on +withr::local_envvar( + list( + POSTGRES_DB = db_name_test + ) +) + +# drop the test database upon exiting +withr::defer( + { + # make sure db_name_test ends with __test before dropping it + assert( + stringr::str_detect(db_name_test, "__test$"), + "db_name_test should end with __test" + ) + setwd(root_repo_directory) + drop_database(db_name_test) + }, + teardown_env() +) + +# run migrations +exit_code <- run_migrations() +if (exit_code != 0) { + stop( + glue::glue( + "Failed to run database migrations", + "exit code: {exit_code}" + ) + ) +} + +# We will run the unbiased API in the background +# and wait until it starts +# We are setting the environment variables +# so that the unbiased API will start an HTTP server +# on the specified host and port without coliision +# with the main API that might be running on the same machine +withr::local_envvar( + list( + UNBIASED_HOST = api_host, + UNBIASED_PORT = api_port + ) +) + +# Mock GITHUB_SHA as valid sha if it is not set +github_sha <- Sys.getenv( + "GITHUB_SHA", + "6e21b5b689cc9737ba0d24147ed4b634c7146a28" +) +if (github_sha == "") { + github_sha <- "6e21b5b689cc9737ba0d24147ed4b634c7146a28" +} +withr::local_envvar( + list( + GITHUB_SHA = github_sha + ) +) + +plumber_process <- callr::r_bg( + \() { + if (!requireNamespace("unbiased", quietly = TRUE)) { + # There is no installed unbiased package + # In that case, we will assume that we are running + # on the development machine + # and we will load the package using devtools + print("Installing unbiased package using devtools") + devtools::load_all() + } + + unbiased:::run_unbiased() + }, + supervise = TRUE +) + +withr::defer( + { + print("Server STDOUT:") + while (length(lines <- plumber_process$read_output_lines())) { + writeLines(lines) + } + print("Server STDERR:") + while (length(lines <- plumber_process$read_error_lines())) { + writeLines(lines) + } + print("Sending SIGINT to plumber process") + plumber_process$interrupt() + + print("Waiting for plumber process to exit") + plumber_process$wait() + }, + teardown_env() +) + +# go back to the original working directory +# that is used by the testthat package +setwd(current_working_dir) + +setup_test_db_connection_pool(envir = teardown_env()) + +# Retry a request until the API starts +print("Waiting for the API to start...") +request(api_url) |> + # Endpoint that should be always available + req_url_path("meta", "sha") |> + req_method("GET") |> + req_retry( + max_tries = 25, + backoff = \(x) 0.3 + ) |> + req_perform() +print("API started, running tests...") diff --git a/tests/testthat/test-DB-0.R b/tests/testthat/test-DB-0.R index 3bdc64e..ffa510d 100644 --- a/tests/testthat/test-DB-0.R +++ b/tests/testthat/test-DB-0.R @@ -1,16 +1,17 @@ # Named with '0' to make sure that this one runs first because it validates # basic properties of the database -skip_if_not(is_CI(), "DB tests require complex setup through Docker Compose") + +source("./test-helpers.R") # Setup constants ---- -versioned_tables <- c( - "study", "arm", "stratum", "factor_constraint", - "numeric_constraint", "patient", "patient_stratum" -) -nonversioned_tables <- c("settings") + # Test values ---- test_that("database contains base tables", { + conn <- pool::localCheckout( + get("db_connection_pool", envir = globalenv()) + ) + with_db_fixtures("fixtures/example_study.yml") expect_contains( DBI::dbListTables(conn), c(versioned_tables, nonversioned_tables) @@ -18,18 +19,12 @@ test_that("database contains base tables", { }) test_that("database contains history tables", { + conn <- pool::localCheckout( + get("db_connection_pool", envir = globalenv()) + ) + with_db_fixtures("fixtures/example_study.yml") expect_contains( DBI::dbListTables(conn), glue::glue("{versioned_tables}_history") ) }) - -test_that("database version is the same as package version (did you update /inst/postgres/00-metadata.sql?)", { - expect_identical( - tbl(conn, "settings") |> - filter(key == "schema_version") |> - pull(value), - packageVersion("unbiased") |> - as.character() - ) -}) diff --git a/tests/testthat/test-DB-study.R b/tests/testthat/test-DB-study.R index 3cd4b37..ca474cb 100644 --- a/tests/testthat/test-DB-study.R +++ b/tests/testthat/test-DB-study.R @@ -1,23 +1,10 @@ -skip_if_not(is_CI(), "DB tests require complex setup through Docker Compose") +source("./test-helpers.R") -test_that("there's a study named 'Badanie testowe' in 'study' table", { - expect_contains( - tbl(conn, "study") |> - pull(name), - "Badanie testowe" - ) -}) - -test_that("study named 'Badanie testowe' has an identifier 'TEST'", { - expect_identical( - tbl(conn, "study") |> - filter(name == "Badanie testowe") |> - pull(identifier), - "TEST" - ) -}) +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") expect_no_error({ tbl(conn, "study") |> rows_append( @@ -31,11 +18,12 @@ test_that("it is enough to provide a name, an identifier, and a method id", { }) }) -new_study_id <- tbl(conn, "study") |> - filter(identifier == "FINE") |> - pull(id) +# first study id is 1 +new_study_id <- 1 |> as.integer() test_that("deleting archivizes a study", { + conn <- pool::localCheckout(pool) + with_db_fixtures("fixtures/example_study.yml") expect_no_error({ tbl(conn, "study") |> rows_delete( @@ -51,87 +39,113 @@ test_that("deleting archivizes a study", { collect(), tibble( id = new_study_id, - identifier = "FINE", - name = "Correctly working study", + identifier = "TEST", + name = "Test Study", method = "minimisation_pocock" ) ) }) test_that("can't push arm with negative ratio", { - expect_error({ - tbl(conn, "arm") |> - rows_append( - tibble( - study_id = 1, - name = "Exception-throwing arm", - ratio = -1 - ), - copy = TRUE, in_place = TRUE - ) - }, regexp = "violates check constraint") + conn <- pool::localCheckout(pool) + with_db_fixtures("fixtures/example_study.yml") + expect_error( + { + tbl(conn, "arm") |> + rows_append( + tibble( + study_id = 1, + name = "Exception-throwing arm", + ratio = -1 + ), + copy = TRUE, in_place = TRUE + ) + }, + regexp = "violates check constraint" + ) }) test_that("can't push stratum other than factor or numeric", { - expect_error({ - tbl(conn, "stratum") |> - rows_append( - tibble( - study_id = 1, - name = "failing stratum", - value_type = "array" - ), - copy = TRUE, in_place = TRUE - ) - }, regexp = "violates check constraint") + conn <- pool::localCheckout(pool) + with_db_fixtures("fixtures/example_study.yml") + expect_error( + { + tbl(conn, "stratum") |> + rows_append( + tibble( + study_id = 1, + name = "failing stratum", + value_type = "array" + ), + copy = TRUE, in_place = TRUE + ) + }, + regexp = "violates check constraint" + ) }) test_that("can't push stratum level outside of defined levels", { + conn <- pool::localCheckout(pool) + with_db_fixtures("fixtures/example_study.yml") # create a new patient return <- expect_no_error({ - tbl(conn, "patient") |> - rows_append( - tibble(study_id = 1, - arm_id = 1, - used = TRUE), - copy = TRUE, in_place = TRUE, returning = id - ) |> - dbplyr::get_returned_rows() - }) + tbl(conn, "patient") |> + rows_append( + tibble( + study_id = 1, + arm_id = 1, + used = TRUE + ), + copy = TRUE, in_place = TRUE, returning = id + ) |> + dbplyr::get_returned_rows() + }) - added_patient_id <<- return$id + added_patient_id <- return$id - expect_error({ - tbl(conn, "patient_stratum") |> - rows_append( - tibble(patient_id = added_patient_id, - stratum_id = 1, - fct_value = "Female"), - copy = TRUE, in_place = TRUE - ) - }, regexp = "Factor value not specified as allowed") + expect_error( + { + tbl(conn, "patient_stratum") |> + rows_append( + tibble( + patient_id = added_patient_id, + stratum_id = 1, + fct_value = "Female" + ), + copy = TRUE, in_place = TRUE + ) + }, + regexp = "Factor value not specified as allowed" + ) # add legal value expect_no_error({ tbl(conn, "patient_stratum") |> rows_append( - tibble(patient_id = added_patient_id, - stratum_id = 1, - fct_value = "F"), + tibble( + patient_id = added_patient_id, + stratum_id = 1, + fct_value = "F" + ), copy = TRUE, in_place = TRUE ) }) }) test_that("numerical constraints are enforced", { + conn <- pool::localCheckout(pool) + with_db_fixtures("fixtures/example_study.yml") + added_patient_id <- 1 |> as.integer() return <- expect_no_error({ tbl(conn, "stratum") |> rows_append( - tibble(study_id = 1, - name = "age", - value_type = "numeric"), + tibble( + study_id = 1, + name = "age", + value_type = "numeric" + ), copy = TRUE, in_place = TRUE, returning = id ) |> dbplyr::get_returned_rows() @@ -142,43 +156,57 @@ test_that("numerical constraints are enforced", { expect_no_error({ tbl(conn, "numeric_constraint") |> rows_append( - tibble(stratum_id = added_stratum_id, - min_value = 18, - max_value = 64), + tibble( + stratum_id = added_stratum_id, + min_value = 18, + max_value = 64 + ), copy = TRUE, in_place = TRUE ) }) # and you can't add an illegal value - expect_error({ - tbl(conn, "patient_stratum") |> - rows_append( - tibble(patient_id = added_patient_id, - stratum_id = added_stratum_id, - num_value = 16), - copy = TRUE, in_place = TRUE - ) - }, regexp = "New value is lower than minimum") + expect_error( + { + tbl(conn, "patient_stratum") |> + rows_append( + tibble( + patient_id = added_patient_id, + stratum_id = added_stratum_id, + num_value = 16 + ), + copy = TRUE, in_place = TRUE + ) + }, + regexp = "New value is lower than minimum" + ) # you can add valid value expect_no_error({ tbl(conn, "patient_stratum") |> rows_append( - tibble(patient_id = added_patient_id, - stratum_id = added_stratum_id, - num_value = 23), + tibble( + patient_id = added_patient_id, + stratum_id = added_stratum_id, + num_value = 23 + ), copy = TRUE, in_place = TRUE ) }) # but you cannot add two values for one patient one stratum - expect_error({ - tbl(conn, "patient_stratum") |> - rows_append( - tibble(patient_id = added_patient_id, - stratum_id = added_stratum_id, - num_value = 24), - copy = TRUE, in_place = TRUE - ) - }, regexp = "duplicate key value violates unique constraint") + expect_error( + { + tbl(conn, "patient_stratum") |> + rows_append( + tibble( + patient_id = added_patient_id, + stratum_id = added_stratum_id, + num_value = 24 + ), + copy = TRUE, in_place = TRUE + ) + }, + regexp = "duplicate key value violates unique constraint" + ) }) diff --git a/tests/testthat/test-E2E-meta-tag.R b/tests/testthat/test-E2E-meta-tag.R index 80305af..eb8fee2 100644 --- a/tests/testthat/test-E2E-meta-tag.R +++ b/tests/testthat/test-E2E-meta-tag.R @@ -4,6 +4,6 @@ test_that("meta tag endpoint returns the SHA", { req_method("GET") |> req_perform() |> resp_body_json() - + expect_string(response, n.chars = 40, pattern = "^[0-9a-f]{40}$") }) diff --git a/tests/testthat/test-E2E-study-minimisation-pocock.R b/tests/testthat/test-E2E-study-minimisation-pocock.R index 9528eaa..c366092 100644 --- a/tests/testthat/test-E2E-study-minimisation-pocock.R +++ b/tests/testthat/test-E2E-study-minimisation-pocock.R @@ -10,7 +10,8 @@ test_that("endpoint returns the study id, can randomize 2 patients", { p = 0.85, arms = list( "placebo" = 1, - "active" = 1), + "active" = 1 + ), covariates = list( sex = list( weight = 1, @@ -20,7 +21,8 @@ test_that("endpoint returns the study id, can randomize 2 patients", { weight = 1, levels = c("up to 60kg", "61-80 kg", "81 kg or more") ) - )) + ) + ) ) |> req_perform() response_body <- @@ -34,10 +36,14 @@ test_that("endpoint returns the study id, can randomize 2 patients", { req_url_path("study", response_body$study$id, "patient") |> req_method("POST") |> req_body_json( - data = list(current_state = - tibble::tibble("sex" = c("female", "male"), - "weight" = c("61-80 kg", "81 kg or more"), - "arm" = c("placebo", ""))) + data = list( + current_state = + tibble::tibble( + "sex" = c("female", "male"), + "weight" = c("61-80 kg", "81 kg or more"), + "arm" = c("placebo", "") + ) + ) ) |> req_perform() response_patient_body <- @@ -48,26 +54,42 @@ test_that("endpoint returns the study id, can randomize 2 patients", { expect_number(response_patient_body$patient_id, lower = 1) # Endpoint Response Structure Test - checkmate::expect_names(names(response_patient_body), identical.to = c("patient_id", "arm_id", "arm_name")) - checkmate::expect_list(response_patient_body, any.missing = TRUE, null.ok = FALSE, len = 3, type = c("numeric", "numeric", "character")) + checkmate::expect_names( + names(response_patient_body), + identical.to = c("patient_id", "arm_id", "arm_name") + ) + checkmate::expect_list( + response_patient_body, + any.missing = TRUE, + null.ok = FALSE, + len = 3, type = c("numeric", "numeric", "character") + ) # Incorrect Study ID response_study <- - tryCatch({ - request(api_url) |> - req_url_path("study", response_body$study$id + 1, "patient") |> - req_method("POST") |> - req_body_json( - data = list(current_state = - tibble::tibble("sex" = c("female", "male"), - "weight" = c("61-80 kg", "81 kg or more"), - "arm" = c("placebo", ""))) + tryCatch( + { + request(api_url) |> + req_url_path("study", response_body$study$id + 1, "patient") |> + req_method("POST") |> + req_body_json( + data = list( + current_state = + tibble::tibble( + "sex" = c("female", "male"), + "weight" = c("61-80 kg", "81 kg or more"), + "arm" = c("placebo", "") + ) + ) ) |> - req_perform() - }, error = function(e) e) - - checkmate::expect_set_equal(response_study$status, 400, label = "HTTP status code") - - }) + req_perform() + }, + error = function(e) e + ) + checkmate::expect_set_equal( + response_study$status, 400, + label = "HTTP status code" + ) +}) diff --git a/tests/testthat/test-helpers.R b/tests/testthat/test-helpers.R new file mode 100644 index 0000000..271e501 --- /dev/null +++ b/tests/testthat/test-helpers.R @@ -0,0 +1,61 @@ +versioned_tables <- c( + "study", "arm", "stratum", "factor_constraint", + "numeric_constraint", "patient", "patient_stratum" +) +nonversioned_tables <- c() + +all_tables <- c( + versioned_tables, + nonversioned_tables, + versioned_tables |> paste0("_history") +) + +with_db_fixtures <- function(test_data_path, env = parent.frame()) { + pool <- get("db_connection_pool", envir = .GlobalEnv) + conn <- pool::localCheckout(pool) + + # load test data in yaml format + test_data <- yaml::read_yaml(test_data_path) + + # truncate tables before inserting data + truncate_tables(all_tables) + + for (table_name in names(test_data)) { + # get table data + table_data <- test_data[table_name] |> dplyr::bind_rows() + + DBI::dbWriteTable( + conn, + table_name, + table_data, + append = TRUE, + row.names = FALSE + ) + } + + withr::defer( + { + truncate_tables(all_tables) + }, + env + ) +} + +truncate_tables <- function(tables) { + pool <- get("db_connection_pool", envir = .GlobalEnv) + conn <- pool::localCheckout(pool) + DBI::dbExecute( + "SET client_min_messages TO WARNING;", + conn = conn + ) + tables |> + rev() |> + purrr::walk( + \(table_name) { + glue::glue_sql( + "TRUNCATE TABLE {`table_name`} RESTART IDENTITY CASCADE;", + .con = conn + ) |> DBI::dbExecute(conn = conn) + } + ) +} diff --git a/tests/testthat/test-randomize-minimisation-pocock.R b/tests/testthat/test-randomize-minimisation-pocock.R index c461fc6..7d98125 100644 --- a/tests/testthat/test-randomize-minimisation-pocock.R +++ b/tests/testthat/test-randomize-minimisation-pocock.R @@ -2,103 +2,165 @@ set.seed(seed = "345345") n_at_the_moment <- 10 arms <- c("control", "active low", "active high") sex <- sample(c("F", "M"), - n_at_the_moment + 1, - replace = TRUE, - prob = c(0.4, 0.6) + n_at_the_moment + 1, + replace = TRUE, + prob = c(0.4, 0.6) ) diabetes <- sample(c("diabetes", "no diabetes"), - n_at_the_moment + 1, - replace = TRUE, - prob = c(0.2, 0.8) + n_at_the_moment + 1, + replace = TRUE, + prob = c(0.2, 0.8) ) arm <- sample(arms, - n_at_the_moment, - replace = TRUE, - prob = c(0.4, 0.4, 0.2) + n_at_the_moment, + replace = TRUE, + prob = c(0.4, 0.4, 0.2) ) |> c("") covar_df <- tibble::tibble(sex, diabetes, arm) test_that("You can call function and it returns arm", { expect_subset( - randomize_minimisation_pocock(arms = arms, current_state = covar_df), choices = arms + randomize_minimisation_pocock(arms = arms, current_state = covar_df), + choices = arms ) }) test_that("Assertions work", { - expect_error(randomize_minimisation_pocock(arms = c(1, 2), current_state = covar_df), - regexp = "Must be of type 'character'") - expect_error(randomize_minimisation_pocock(arms = arms, current_state = covar_df, - method = "nonexistent"), - regexp = "Must be element of set .'range','var','sd'., but is 'nonexistent'") - expect_error(randomize_minimisation_pocock(arms = arms, current_state = "5 patietns OK"), - regexp = "Assertion on 'current_state' failed: Must be a tibble, not character") - expect_error(randomize_minimisation_pocock(arms = arms, current_state = covar_df[, 1:2]), - regexp = "Names must include the elements .'arm'.") + expect_error( + randomize_minimisation_pocock( + arms = c(1, 2), current_state = covar_df + ), + regexp = "Must be of type 'character'" + ) + expect_error( + randomize_minimisation_pocock( + arms = arms, current_state = covar_df, + method = "nonexistent" + ), + regexp = "Must be element of set .'range','var','sd'., but is 'nonexistent'" + ) + expect_error( + randomize_minimisation_pocock( + arms = arms, + current_state = "5 patietns OK" + ), + regexp = + "Assertion on 'current_state' failed: Must be a tibble, not character" + ) + expect_error( + randomize_minimisation_pocock( + arms = arms, + current_state = covar_df[, 1:2] + ), + regexp = "Names must include the elements .'arm'." + ) # Last subject already randomized - expect_error(randomize_minimisation_pocock(arms = arms, current_state = covar_df[1:3,]), - regexp = "must have at most 0 characters") - expect_error(randomize_minimisation_pocock(arms = c("foo", "bar"), - current_state = covar_df), - regexp = "Must be a subset of .'foo','bar',''.") - expect_error(randomize_minimisation_pocock(arms = arms, current_state = covar_df, - weights = c("sex" = -1, "diabetes" = 2)), - regexp = "Element 1 is not >= 0") - expect_error(randomize_minimisation_pocock(arms = arms, current_state = covar_df, - weights = c("wrong" = 1, "diabetes" = 2)), - regexp = "is missing elements .'sex'.") - expect_error(randomize_minimisation_pocock(arms = arms, current_state = covar_df, - ratio = c("control" = 1.5, - "active low" = 2, - "active high" = 1)), - regexp = "element 1 is not close to an integer") - expect_error(randomize_minimisation_pocock(arms = arms, current_state = covar_df, - ratio = c("control" = 1L, - "active high" = 1L)), - regexp = "Must have length 3, but has length 2") - expect_error(randomize_minimisation_pocock(arms = arms, current_state = covar_df, - p = 12), - regexp = "Assertion on 'p' failed: Element 1 is not <= 1") + expect_error( + randomize_minimisation_pocock(arms = arms, current_state = covar_df[1:3, ]), + regexp = "must have at most 0 characters" + ) + expect_error( + randomize_minimisation_pocock( + arms = c("foo", "bar"), + current_state = covar_df + ), + regexp = "Must be a subset of .'foo','bar',''." + ) + expect_error( + randomize_minimisation_pocock( + arms = arms, current_state = covar_df, + weights = c("sex" = -1, "diabetes" = 2) + ), + regexp = "Element 1 is not >= 0" + ) + expect_error( + randomize_minimisation_pocock( + arms = arms, current_state = covar_df, + weights = c("wrong" = 1, "diabetes" = 2) + ), + regexp = "is missing elements .'sex'." + ) + expect_error( + randomize_minimisation_pocock( + arms = arms, current_state = covar_df, + ratio = c( + "control" = 1.5, + "active low" = 2, + "active high" = 1 + ) + ), + regexp = "element 1 is not close to an integer" + ) + expect_error( + randomize_minimisation_pocock( + arms = arms, current_state = covar_df, + ratio = c( + "control" = 1L, + "active high" = 1L + ) + ), + regexp = "Must have length 3, but has length 2" + ) + expect_error( + randomize_minimisation_pocock( + arms = arms, current_state = covar_df, + p = 12 + ), + regexp = "Assertion on 'p' failed: Element 1 is not <= 1" + ) }) test_that("Function randomizes first patient randomly", { randomized <- sapply(1:100, function(x) { - randomize_minimisation_pocock(arms = arms, - current_state = covar_df[nrow(covar_df), ]) + randomize_minimisation_pocock( + arms = arms, + current_state = covar_df[nrow(covar_df), ] + ) }) - test <- prop.test(x = sum(randomized == "control"), - n = length(randomized), - p = 1/3, - conf.level = 0.95, - correct = FALSE) + test <- prop.test( + x = sum(randomized == "control"), + n = length(randomized), + p = 1 / 3, + conf.level = 0.95, + correct = FALSE + ) expect_gt(test$p.value, 0.05) }) test_that("Function randomizes second patient deterministically", { arms <- c("A", "B") - situation <- tibble::tibble(sex = c("F", "F"), - arm = c("A", "")) + situation <- tibble::tibble( + sex = c("F", "F"), + arm = c("A", "") + ) randomized <- - randomize_minimisation_pocock(arms = arms, - current_state = situation, - p = 1) + randomize_minimisation_pocock( + arms = arms, + current_state = situation, + p = 1 + ) expect_equal(randomized, "B") }) test_that("Setting proportion of randomness works", { arms <- c("A", "B") - situation <- tibble::tibble(sex = c("F", "F"), - arm = c("A", "")) + situation <- tibble::tibble( + sex = c("F", "F"), + arm = c("A", "") + ) randomized <- sapply(1:100, function(x) { - randomize_minimisation_pocock(arms = arms, - current_state = situation, - p = 0.60) + randomize_minimisation_pocock( + arms = arms, + current_state = situation, + p = 0.60 + ) }) # 60% to minimization arm (B) 40% to other arm (in this case A) diff --git a/tests/testthat/test-randomize-simple.R b/tests/testthat/test-randomize-simple.R index 51f2486..c8d3819 100644 --- a/tests/testthat/test-randomize-simple.R +++ b/tests/testthat/test-randomize-simple.R @@ -1,7 +1,9 @@ test_that("returns a single string", { expect_vector( - randomize_simple(c("active", "placebo"), - c("active" = 2L, "placebo" = 1L)), + randomize_simple( + c("active", "placebo"), + c("active" = 2L, "placebo" = 1L) + ), ptype = character(), size = 1 ) @@ -28,8 +30,10 @@ test_that("incorrect parameters raise an exception", { # Incorrect ratio type expect_error(randomize_simple(c("roof", "basement"), c("high", "low"))) # Lengths not matching - expect_error(randomize_simple(c("Paris", "Barcelona"), - c("Paris" = 1L, "Barcelona" = 2L, "Warsaw" = 1L))) + expect_error(randomize_simple( + c("Paris", "Barcelona"), + c("Paris" = 1L, "Barcelona" = 2L, "Warsaw" = 1L) + )) # Missing value expect_error(randomize_simple(c("yen", NA))) # Empty arm name @@ -41,26 +45,32 @@ test_that("incorrect parameters raise an exception", { test_that("proportions are kept (allocation 1:1)", { randomizations <- sapply(1:1000, function(x) randomize_simple(c("armA", "armB"))) - x <- prop.test(x = sum(randomizations == "armA"), - n = length(randomizations), - p = 0.5, - conf.level = 0.95, - correct = FALSE) + x <- prop.test( + x = sum(randomizations == "armA"), + n = length(randomizations), + p = 0.5, + conf.level = 0.95, + correct = FALSE + ) # precision 0.01 expect_gt(x$p.value, 0.01) }) -test_that("proportions are kept (allocation 2:1), even if ratio is in reverse", { - function_result <- sapply(1:1000, function(x) { - randomize_simple(c("armA", "armB"), c("armB" = 1L,"armA" = 2L)) - } +test_that( + "proportions are kept (allocation 2:1), even if ratio is in reverse", + { + function_result <- sapply(1:1000, function(x) { + randomize_simple(c("armA", "armB"), c("armB" = 1L, "armA" = 2L)) + }) + x <- prop.test( + x = sum(function_result == "armA"), + n = length(function_result), + p = 2 / 3, + conf.level = 0.95, + correct = FALSE ) - x <- prop.test(x = sum(function_result == "armA"), - n = length(function_result), - p = 2/3, - conf.level = 0.95, - correct = FALSE) - # precision 0.01 - expect_gt(x$p.value, 0.01) -}) + # precision 0.01 + expect_gt(x$p.value, 0.01) + } +)