diff --git a/DESCRIPTION b/DESCRIPTION index 68c25cb..09accd3 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: vmxr Title: VeloMetrix R Client -Version: 0.1.1.9000 +Version: 0.2.0 Authors@R: c( person(given = "Eric", family = "Novik", email = "eric@generable.com", role = c("aut", "cre")), person(given = "Juho", family = "Timonen", role = "ctb"), diff --git a/NAMESPACE b/NAMESPACE index 8aae9d3..be39484 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -6,6 +6,7 @@ S3method(print,vmx_model_data) S3method(print,vmx_resource) S3method(vmx_wait,default) S3method(vmx_wait,vmx_dataset) +S3method(vmx_wait,vmx_dosing_input) S3method(vmx_wait,vmx_model_build_run) S3method(vmx_wait,vmx_nca_analysis) S3method(vmx_wait,vmx_prep_status) @@ -26,6 +27,7 @@ export(vmx_dataset_download) export(vmx_dataset_files) export(vmx_dataset_tags) export(vmx_datasets) +export(vmx_dosing) export(vmx_dosing_input) export(vmx_dosing_input_status) export(vmx_fit_global_estimates) diff --git a/NEWS.md b/NEWS.md index 1232288..8c6baf5 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,37 @@ -# vmxr 0.1.1.9000 (development) +# vmxr 0.2.0 + +* Collection functions continue to return all matching rows. Cursor pages are + followed automatically with strict envelope validation and repeated-cursor + detection, so malformed pagination fails instead of truncating results or + looping forever. +* Estimate helpers now preserve the server-selected point statistic, interval + kind, interval level, and additive tagged metadata. They no longer hardcode + posterior/credible semantics or silently pad malformed parallel arrays. + Observed-vs-predicted helpers consume the current `Estimate` envelope and + retain PK/PD units and marker identity. +* Successful responses are checked for required IDs, array alignment, page + consistency, declared table types, and other contract-critical shape + invariants. Malformed success payloads raise `vmx_response_error` rather than + being silently recycled, truncated, or attached to the wrong resource. +* PK-only modeling previews now send `pd_markers = []`, matching PK-only model + build submission. Simulation inputs validate canonical `simdose_` IDs and + subject records, and dosing inputs can be passed to `vmx_wait()`. +* `vmx_dosing()` exposes the separate dosing-event domain, and + `vmx_model_data()` includes `$dosing` while validating required table + availability metadata. +* Polling stops immediately on any terminal state, surfaces safe server failure + copy, rejects unknown statuses and invalid controls, and uses resource-specific + long-running defaults. NCA, simulation, dosing-input, and model-build defaults + include a persistence cushion beyond their worker execution ceilings. +* Nullable update fields can be explicitly cleared without allowing `NULL` for + required fields. OIDC caches now reject structurally invalid tokens and fail + loudly if secure atomic replacement does not succeed. +* Prep-question tibbles now retain defaults, grouping, resolution hints, + referents, rationales, and data previews. Prep answers support idempotency + keys, data-version exports require the canonical matching envelope, and + create helpers reject malformed upload compositions, retry identifiers, + simulation bounds, and ambiguous scalar inputs before dispatch. +* Study listing now exposes the API's `created_since` filter. * `vmx_login()` device-code prompt now matches the actual flow (GEN-2378). Because the browser is opened at `verification_uri_complete` (the URL that diff --git a/R/client.R b/R/client.R index c99e40f..a69bdc7 100644 --- a/R/client.R +++ b/R/client.R @@ -30,15 +30,24 @@ #' @return An object of class `vmx_client`. #' @export vmx_client <- function(base_url = NULL, token = NULL, ...) { - base_url <- trimws(base_url %||% Sys.getenv("VMX_API_BASE_URL", unset = "")) - token <- trimws(token %||% Sys.getenv("VMX_API_TOKEN", unset = "")) + base_url <- base_url %||% Sys.getenv("VMX_API_BASE_URL", unset = "") + token <- token %||% Sys.getenv("VMX_API_TOKEN", unset = "") - if (!nzchar(base_url)) { + if (!is.character(base_url) || length(base_url) != 1L || + is.na(base_url) || !nzchar(trimws(base_url))) { vmx_abort( - "No API base URL. Set `base_url=` or the VMX_API_BASE_URL env var.", + "Set `base_url=` or VMX_API_BASE_URL to one non-empty URL.", class = "vmx_usage_error" ) } + if (!is.character(token) || length(token) != 1L || is.na(token)) { + vmx_abort( + "`token` / VMX_API_TOKEN must be one string.", + class = "vmx_usage_error" + ) + } + base_url <- trimws(base_url) + token <- trimws(token) # Resolve the bearer token via a *provider closure* re-invoked on every request # (see vmx_req), not a single string baked in here. A frozen OIDC access token # expires a few minutes into a persistent `con` and every later call then 401s diff --git a/R/data_versions.R b/R/data_versions.R index cca31ce..daba3fa 100644 --- a/R/data_versions.R +++ b/R/data_versions.R @@ -6,7 +6,7 @@ #' @param include_archived Include archived versions. #' @param eligible_for_modeling Optional modeling-eligibility filter. #' @param client A `vmx_client`. -#' @return A tibble. +#' @return A tibble containing all matching data versions. #' @export vmx_data_versions <- function(treatment = NULL, study = NULL, include_archived = FALSE, @@ -18,7 +18,7 @@ vmx_data_versions <- function(treatment = NULL, study = NULL, include_archived = include_archived, eligible_for_modeling = eligible_for_modeling ) - vmx_items_to_tibble(vmx_paginate(client, "/data-versions", params)) + vmx_paginate(client, "/data-versions", params) } #' Fetch one data version @@ -27,7 +27,11 @@ vmx_data_versions <- function(treatment = NULL, study = NULL, #' @return A `vmx_data_version`. #' @export vmx_data_version <- function(id, client = vmx_client()) { - data <- vmx_get(client, paste0("/data-versions/", vmx_id(id, "dv"))) + data_version_id <- vmx_id(id, "dv") + data <- vmx_get(client, paste0("/data-versions/", data_version_id)) + vmx_validate_response_id( + data, "data_version_id", data_version_id, "data version" + ) new_vmx_resource(data, "vmx_data_version", "data_version_id") } @@ -46,12 +50,29 @@ vmx_data_version <- function(id, client = vmx_client()) { #' @export vmx_data_version_create <- function(dataset, uploads, prior_config = NULL, client = vmx_client()) { + dataset_id <- vmx_id(dataset, "ds", "dataset") + uploads <- vmx_nonempty_strings( + uploads, "uploads", unique = TRUE + ) + upload_ids <- vapply( + uploads, + vmx_id, + character(1), + prefix = "upl", + arg = "uploads" + ) |> unname() body <- vmx_compact(list( - upload_ids = as.list(uploads), + upload_ids = as.list(upload_ids), prior_config_data_version_id = vmx_opt_id(prior_config, "dv", "prior_config") )) - data <- vmx_post(client, paste0("/datasets/", vmx_id(dataset, "ds", "dataset"), - "/data-versions"), body) + data <- vmx_post( + client, + paste0("/datasets/", dataset_id, "/data-versions"), + body + ) + vmx_validate_response_id( + data, "dataset_id", dataset_id, "data-version creation" + ) new_vmx_resource(data, "vmx_prep_status", "dataset_id") } @@ -71,7 +92,21 @@ vmx_data_version_create <- function(dataset, uploads, prior_config = NULL, vmx_data_version_table <- function(dv, domain = c("subjects", "pk", "dosing", "pd", "labs", "covariates"), client = vmx_client()) { domain <- match.arg(domain) - tbl <- vmx_get(client, paste0("/data-versions/", vmx_id(dv, "dv"), "/tables/", domain)) + dv_id <- vmx_id(dv, "dv") + tbl <- vmx_get(client, paste0("/data-versions/", dv_id, "/tables/", domain)) + vmx_validate_response_id(tbl, "data_version_id", dv_id, "data-version table") + returned_domain <- vmx_response_scalar( + vmx_response_field(tbl, "domain", "data-version table.domain"), + "data-version table.domain", + type = "character", + nonempty = TRUE + ) + if (!identical(returned_domain, domain)) { + vmx_abort_response( + "data-version table field 'domain' does not match the requested domain.", + field = "domain" + ) + } vmx_dvtable_to_tibble(tbl) } @@ -87,18 +122,46 @@ vmx_data_version_table <- function(dv, domain = c("subjects", "pk", "dosing", "p #' @return The export envelope (list), or, when `dest` is set, `dest` invisibly. #' @export vmx_data_version_export <- function(dv, dest = NULL, client = vmx_client()) { - envelope <- vmx_get(client, paste0("/data-versions/", vmx_id(dv, "dv"), "/export")) + data_version_id <- vmx_id(dv, "dv") + envelope <- vmx_get( + client, paste0("/data-versions/", data_version_id, "/export") + ) + vmx_validate_response_id( + envelope, "data_version_id", data_version_id, "data-version export" + ) + url <- vmx_response_scalar( + vmx_response_field( + envelope, "download_url", "data-version export.download_url" + ), + "data-version export.download_url", + type = "character", + nonempty = TRUE + ) if (is.null(dest)) { return(envelope) } - url <- envelope$download_url %||% envelope$url - if (is.null(url)) { - vmx_abort("Export envelope did not contain a download URL.", class = "vmx_api_error") + if (!is.character(dest) || length(dest) != 1L || is.na(dest) || + !nzchar(trimws(dest))) { + vmx_abort( + "`dest` must be one non-empty file path.", + class = "vmx_usage_error" + ) } # Anonymous request: the signed URL carries its own credentials; sending the # API bearer to GCS would leak the token and is rejected anyway. - httr2::request(url) |> - httr2::req_perform(path = dest) + tryCatch( + httr2::request(url) |> + httr2::req_perform(path = dest), + error = function(e) { + # Do not attach the transport condition: it may contain the signed URL + # (and therefore its temporary credentials). + vmx_abort( + "Data-version export download failed.", + class = "vmx_api_error", + reason = "export_download_failed" + ) + } + ) invisible(dest) } @@ -125,7 +188,13 @@ vmx_data_version_unarchive <- function(dv, client = vmx_client()) { #' @noRd vmx_set_dv_archive <- function(dv, archived, reason, client) { body <- vmx_compact(list(archived = archived, reason = reason)) - data <- vmx_patch(client, paste0("/data-versions/", vmx_id(dv, "dv"), "/archive"), body) + data_version_id <- vmx_id(dv, "dv") + data <- vmx_patch( + client, paste0("/data-versions/", data_version_id, "/archive"), body + ) + vmx_validate_response_id( + data, "data_version_id", data_version_id, "data-version archive update" + ) new_vmx_resource(data, "vmx_data_version", "data_version_id") } @@ -140,7 +209,7 @@ vmx_subjects <- function(dv, client = vmx_client()) { vmx_data_version_table(dv, "subjects", client = client) } -#' PK observations + events table +#' PK observations table #' @param dv A data-version id or `vmx_data_version`. #' @param client A `vmx_client`. #' @return A tibble. @@ -149,6 +218,15 @@ vmx_pk <- function(dv, client = vmx_client()) { vmx_data_version_table(dv, "pk", client = client) } +#' Dosing events table +#' @param dv A data-version id or `vmx_data_version`. +#' @param client A `vmx_client`. +#' @return A tibble. +#' @export +vmx_dosing <- function(dv, client = vmx_client()) { + vmx_data_version_table(dv, "dosing", client = client) +} + #' PD observations table #' @param dv A data-version id or `vmx_data_version`. #' @param client A `vmx_client`. @@ -160,11 +238,11 @@ vmx_pd <- function(dv, client = vmx_client()) { #' Fetch model-ready tidy tables for a data version #' -#' Returns a `vmx_model_data` bundle with `$subjects`, `$pk`, `$pd` (each a -#' tibble, or `NULL` when the DataVersion has no such prepared table), and -#' `$meta` (units, time bases, PD-marker manifest, subject count) read from the -#' DataVersion. Only domains flagged in the DV's `table_availability` are -#' fetched, so absent optional tables don't 404. +#' Returns a `vmx_model_data` bundle with `$subjects`, `$pk`, `$dosing`, and +#' `$pd` (each a tibble, or `NULL` when the DataVersion has no such prepared +#' table), and `$meta` (units, time bases, PD-marker manifest, subject count) +#' read from the DataVersion. Only domains flagged in the DV's +#' `table_availability` are fetched, so absent optional tables don't 404. #' #' @param dv A data-version id or `vmx_data_version`. #' @param client A `vmx_client`. @@ -172,7 +250,7 @@ vmx_pd <- function(dv, client = vmx_client()) { #' @export vmx_model_data <- function(dv, client = vmx_client()) { dv_obj <- if (inherits(dv, "vmx_data_version")) dv else vmx_data_version(vmx_id(dv, "dv"), client = client) - avail <- dv_obj$table_availability %||% list() + avail <- vmx_table_availability(dv_obj) fetch <- function(domain) { if (isTRUE(avail[[domain]])) vmx_data_version_table(dv_obj, domain, client = client) else NULL } @@ -180,6 +258,7 @@ vmx_model_data <- function(dv, client = vmx_client()) { list( subjects = fetch("subjects"), pk = fetch("pk"), + dosing = fetch("dosing"), pd = fetch("pd"), meta = list( data_version_id = dv_obj$data_version_id, @@ -195,6 +274,29 @@ vmx_model_data <- function(dv, client = vmx_client()) { ) } +vmx_table_availability <- function(dv) { + avail <- vmx_response_field( + dv, "table_availability", "data version.table_availability" + ) + required <- c("subjects", "pk", "dosing", "pd", "labs", "covariates") + if (!is.list(avail) || is.null(names(avail)) || + any(!nzchar(names(avail))) || anyDuplicated(names(avail)) || + !all(required %in% names(avail))) { + vmx_abort_response( + "field 'data version.table_availability' is missing required domains.", + field = "table_availability" + ) + } + for (domain in names(avail)) { + vmx_response_scalar( + avail[[domain]], + paste0("data version.table_availability.", domain), + type = "logical" + ) + } + avail +} + #' @export print.vmx_model_data <- function(x, ...) { cli::cli_text("{.cls } {x$meta$data_version_id %||% ''}") @@ -202,6 +304,7 @@ print.vmx_model_data <- function(x, ...) { cli::cli_bullets(c( "*" = "subjects: {dims(x$subjects)}", "*" = "pk: {dims(x$pk)}", + "*" = "dosing: {dims(x$dosing)}", "*" = "pd: {dims(x$pd)}" )) invisible(x) diff --git a/R/datasets.R b/R/datasets.R index 7843f90..0f55cb8 100644 --- a/R/datasets.R +++ b/R/datasets.R @@ -12,14 +12,19 @@ #' @param treatment Optional treatment; inferred from `study` when possible. #' @param config Optional gecodata v2 `project.yaml` path (warm-start). #' @param wait If `TRUE`, block until prep settles. +#' @param ... Polling controls forwarded to [vmx_wait()] when `wait = TRUE`. #' @param client A `vmx_client`. #' @return A `vmx_dataset` (status `"uploaded"`). #' @export vmx_upload <- function(study, files, mode = c("initial", "incremental", "replacement"), treatment = NULL, config = NULL, wait = FALSE, - client = vmx_client()) { + client = vmx_client(), ...) { mode <- match.arg(mode) + files <- vmx_nonempty_strings(files, "files", unique = TRUE) + if (!is.null(config)) { + config <- vmx_nonempty_strings(config, "config", exactly_one = TRUE) + } std_id <- vmx_id(study, "std", arg = "study") tmt_id <- if (!is.null(treatment)) { vmx_id(treatment, "tmt", arg = "treatment") @@ -27,10 +32,20 @@ vmx_upload <- function(study, files, vmx_study_treatment_id(study, client) } - missing <- files[!file.exists(files)] - if (length(missing)) { + invalid_files <- files[ + !file.exists(files) | + vapply( + files, + function(path) isTRUE(file.info(path)$isdir), + logical(1) + ) + ] + if (length(invalid_files)) { vmx_abort( - sprintf("File(s) not found: %s", paste(missing, collapse = ", ")), + sprintf( + "Upload path(s) must be existing files: %s", + paste(invalid_files, collapse = ", ") + ), class = "vmx_usage_error" ) } @@ -53,9 +68,12 @@ vmx_upload <- function(study, files, req <- httr2::req_method(vmx_req(client, "/datasets"), "POST") |> httr2::req_body_multipart(!!!parts, !!!file_parts) - ds <- new_vmx_resource(vmx_perform(req), "vmx_dataset", "dataset_id") + data <- vmx_perform(req) + vmx_validate_response_id(data, "study_id", std_id, "dataset upload") + vmx_validate_response_id(data, "treatment_id", tmt_id, "dataset upload") + ds <- new_vmx_resource(data, "vmx_dataset", "dataset_id") - if (isTRUE(wait)) vmx_wait(ds, client = client) else ds + if (isTRUE(wait)) vmx_wait(ds, client = client, ...) else ds } #' Resolve the treatment id that owns a study @@ -66,31 +84,30 @@ vmx_upload <- function(study, files, #' @noRd vmx_study_treatment_id <- function(study, client) { if (inherits(study, "vmx_resource") && !is.null(study[["treatment_id"]])) { - return(study[["treatment_id"]]) + return(vmx_id(study[["treatment_id"]], "tmt", "study$treatment_id")) } std_id <- vmx_id(study, "std", arg = "study") - tmt_id <- vmx_get(client, paste0("/studies/", std_id))[["treatment_id"]] - if (is.null(tmt_id)) { - vmx_abort( - sprintf("Could not resolve the treatment for study '%s'; pass `treatment=`.", std_id), - class = "vmx_usage_error" - ) - } - tmt_id + response <- vmx_get(client, paste0("/studies/", std_id)) + vmx_validate_response_id(response, "study_id", std_id, "study") + vmx_id( + vmx_response_field(response, "treatment_id", "study.treatment_id"), + "tmt", + "study$treatment_id" + ) } #' List datasets #' @param study Optional study filter. #' @param treatment Optional treatment filter. #' @param client A `vmx_client`. -#' @return A tibble. +#' @return A tibble containing all matching datasets. #' @export vmx_datasets <- function(study = NULL, treatment = NULL, client = vmx_client()) { params <- list( study_id = vmx_opt_id(study, "std", "study"), treatment_id = vmx_opt_id(treatment, "tmt", "treatment") ) - vmx_items_to_tibble(vmx_paginate(client, "/datasets", params)) + vmx_paginate(client, "/datasets", params) } #' Fetch one dataset @@ -99,18 +116,20 @@ vmx_datasets <- function(study = NULL, treatment = NULL, client = vmx_client()) #' @return A `vmx_dataset`. #' @export vmx_dataset <- function(id, client = vmx_client()) { - data <- vmx_get(client, paste0("/datasets/", vmx_id(id, "ds"))) + dataset_id <- vmx_id(id, "ds") + data <- vmx_get(client, paste0("/datasets/", dataset_id)) + vmx_validate_response_id(data, "dataset_id", dataset_id, "dataset") new_vmx_resource(data, "vmx_dataset", "dataset_id") } #' List the files in a dataset #' @param dataset A dataset id or `vmx_dataset`. #' @param client A `vmx_client`. -#' @return A tibble. +#' @return A tibble containing all files in the dataset. #' @export vmx_dataset_files <- function(dataset, client = vmx_client()) { id <- vmx_id(dataset, "ds", arg = "dataset") - vmx_items_to_tibble(vmx_paginate(client, paste0("/datasets/", id, "/files"))) + vmx_paginate(client, paste0("/datasets/", id, "/files")) } #' The tags on a dataset @@ -132,7 +151,21 @@ vmx_dataset_tags <- function(dataset, client = vmx_client()) { if (is.null(tags) || !length(tags)) { return(tibble::tibble(key = character(0), value = character(0))) } - tibble::tibble(key = names(tags), value = vmx_chr(unname(tags))) + if (!is.list(tags) || is.null(names(tags)) || + any(!nzchar(names(tags))) || anyDuplicated(names(tags))) { + vmx_abort_response( + "field 'dataset.tags' must be an object.", + field = "tags" + ) + } + values <- vapply(seq_along(tags), function(i) { + vmx_response_scalar( + tags[[i]], + paste0("dataset.tags.", names(tags)[[i]]), + type = "character" + ) + }, character(1)) + tibble::tibble(key = names(tags), value = values) } #' Cancel a dataset's in-flight format job @@ -145,7 +178,11 @@ vmx_dataset_tags <- function(dataset, client = vmx_client()) { #' @return The updated `vmx_prep_status`. #' @export vmx_dataset_cancel <- function(dataset, client = vmx_client()) { - data <- vmx_post(client, paste0("/datasets/", vmx_id(dataset, "ds", arg = "dataset"), "/cancel")) + dataset_id <- vmx_id(dataset, "ds", arg = "dataset") + data <- vmx_post(client, paste0("/datasets/", dataset_id, "/cancel")) + vmx_validate_response_id( + data, "dataset_id", dataset_id, "dataset cancellation" + ) new_vmx_resource(data, "vmx_prep_status", "dataset_id") } @@ -191,11 +228,15 @@ vmx_upload_unignore <- function(dataset, upload, client = vmx_client()) { #' @noRd vmx_set_upload_ignored <- function(dataset, upload, ignored, client) { endpoint <- if (ignored) "ignore-upload" else "unignore-upload" - upload_id <- if (inherits(upload, "vmx_resource")) vmx_resource_id(upload) else upload + upload_id <- vmx_id(upload, "upl", "upload") + dataset_id <- vmx_id(dataset, "ds", arg = "dataset") data <- vmx_post( client, - paste0("/datasets/", vmx_id(dataset, "ds", arg = "dataset"), "/", endpoint), + paste0("/datasets/", dataset_id, "/", endpoint), list(upload_id = upload_id) ) + vmx_validate_response_id( + data, "dataset_id", dataset_id, "dataset upload update" + ) new_vmx_resource(data, "vmx_prep_status", "dataset_id") } diff --git a/R/errors.R b/R/errors.R index 2bf3ff6..5c718f9 100644 --- a/R/errors.R +++ b/R/errors.R @@ -4,6 +4,7 @@ # vmx_error (parent) # |- vmx_auth_error 401 / unauthenticated # |- vmx_api_error 4xx/5xx with server `reason` + body +# |- vmx_response_error malformed successful API response # |- vmx_timeout_error vmx_wait() exceeded its timeout # |- vmx_usage_error client-side validation (e.g. bad id prefix) @@ -29,6 +30,21 @@ vmx_abort <- function(message, class = character(), ..., call = rlang::caller_en ) } +# Raise when a successful response violates the public API contract. Messages +# name only the response field and expected shape; they never include payload +# values, which may contain sensitive study data. +vmx_abort_response <- function(message, field = NULL, data = NULL, + call = rlang::caller_env()) { + vmx_abort( + paste0("Invalid response from the VeloMetrix API: ", message), + class = "vmx_response_error", + reason = "invalid_response", + field = field, + data = data, + call = call + ) +} + # Convenience stub used by not-yet-implemented public verbs. vmx_abort_unimplemented <- function(what = NULL, call = rlang::caller_env()) { what <- what %||% "This function" diff --git a/R/http.R b/R/http.R index 0b7aee1..86b6cf0 100644 --- a/R/http.R +++ b/R/http.R @@ -8,7 +8,7 @@ #' Build a base request for a client #' #' Attaches the `/api/v1` prefix, bearer auth, and a user agent. HTTP error -#' status is handled by [vmx_perform()] (not httr2's default), so the request +#' status is handled by `vmx_perform()` (not httr2's default), so the request #' is configured not to raise on 4xx/5xx. #' #' @param client A `vmx_client`. @@ -122,26 +122,53 @@ vmx_patch <- function(client, path, body = NULL) { vmx_perform(req) } -#' Follow `next_cursor` pagination, returning all items as a flat list +#' Fetch and combine every page of a cursor-paginated collection #' -#' @param limit Optional cap on the total number of items returned. +#' Cursors remain opaque: this helper only sends each server-provided +#' `next_cursor` back to the same endpoint with the same filters. Every page is +#' validated before its rows are combined. Repeated cursors fail loudly instead +#' of looping forever. +#' +#' @param validate_page Optional callback for endpoint-specific page checks. #' @keywords internal #' @noRd -vmx_paginate <- function(client, path, params = list(), limit = NULL) { +vmx_paginate <- function(client, path, params = list(), validate_page = NULL) { query <- vmx_compact(params) - items <- list() + pages <- list() + metadata <- NULL + metadata_set <- FALSE + seen_cursors <- character() + repeat { - page <- vmx_get(client, path, query) - items <- c(items, page$items %||% list()) - if (!is.null(limit) && length(items) >= limit) { - items <- items[seq_len(limit)] - break + raw_page <- vmx_get(client, path, query) + if (!is.null(validate_page)) { + validate_page(raw_page) + } + page <- vmx_page_to_tibble(raw_page, context = path) + if (!metadata_set) { + metadata <- attr(page, "vmx_metadata", exact = TRUE) + metadata_set <- TRUE + } + + cursor <- attr(page, "next_cursor", exact = TRUE) + attr(page, "next_cursor") <- NULL + attr(page, "has_next_page") <- NULL + attr(page, "vmx_metadata") <- NULL + pages[[length(pages) + 1L]] <- page + if (is.null(cursor)) break + if (cursor %in% seen_cursors) { + vmx_abort_response( + sprintf("%s returned a repeated pagination cursor.", path), + field = "next_cursor" + ) } - cursor <- page$next_cursor - if (!is.character(cursor) || length(cursor) != 1L || !nzchar(cursor)) break + seen_cursors <- c(seen_cursors, cursor) query$cursor <- cursor } - items + + out <- vctrs::vec_rbind(!!!pages) + attr(out, "vmx_metadata") <- metadata + out } #' Drop NULL-valued elements of a list @@ -150,3 +177,15 @@ vmx_paginate <- function(client, path, params = list(), limit = NULL) { vmx_compact <- function(x) { x[!vapply(x, is.null, logical(1))] } + +# Validate an opaque cursor or similar non-blank scalar without interpreting it. +vmx_id_like_scalar <- function(x, arg) { + if (!is.character(x) || length(x) != 1L || is.na(x) || + !nzchar(trimws(x))) { + vmx_abort( + sprintf("`%s` must be one non-empty string.", arg), + class = "vmx_usage_error" + ) + } + invisible(x) +} diff --git a/R/modeling.R b/R/modeling.R index ff41a01..b872c80 100644 --- a/R/modeling.R +++ b/R/modeling.R @@ -12,9 +12,31 @@ vmx_model_catalog <- function(data_version = NULL, client = vmx_client()) { catalog <- vmx_get(client, "/model-catalog", list(data_version_id = vmx_opt_id(data_version, "dv", "data_version"))) + if (!is.list(catalog) || + (length(catalog) && + (is.null(names(catalog)) || any(!nzchar(names(catalog))) || + anyDuplicated(names(catalog))))) { + vmx_abort_response( + "model catalog must be an object keyed by category.", + field = "model_catalog" + ) + } rows <- list() for (category in names(catalog)) { - for (model in catalog[[category]]) { + models <- catalog[[category]] + if (!is.list(models) || !is.null(names(models))) { + vmx_abort_response( + "each model catalog category must contain an array of models.", + field = category + ) + } + for (model in models) { + if (is.list(model) && "category" %in% names(model)) { + vmx_abort_response( + "model catalog entry conflicts with the client category column.", + field = "category" + ) + } row <- vmx_flatten_row(model) row$category <- category rows[[length(rows) + 1L]] <- row @@ -30,27 +52,68 @@ vmx_model_catalog <- function(data_version = NULL, client = vmx_client()) { #' @return A named list. #' @export vmx_model_describe <- function(model_name, client = vmx_client()) { - vmx_post(client, "/model-catalog/model-description", - list(model_catalog_name = model_name)) + model_name <- vmx_nonempty_strings( + model_name, "model_name", exactly_one = TRUE + ) + out <- vmx_post( + client, "/model-catalog/model-description", + list(model_catalog_name = model_name) + ) + if (!is.list(out) || is.null(names(out)) || any(!nzchar(names(out))) || + anyDuplicated(names(out))) { + vmx_abort_response( + "model description must be an object of text fields.", + field = "model_description" + ) + } + for (field in names(out)) { + vmx_response_scalar( + out[[field]], + paste0("model description.", field), + type = "character" + ) + } + out } #' Preview modeling options for a data version #' @param data_version A data-version id or `vmx_data_version`. #' @param time_basis Time basis. -#' @param pd_marker Optional PD marker gen_uuid(s) (character vector). +#' @param pd_marker PD marker gen_uuid(s). `NULL` or `character(0)` explicitly +#' previews a PK-only build; pass marker UUIDs to preview PD modeling. #' @param covariate Optional covariate name(s). #' @param client A `vmx_client`. #' @return A list (the selection preview). #' @export vmx_modeling_options <- function(data_version, time_basis, pd_marker = NULL, covariate = NULL, client = vmx_client()) { - body <- vmx_compact(list( + time_basis <- vmx_nonempty_strings( + time_basis, "time_basis", exactly_one = TRUE + ) + markers <- pd_marker %||% character(0) + if (!is.character(markers) || anyNA(markers) || + any(!nzchar(trimws(markers))) || anyDuplicated(markers)) { + vmx_abort("`pd_marker` must contain non-empty marker UUID strings.", + class = "vmx_usage_error") + } + covariates <- if (is.null(covariate)) { + NULL + } else { + vmx_nonempty_strings(covariate, "covariate", unique = TRUE) + } + body <- list( data_version_id = vmx_id(data_version, "dv", "data_version"), time_basis = time_basis, - pd_markers = if (!is.null(pd_marker)) as.list(pd_marker), - covariates = if (!is.null(covariate)) as.list(covariate) - )) - vmx_post(client, "/modeling-options", body) + # The API defines null/omitted as "all markers". Send [] deliberately so + # the default preflight matches vmx_model_build()'s PK-only default. + pd_markers = as.list(markers) + ) + if (!is.null(covariates)) body$covariates <- as.list(covariates) + out <- vmx_post(client, "/modeling-options", body) + vmx_validate_response_id( + out, "data_version_id", body$data_version_id, "modeling options" + ) + out } #' Start a model build run (optionally wait) @@ -60,7 +123,8 @@ vmx_modeling_options <- function(data_version, time_basis, pd_marker = NULL, #' #' @param data_version A data-version id or `vmx_data_version`. #' @param time_basis Time basis. -#' @param pd_marker Optional `"GEN_uuid:increasing"` / `":decreasing"` string(s). +#' @param pd_marker Optional `"GEN_uuid:increasing"` / `":decreasing"` +#' string(s). `NULL` or `character(0)` requests a PK-only build. #' @param covariate Optional covariate name(s). #' @param idempotency_key Optional idempotency key. #' @param retried_from Optional prior run to retry from. @@ -74,27 +138,49 @@ vmx_model_build <- function(data_version, time_basis, pd_marker = NULL, covariate = NULL, idempotency_key = NULL, retried_from = NULL, wait = FALSE, ..., client = vmx_client()) { + time_basis <- vmx_nonempty_strings( + time_basis, "time_basis", exactly_one = TRUE + ) + covariates <- if (is.null(covariate)) { + character(0) + } else { + vmx_nonempty_strings(covariate, "covariate", unique = TRUE) + } body <- list( data_version_id = vmx_id(data_version, "dv", "data_version"), time_basis = time_basis, - covariates = if (is.null(covariate)) list() else as.list(covariate) + covariates = as.list(covariates) ) pdm <- vmx_pd_markers(pd_marker) - if (!is.null(pdm)) body$pd_markers <- pdm - if (!is.null(idempotency_key)) body$idempotency_key <- idempotency_key - if (!is.null(retried_from)) body$retried_from <- retried_from + body$pd_markers <- pdm + if (!is.null(idempotency_key)) { + vmx_id_like_scalar(idempotency_key, "idempotency_key") + body$idempotency_key <- idempotency_key + } + if (!is.null(retried_from)) { + body$retried_from <- vmx_id(retried_from, "run", "retried_from") + } - run <- new_vmx_resource(vmx_post(client, "/model-build-runs", body), - "vmx_model_build_run", "run_id") + data <- vmx_post(client, "/model-build-runs", body) + vmx_validate_response_id( + data, "data_version_id", body$data_version_id, "model-build creation" + ) + run <- new_vmx_resource( + data, "vmx_model_build_run", "run_id" + ) if (isTRUE(wait)) vmx_wait(run, client = client, ...) else run } # Parse "GEN_uuid:direction" shorthand into the API's marker objects. vmx_pd_markers <- function(x) { - if (is.null(x)) return(NULL) - lapply(x, function(s) { + if (is.null(x)) return(list()) + if (!is.character(x) || anyNA(x) || any(!nzchar(trimws(x)))) { + vmx_abort("`pd_marker` must be a character vector.", class = "vmx_usage_error") + } + out <- lapply(x, function(s) { parts <- strsplit(s, ":", fixed = TRUE)[[1]] - if (length(parts) != 2L || !parts[[2]] %in% c("increasing", "decreasing")) { + if (length(parts) != 2L || !nzchar(parts[[1]]) || + !parts[[2]] %in% c("increasing", "decreasing")) { vmx_abort( sprintf("pd_marker '%s' must be 'GEN_uuid:increasing' or 'GEN_uuid:decreasing'.", s), class = "vmx_usage_error" @@ -102,12 +188,18 @@ vmx_pd_markers <- function(x) { } list(gen_uuid = parts[[1]], direction = parts[[2]]) }) + ids <- vapply(out, `[[`, character(1), "gen_uuid") + if (anyDuplicated(ids)) { + vmx_abort("`pd_marker` contains a duplicate marker UUID.", + class = "vmx_usage_error") + } + out } #' List model build runs #' @param data_version,study,treatment,status Optional filters. #' @param client A `vmx_client`. -#' @return A tibble. +#' @return A tibble containing all matching model-build runs. #' @export vmx_model_build_runs <- function(data_version = NULL, study = NULL, treatment = NULL, status = NULL, @@ -118,7 +210,7 @@ vmx_model_build_runs <- function(data_version = NULL, study = NULL, treatment_id = vmx_opt_id(treatment, "tmt", "treatment"), status = status ) - vmx_items_to_tibble(vmx_paginate(client, "/model-build-runs", params)) + vmx_paginate(client, "/model-build-runs", params) } #' Build-run status @@ -127,17 +219,26 @@ vmx_model_build_runs <- function(data_version = NULL, study = NULL, #' @return A `vmx_model_build_run`. #' @export vmx_model_build_status <- function(run, client = vmx_client()) { - data <- vmx_get(client, paste0("/model-build-runs/", vmx_id(run, "run"), "/status")) + run_id <- vmx_id(run, "run") + data <- vmx_get(client, paste0("/model-build-runs/", run_id, "/status")) + vmx_validate_response_id(data, "run_id", run_id, "model-build status") new_vmx_resource(data, "vmx_model_build_run", "run_id") } #' Build-run logs #' @param run A build-run id or object. +#' @param order Newest-first (`"desc"`) or oldest-first (`"asc"`). #' @param client A `vmx_client`. -#' @return A tibble of log lines. +#' @return A tibble containing all log lines in the requested order. #' @export -vmx_model_build_logs <- function(run, client = vmx_client()) { - vmx_items_to_tibble(vmx_paginate(client, paste0("/model-build-runs/", vmx_id(run, "run"), "/logs"))) +vmx_model_build_logs <- function(run, client = vmx_client(), + order = c("desc", "asc")) { + order <- match.arg(order) + vmx_paginate( + client, + paste0("/model-build-runs/", vmx_id(run, "run"), "/logs"), + list(order = order) + ) } #' Build-run results @@ -146,7 +247,10 @@ vmx_model_build_logs <- function(run, client = vmx_client()) { #' @return A list (fits summary, modeling population, PK structure selection). #' @export vmx_model_build_results <- function(run, client = vmx_client()) { - vmx_get(client, paste0("/model-build-runs/", vmx_id(run, "run"), "/results")) + run_id <- vmx_id(run, "run") + out <- vmx_get(client, paste0("/model-build-runs/", run_id, "/results")) + vmx_validate_response_id(out, "run_id", run_id, "model-build results") + out } #' Markdown export of a build run @@ -155,11 +259,18 @@ vmx_model_build_results <- function(run, client = vmx_client()) { #' @return The export markdown as a length-1 character vector. #' @export vmx_model_build_export <- function(run, client = vmx_client()) { + run_id <- vmx_id(run, "run") req <- httr2::req_headers( - vmx_req(client, paste0("/model-build-runs/", vmx_id(run, "run"), "/export")), + vmx_req(client, paste0("/model-build-runs/", run_id, "/export")), Accept = "application/json" ) - vmx_perform(req)$content + out <- vmx_perform(req) + vmx_validate_response_id(out, "run_id", run_id, "model-build export") + vmx_response_scalar( + vmx_response_field(out, "content", "model-build export.content"), + "model-build export.content", + type = "character" + ) } #' Build-run report status (signed HTML report URL when ready) @@ -168,7 +279,10 @@ vmx_model_build_export <- function(run, client = vmx_client()) { #' @return A list with `status` and, when ready, `url`. #' @export vmx_model_build_report <- function(run, client = vmx_client()) { - vmx_get(client, paste0("/model-build-runs/", vmx_id(run, "run"), "/report")) + run_id <- vmx_id(run, "run") + out <- vmx_get(client, paste0("/model-build-runs/", run_id, "/report")) + vmx_validate_response_id(out, "run_id", run_id, "model-build report") + out } #' Request build-run report generation @@ -183,11 +297,14 @@ vmx_model_build_report <- function(run, client = vmx_client()) { vmx_model_build_report_create <- function(run, subject_plot_mode = c("all", "none"), client = vmx_client()) { subject_plot_mode <- match.arg(subject_plot_mode) - vmx_post( + run_id <- vmx_id(run, "run") + out <- vmx_post( client, - paste0("/model-build-runs/", vmx_id(run, "run"), "/report"), + paste0("/model-build-runs/", run_id, "/report"), list(subject_plot_mode = subject_plot_mode) ) + vmx_validate_response_id(out, "run_id", run_id, "model-build report request") + out } #' Cancel a build run @@ -196,7 +313,9 @@ vmx_model_build_report_create <- function(run, subject_plot_mode = c("all", "non #' @return A `vmx_model_build_run`. #' @export vmx_model_build_cancel <- function(run, client = vmx_client()) { - data <- vmx_post(client, paste0("/model-build-runs/", vmx_id(run, "run"), "/cancel")) + run_id <- vmx_id(run, "run") + data <- vmx_post(client, paste0("/model-build-runs/", run_id, "/cancel")) + vmx_validate_response_id(data, "run_id", run_id, "model-build cancellation") new_vmx_resource(data, "vmx_model_build_run", "run_id") } @@ -222,21 +341,34 @@ vmx_model_build_artifacts <- function(run, dest = ".", client = vmx_client()) { # ---- Fits ------------------------------------------------------------------ #' List model fits -#' @param run,data_version,model_type,marker_name,status Optional filters. +#' @param run Optional model-build run filter. +#' @param data_version Optional data-version filter. +#' @param treatment Optional treatment filter. +#' @param study Optional study filter. +#' @param model_type Optional model-type filter. +#' @param marker_name Optional marker-name filter. +#' @param source_pk_model_fit Optional source PK model-fit filter. +#' @param status Optional model-fit status filter. #' @param client A `vmx_client`. -#' @return A tibble. +#' @return A tibble containing all matching model fits. #' @export vmx_model_fits <- function(run = NULL, data_version = NULL, model_type = NULL, marker_name = NULL, status = NULL, - client = vmx_client()) { + client = vmx_client(), treatment = NULL, study = NULL, + source_pk_model_fit = NULL) { params <- list( run_id = vmx_opt_id(run, "run", "run"), data_version_id = vmx_opt_id(data_version, "dv", "data_version"), + treatment_id = vmx_opt_id(treatment, "tmt", "treatment"), + study_id = vmx_opt_id(study, "std", "study"), model_type = model_type, marker_name = marker_name, + source_pk_model_fit_id = vmx_opt_id( + source_pk_model_fit, "mf", "source_pk_model_fit" + ), status = status ) - vmx_items_to_tibble(vmx_paginate(client, "/model-fits", params)) + vmx_paginate(client, "/model-fits", params) } #' Fetch one model fit's details @@ -247,6 +379,10 @@ vmx_model_fits <- function(run = NULL, data_version = NULL, model_type = NULL, vmx_model_fit <- function(id, client = vmx_client()) { mf <- vmx_id(id, "mf") data <- vmx_get(client, paste0("/model-fits/", mf, "/details")) + metadata <- vmx_response_field(data, "metadata", "model-fit details.metadata") + vmx_validate_response_id( + metadata, "model_fit_id", mf, "model-fit details metadata" + ) data$model_fit_id <- mf new_vmx_resource(data, "vmx_model_fit", "model_fit_id") } @@ -257,103 +393,509 @@ vmx_model_fit <- function(id, client = vmx_client()) { #' @return A list with postprocessor status. #' @export vmx_model_fit_postprocessor_status <- function(fit, client = vmx_client()) { - vmx_get(client, paste0("/model-fits/", vmx_id(fit, "mf"), "/postprocessor-status")) + fit_id <- vmx_id(fit, "mf") + out <- vmx_get(client, paste0("/model-fits/", fit_id, "/postprocessor-status")) + vmx_validate_response_id(out, "model_fit_id", fit_id, "postprocessor status") + out } #' Subject-level parameter estimates (tidy, long) #' -#' One row per subject x parameter, with the posterior point estimate (`value`) -#' and credible interval (`ci_lower`/`ci_upper`). +#' One row per subject x estimate. `value_statistic`, `interval_kind`, and +#' `interval_level` preserve the server-selected estimate semantics; +#' `interval_lower` and `interval_upper` are the corresponding bounds. Tagged +#' estimate metadata is retained as columns rather than interpreted by vmxr. #' #' @param fit A fit id or `vmx_model_fit`. #' @param client A `vmx_client`. #' @return A tibble. #' @export vmx_fit_subject_estimates <- function(fit, client = vmx_client()) { - d <- vmx_get(client, paste0("/model-fits/", vmx_id(fit, "mf"), "/subject-estimates")) - subject_id <- vmx_chr(d$subject_id) - gen_subject_uuid <- vmx_chr(d$gen_subject_uuid) - n <- length(subject_id) - rows <- lapply(d$estimates, function(est) { - tibble::tibble( + fit_id <- vmx_id(fit, "mf") + d <- vmx_get(client, paste0("/model-fits/", fit_id, "/subject-estimates")) + vmx_validate_response_id(d, "model_fit_id", fit_id, "subject estimates") + gen_subject_uuid <- vmx_response_vector( + vmx_response_field(d, "gen_subject_uuid", "subject estimates.gen_subject_uuid"), + "subject estimates.gen_subject_uuid", + type = "character" + ) + if (anyDuplicated(gen_subject_uuid)) { + vmx_abort_response( + "field 'subject estimates.gen_subject_uuid' contains duplicate subject keys.", + field = "gen_subject_uuid" + ) + } + n <- length(gen_subject_uuid) + subject_id <- vmx_response_vector( + vmx_response_field(d, "subject_id", "subject estimates.subject_id"), + "subject estimates.subject_id", + type = "character", + size = n + ) + estimates <- vmx_estimate_rows(d, "subject estimates") + rows <- lapply(seq_along(estimates), function(i) { + core <- vmx_estimate_core( + estimates[[i]], + sprintf("subject estimates.estimates[%d]", i), + size = n, + tagged = TRUE + ) + base <- tibble::tibble( subject_id = subject_id, gen_subject_uuid = gen_subject_uuid, - name = est$name %||% NA_character_, - display_name = est$display_name %||% NA_character_, - unit = est$unit %||% NA_character_, - value = vmx_pad(vmx_num(est$value), n), - ci_lower = vmx_pad(vmx_num(est$interval$lower), n), - ci_upper = vmx_pad(vmx_num(est$interval$upper), n), - value_statistic = est$value_statistic %||% NA_character_, - kind = est$kind %||% NA_character_, - model_type = est$model_type %||% NA_character_ + value = core$value, + interval_lower = core$interval_lower, + interval_upper = core$interval_upper, + value_statistic = rep(core$value_statistic, n), + interval_kind = rep(core$interval_kind, n), + interval_level = rep(core$interval_level, n) + ) + vctrs::vec_cbind( + base, + vmx_estimate_metadata( + estimates[[i]], + n, + sprintf("subject estimates.estimates[%d]", i) + ) ) }) - vctrs::vec_rbind(!!!rows) + out <- if (length(rows)) { + vctrs::vec_rbind(!!!rows) + } else { + vmx_empty_estimate_tibble(subject = TRUE) + } + attr(out, "model_fit_id") <- fit_id + if ("schema_version" %in% names(d)) attr(out, "schema_version") <- d$schema_version + out } #' Global (population) parameter estimates (tidy) #' -#' One row per parameter, with the point estimate and credible interval. +#' One row per estimate, preserving the server-selected point statistic, +#' interval kind, interval level, and tagged estimate metadata. #' #' @param fit A fit id or `vmx_model_fit`. #' @param client A `vmx_client`. #' @return A tibble. #' @export vmx_fit_global_estimates <- function(fit, client = vmx_client()) { - d <- vmx_get(client, paste0("/model-fits/", vmx_id(fit, "mf"), "/global-estimates")) - rows <- lapply(d$estimates, function(est) { - tibble::tibble( - name = est$name %||% NA_character_, - display_name = est$display_name %||% NA_character_, - unit = est$unit %||% NA_character_, - value = vmx_num1(est$value), - ci_lower = vmx_num1(est$interval$lower), - ci_upper = vmx_num1(est$interval$upper), - level = vmx_num1(est$interval$level), - value_statistic = est$value_statistic %||% NA_character_, - kind = est$kind %||% NA_character_, - model_type = est$model_type %||% NA_character_, - description = est$description %||% NA_character_ + fit_id <- vmx_id(fit, "mf") + d <- vmx_get(client, paste0("/model-fits/", fit_id, "/global-estimates")) + vmx_validate_response_id(d, "model_fit_id", fit_id, "global estimates") + estimates <- vmx_estimate_rows(d, "global estimates") + rows <- lapply(seq_along(estimates), function(i) { + core <- vmx_estimate_core( + estimates[[i]], + sprintf("global estimates.estimates[%d]", i), + size = NULL, + tagged = TRUE + ) + base <- tibble::tibble( + value = core$value, + interval_lower = core$interval_lower, + interval_upper = core$interval_upper, + value_statistic = core$value_statistic, + interval_kind = core$interval_kind, + interval_level = core$interval_level + ) + vctrs::vec_cbind( + base, + vmx_estimate_metadata( + estimates[[i]], + 1L, + sprintf("global estimates.estimates[%d]", i) + ) ) }) - vctrs::vec_rbind(!!!rows) + out <- if (length(rows)) { + vctrs::vec_rbind(!!!rows) + } else { + vmx_empty_estimate_tibble(subject = FALSE) + } + attr(out, "model_fit_id") <- fit_id + if ("schema_version" %in% names(d)) attr(out, "schema_version") <- d$schema_version + out } #' Observed-vs-predicted diagnostic (tidy) #' -#' Reshapes the `pk` block's parallel observation arrays (subject ids, time, -#' observed concentration, BLQ/ALOQ flags, LLOQ, …) into a one-row-per- -#' observation tibble. Non-columnar members — notably the predicted- -#' concentration quantile bands — are kept on the `"extra"` attribute; the PD -#' block is on `"pd"` and the fit id on `"model_fit_id"`. +#' Reshapes the PK block into one row per observation. The returned prediction +#' columns retain the server-selected point statistic and interval semantics. +#' A named list of equivalently reshaped PD-marker tibbles is attached as the +#' `"pd_markers"` attribute; units and marker references remain attributes on +#' their respective tibbles. #' #' @param fit A fit id or `vmx_model_fit`. #' @param client A `vmx_client`. #' @return A tibble (one row per PK observation). #' @export vmx_fit_obs_vs_pred <- function(fit, client = vmx_client()) { - art <- vmx_get(client, paste0("/model-fits/", vmx_id(fit, "mf"), "/obs-vs-pred")) - out <- vmx_columns_to_tibble(art$pk) - attr(out, "pd") <- art$pd_markers - attr(out, "model_fit_id") <- art$model_fit_id + fit_id <- vmx_id(fit, "mf") + art <- vmx_get(client, paste0("/model-fits/", fit_id, "/obs-vs-pred")) + vmx_validate_response_id(art, "model_fit_id", fit_id, "observed-vs-predicted") + pk <- vmx_response_field(art, "pk", "observed-vs-predicted.pk") + out <- vmx_obs_vs_pred_block( + pk, + "observed-vs-predicted.pk", + observed_field = "observed_concentration", + predicted_field = "predicted_concentration", + pk = TRUE + ) + pd_payload <- vmx_response_field( + art, "pd_markers", "observed-vs-predicted.pd_markers" + ) + if (!is.list(pd_payload) || is.null(names(pd_payload)) || + any(!nzchar(names(pd_payload))) || anyDuplicated(names(pd_payload))) { + vmx_abort_response( + "field 'observed-vs-predicted.pd_markers' must be an object keyed by marker name.", + field = "pd_markers" + ) + } + pd_markers <- lapply(seq_along(pd_payload), function(i) { + marker_name <- names(pd_payload)[[i]] + vmx_obs_vs_pred_block( + pd_payload[[i]], + sprintf("observed-vs-predicted.pd_markers[%d]", i), + observed_field = "observed", + predicted_field = "predicted", + pk = FALSE, + marker_name = marker_name + ) + }) + names(pd_markers) <- names(pd_payload) + attr(out, "pd_markers") <- pd_markers + attr(out, "model_fit_id") <- fit_id out } #' Visual predictive check artifact #' -#' Returns the parsed VPC artifact (per dose-group and per-subject quantile -#' bands over time grids). Tibble reshaping is deferred; see the package NEWS. +#' Returns the parsed Visual Predictive Check artifact. Its subject and +#' dose-group channels contain model-implied response trajectories with the +#' server-provided point statistic and interval. The nested wire shape is +#' retained verbatim. #' #' @param fit A fit id or `vmx_model_fit`. #' @param client A `vmx_client`. #' @return A list (the parsed artifact). #' @export vmx_fit_vpc <- function(fit, client = vmx_client()) { - vmx_get(client, paste0("/model-fits/", vmx_id(fit, "mf"), "/vpc")) + fit_id <- vmx_id(fit, "mf") + out <- vmx_get(client, paste0("/model-fits/", fit_id, "/vpc")) + vmx_validate_response_id(out, "model_fit_id", fit_id, "VPC") + out +} + +# ---- Estimate response validation ----------------------------------------- + +vmx_estimate_rows <- function(payload, context) { + rows <- vmx_response_field(payload, "estimates", paste0(context, ".estimates")) + if (!is.list(rows) || !is.null(names(rows))) { + vmx_abort_response( + sprintf("field '%s.estimates' must be an array.", context), + field = "estimates" + ) + } + rows } -# Pad a numeric vector to length n with NA (guards against absent CI arrays). -vmx_pad <- function(v, n) if (length(v) == n) v else rep(NA_real_, n) -# Scalar coercion with NA for JSON null / absent. -vmx_num1 <- function(v) if (length(v) == 0) NA_real_ else as.numeric(v[[1]]) +vmx_estimate_core <- function(est, context, size = NULL, tagged = FALSE) { + if (!is.list(est) || is.null(names(est)) || anyDuplicated(names(est))) { + vmx_abort_response(sprintf("%s must be an object.", context), field = context) + } + if (isTRUE(tagged)) { + for (field in c("kind", "name", "display_name", "model_type", "unit")) { + vmx_response_scalar( + vmx_response_field(est, field, paste0(context, ".", field)), + paste0(context, ".", field), + type = "character", + nonempty = TRUE + ) + } + model_type <- est$model_type + if (!model_type %in% c("pk", "pd")) { + vmx_abort_response( + sprintf("field '%s.model_type' must be 'pk' or 'pd'.", context), + field = paste0(context, ".model_type") + ) + } + if (identical(model_type, "pd")) { + vmx_response_scalar( + vmx_response_field(est, "marker_name", paste0(context, ".marker_name")), + paste0(context, ".marker_name"), + type = "character", + nonempty = TRUE + ) + } + } + value_statistic <- vmx_response_scalar( + vmx_response_field(est, "value_statistic", paste0(context, ".value_statistic")), + paste0(context, ".value_statistic"), + type = "character", + nonempty = TRUE + ) + interval <- vmx_response_field(est, "interval", paste0(context, ".interval")) + if (!is.list(interval) || is.null(names(interval))) { + vmx_abort_response( + sprintf("field '%s.interval' must be an object.", context), + field = paste0(context, ".interval") + ) + } + interval_kind <- vmx_response_scalar( + vmx_response_field(interval, "kind", paste0(context, ".interval.kind")), + paste0(context, ".interval.kind"), + type = "character", + nonempty = TRUE + ) + interval_level <- vmx_response_scalar( + vmx_response_field(interval, "level", paste0(context, ".interval.level")), + paste0(context, ".interval.level"), + type = "numeric" + ) + if (interval_level <= 0 || interval_level > 1) { + vmx_abort_response( + sprintf("field '%s.interval.level' must be in (0, 1].", context), + field = paste0(context, ".interval.level") + ) + } + if (is.null(size)) { + value <- vmx_response_scalar( + vmx_response_field(est, "value", paste0(context, ".value")), + paste0(context, ".value"), + type = "numeric" + ) + lower <- vmx_response_scalar( + vmx_response_field(interval, "lower", paste0(context, ".interval.lower")), + paste0(context, ".interval.lower"), + type = "numeric" + ) + upper <- vmx_response_scalar( + vmx_response_field(interval, "upper", paste0(context, ".interval.upper")), + paste0(context, ".interval.upper"), + type = "numeric" + ) + } else { + value <- vmx_response_vector( + vmx_response_field(est, "value", paste0(context, ".value")), + paste0(context, ".value"), + type = "numeric", + size = size + ) + lower <- vmx_response_vector( + vmx_response_field(interval, "lower", paste0(context, ".interval.lower")), + paste0(context, ".interval.lower"), + type = "numeric", + size = size + ) + upper <- vmx_response_vector( + vmx_response_field(interval, "upper", paste0(context, ".interval.upper")), + paste0(context, ".interval.upper"), + type = "numeric", + size = size + ) + } + if (any(lower > upper)) { + vmx_abort_response( + sprintf("field '%s.interval' has a lower bound above its upper bound.", context), + field = paste0(context, ".interval") + ) + } + list( + value = value, + interval_lower = lower, + interval_upper = upper, + value_statistic = value_statistic, + interval_kind = interval_kind, + interval_level = interval_level + ) +} + +# Preserve every additive TaggedEstimate metadata field. Known fields remain +# ordinary columns; future scalar fields do too, while nested metadata becomes +# a list-column rather than being discarded. +vmx_estimate_metadata <- function(est, size, context) { + core_fields <- c("value", "value_statistic", "interval") + reserved <- c( + "subject_id", "gen_subject_uuid", "value", "interval_lower", + "interval_upper", "value_statistic", "interval_kind", "interval_level" + ) + fields <- setdiff(names(est), core_fields) + collision <- intersect(fields, reserved) + if (length(collision)) { + vmx_abort_response( + sprintf("%s metadata conflicts with a tidy estimate column.", context), + field = collision[[1]] + ) + } + columns <- list() + for (field in fields) { + value <- est[[field]] + if (is.null(value)) next + columns[[field]] <- if (!is.list(value) && length(value) == 1L && !is.na(value)) { + rep(value, size) + } else { + rep(list(value), size) + } + } + tibble::as_tibble(columns) +} + +vmx_empty_estimate_tibble <- function(subject) { + out <- tibble::tibble( + value = numeric(0), + interval_lower = numeric(0), + interval_upper = numeric(0), + value_statistic = character(0), + interval_kind = character(0), + interval_level = numeric(0), + kind = character(0), + name = character(0), + display_name = character(0), + model_type = character(0), + unit = character(0) + ) + if (isTRUE(subject)) { + out <- vctrs::vec_cbind( + tibble::tibble( + subject_id = character(0), + gen_subject_uuid = character(0) + ), + out + ) + } + out +} + +vmx_obs_vs_pred_block <- function(block, context, observed_field, + predicted_field, pk, marker_name = NULL) { + if (!is.list(block) || is.null(names(block))) { + vmx_abort_response(sprintf("%s must be an object.", context), field = context) + } + gen_measurement_uuid <- vmx_response_vector( + vmx_response_field(block, "gen_measurement_uuid", paste0(context, ".gen_measurement_uuid")), + paste0(context, ".gen_measurement_uuid"), + type = "character" + ) + if (anyDuplicated(gen_measurement_uuid)) { + vmx_abort_response( + sprintf("field '%s.gen_measurement_uuid' contains duplicate measurement keys.", context), + field = "gen_measurement_uuid" + ) + } + n <- length(gen_measurement_uuid) + gen_subject_uuid <- vmx_response_vector( + vmx_response_field(block, "gen_subject_uuid", paste0(context, ".gen_subject_uuid")), + paste0(context, ".gen_subject_uuid"), + type = "character", + size = n + ) + subject_id <- vmx_response_vector( + vmx_response_field(block, "subject_id", paste0(context, ".subject_id")), + paste0(context, ".subject_id"), + type = "character", + size = n + ) + time <- vmx_response_vector( + vmx_response_field(block, "time", paste0(context, ".time")), + paste0(context, ".time"), + type = "numeric", + size = n + ) + observed <- vmx_response_vector( + vmx_response_field(block, observed_field, paste0(context, ".", observed_field)), + paste0(context, ".", observed_field), + type = "numeric", + size = n, + nullable = TRUE + ) + predicted <- vmx_response_field( + block, predicted_field, paste0(context, ".", predicted_field) + ) + estimate <- vmx_estimate_core( + predicted, + paste0(context, ".", predicted_field), + size = n, + tagged = FALSE + ) + out <- tibble::tibble( + gen_measurement_uuid = gen_measurement_uuid, + gen_subject_uuid = gen_subject_uuid, + subject_id = subject_id, + time = time + ) + out[[observed_field]] <- observed + if (isTRUE(pk)) { + for (field in c("is_bloq", "is_aloq")) { + out[[field]] <- vmx_response_vector( + vmx_response_field(block, field, paste0(context, ".", field)), + paste0(context, ".", field), + type = "logical", + size = n + ) + } + for (field in c("lloq", "uloq")) { + if (field %in% names(block)) { + out[[field]] <- vmx_response_vector( + block[[field]], + paste0(context, ".", field), + type = "numeric", + size = n, + nullable = TRUE + ) + } + } + } else { + marker <- vmx_response_field(block, "marker", paste0(context, ".marker")) + marker_gen_uuid <- vmx_response_scalar( + vmx_response_field(marker, "gen_uuid", paste0(context, ".marker.gen_uuid")), + paste0(context, ".marker.gen_uuid"), + type = "character", + nonempty = TRUE + ) + marker_value <- vmx_response_scalar( + vmx_response_field(marker, "name", paste0(context, ".marker.name")), + paste0(context, ".marker.name"), + type = "character", + nonempty = TRUE + ) + if (!identical(marker_value, marker_name)) { + vmx_abort_response( + sprintf("field '%s.marker.name' does not match its pd_markers map key.", context), + field = paste0(context, ".marker.name") + ) + } + attr(out, "marker") <- list( + gen_uuid = marker_gen_uuid, + name = marker_value + ) + } + out$predicted_value <- estimate$value + out$predicted_interval_lower <- estimate$interval_lower + out$predicted_interval_upper <- estimate$interval_upper + out$predicted_value_statistic <- rep(estimate$value_statistic, n) + out$predicted_interval_kind <- rep(estimate$interval_kind, n) + out$predicted_interval_level <- rep(estimate$interval_level, n) + units <- vmx_response_field(block, "units", paste0(context, ".units")) + required_units <- if (isTRUE(pk)) { + c("time", "concentration") + } else { + c("time", "observed", "predicted") + } + if (!is.list(units) || is.null(names(units)) || anyDuplicated(names(units)) || + !all(required_units %in% names(units))) { + vmx_abort_response( + sprintf("field '%s.units' is missing required unit labels.", context), + field = paste0(context, ".units") + ) + } + for (field in required_units) { + vmx_response_scalar( + units[[field]], + paste0(context, ".units.", field), + type = "character", + nonempty = TRUE + ) + } + attr(out, "units") <- units + out +} diff --git a/R/nca.R b/R/nca.R index 3753f27..974bfc6 100644 --- a/R/nca.R +++ b/R/nca.R @@ -8,7 +8,7 @@ #' `degraded`/`failed`). #' @param time_basis Optional time-basis filter. #' @param client A `vmx_client`. -#' @return A tibble, one row per analysis. +#' @return A tibble containing all matching analyses. #' @export vmx_nca_analyses <- function(data_version = NULL, study = NULL, treatment = NULL, status = NULL, time_basis = NULL, @@ -20,7 +20,7 @@ vmx_nca_analyses <- function(data_version = NULL, study = NULL, treatment = NULL status = status, time_basis = time_basis ) - vmx_items_to_tibble(vmx_paginate(client, "/nca-analyses", params)) + vmx_paginate(client, "/nca-analyses", params) } #' Run an NCA analysis @@ -42,14 +42,23 @@ vmx_nca_analyses <- function(data_version = NULL, study = NULL, treatment = NULL vmx_nca <- function(data_version, time_basis, idempotency_key = NULL, retried_from = NULL, wait = TRUE, ..., client = vmx_client()) { + time_basis <- vmx_nonempty_strings( + time_basis, "time_basis", exactly_one = TRUE + ) + if (!is.null(idempotency_key)) { + vmx_id_like_scalar(idempotency_key, "idempotency_key") + } body <- vmx_compact(list( data_version_id = vmx_id(data_version, "dv", "data_version"), time_basis = time_basis, idempotency_key = idempotency_key, - retried_from = retried_from + retried_from = vmx_opt_id(retried_from, "nca", "retried_from") )) - nca <- new_vmx_resource(vmx_post(client, "/nca-analyses", body), - "vmx_nca_analysis", "nca_id") + data <- vmx_post(client, "/nca-analyses", body) + vmx_validate_response_id( + data, "data_version_id", body$data_version_id, "NCA creation" + ) + nca <- new_vmx_resource(data, "vmx_nca_analysis", "nca_id") if (isTRUE(wait)) vmx_wait(nca, client = client, ...) else nca } @@ -59,7 +68,9 @@ vmx_nca <- function(data_version, time_basis, idempotency_key = NULL, #' @return A `vmx_nca_analysis`. #' @export vmx_nca_get <- function(id, client = vmx_client()) { - data <- vmx_get(client, paste0("/nca-analyses/", vmx_id(id, "nca"))) + nca_id <- vmx_id(id, "nca") + data <- vmx_get(client, paste0("/nca-analyses/", nca_id)) + vmx_validate_response_id(data, "nca_id", nca_id, "NCA analysis") new_vmx_resource(data, "vmx_nca_analysis", "nca_id") } @@ -75,27 +86,69 @@ vmx_nca_get <- function(id, client = vmx_client()) { #' @return A tibble. #' @export vmx_nca_result <- function(nca, client = vmx_client()) { - res <- vmx_get(client, paste0("/nca-analyses/", vmx_id(nca, "nca"), "/result")) + nca_id <- vmx_id(nca, "nca") + res <- vmx_get(client, paste0("/nca-analyses/", nca_id, "/result")) + vmx_validate_response_id(res, "nca_id", nca_id, "NCA result") + gen_subject_uuid <- vmx_response_vector( + vmx_response_field(res, "gen_subject_uuid", "NCA result.gen_subject_uuid"), + "NCA result.gen_subject_uuid", + type = "character" + ) + if (anyDuplicated(gen_subject_uuid)) { + vmx_abort_response( + "field 'NCA result.gen_subject_uuid' contains duplicate subject keys.", + field = "gen_subject_uuid" + ) + } + n <- length(gen_subject_uuid) + subject_id <- vmx_response_vector( + vmx_response_field(res, "subject_id", "NCA result.subject_id"), + "NCA result.subject_id", + type = "character", + size = n + ) + estimates <- vmx_response_field(res, "point_estimates", "NCA result.point_estimates") + if (!is.list(estimates) || is.null(names(estimates)) || + any(!nzchar(names(estimates))) || anyDuplicated(names(estimates))) { + vmx_abort_response( + "field 'NCA result.point_estimates' must be an object.", + field = "point_estimates" + ) + } + reserved <- intersect( + names(estimates), c("subject_id", "gen_subject_uuid") + ) + if (length(reserved)) { + vmx_abort_response( + "NCA metric name conflicts with a subject-identity column.", + field = paste0("point_estimates.", reserved[[1]]) + ) + } cols <- list( - subject_id = vmx_chr(res$subject_id), - gen_subject_uuid = vmx_chr(res$gen_subject_uuid) + subject_id = subject_id, + gen_subject_uuid = gen_subject_uuid ) - for (metric in names(res$point_estimates)) { - cols[[metric]] <- vmx_num(res$point_estimates[[metric]]) + for (metric in names(estimates)) { + cols[[metric]] <- vmx_response_vector( + estimates[[metric]], + paste0("NCA result.point_estimates.", metric), + type = "numeric", + size = n, + nullable = TRUE + ) } out <- tibble::as_tibble(cols) - attr(out, "quantities") <- res$quantities + metadata <- res[setdiff( + names(res), + c("gen_subject_uuid", "subject_id", "point_estimates") + )] + attr(out, "vmx_metadata") <- metadata + for (name in c( + "nca_id", "data_version_id", "status", "time_basis", "units", + "quantities", "excluded_subjects", "worker_version", "trigger_source", + "retried_from" + )) { + if (name %in% names(res)) attr(out, name) <- res[[name]] + } out } - -# Coerce a parsed JSON array (list of scalars, possibly with JSON nulls) to a -# vector. A null parses to NULL or an empty list depending on the encoder, so -# treat any length-0 element as a missing value. -vmx_chr <- function(x) { - if (!length(x)) return(character(0)) - vapply(x, function(v) if (length(v) == 0) NA_character_ else as.character(v[[1]]), character(1)) -} -vmx_num <- function(x) { - if (!length(x)) return(numeric(0)) - vapply(x, function(v) if (length(v) == 0) NA_real_ else as.numeric(v[[1]]), numeric(1)) -} diff --git a/R/oidc.R b/R/oidc.R index fd6f188..1f21671 100644 --- a/R/oidc.R +++ b/R/oidc.R @@ -1,7 +1,7 @@ # Native OIDC device-code authentication (GEN-2332). # # vmxr authenticates to vmx-api entirely in R via the OIDC device-code flow -# (RFC 8628, run by httr2::oauth_flow_device) against the staging Authentik +# (RFC 8628, run by httr2::oauth_flow_device) against the workspace's Authentik # vmx-cli provider -- no Python CLI dependency. `vmx_login()` runs the flow and # caches the token; `vmx_client()` auto-authenticates from that cache, silently # refreshing with the refresh token, and prompting a fresh login only when there @@ -75,16 +75,39 @@ vmx_oidc_config <- function(issuer = NULL, client_id = NULL, scopes = NULL) { # is an absolute epoch-seconds deadline; `refresh_token` is NULL when absent. .vmx_token <- function(access_token, refresh_token, expires_at, token_type, issuer, client_id) { + access_token <- .vmx_token_string(access_token, "access_token") + issuer <- .vmx_token_string(issuer, "issuer") + client_id <- .vmx_token_string(client_id, "client_id") + token_type <- .vmx_token_string(token_type %||% "Bearer", "token_type") + expires_at <- suppressWarnings(as.numeric(expires_at)) + if (length(expires_at) != 1L || is.na(expires_at) || !is.finite(expires_at)) { + vmx_abort("OIDC token expiry is invalid.", class = "vmx_auth_error") + } + if (!is.null(refresh_token)) { + refresh_token <- .vmx_token_string(refresh_token, "refresh_token") + } + list( access_token = access_token, - refresh_token = if (is.null(refresh_token) || !nzchar(refresh_token)) NULL else refresh_token, - expires_at = as.numeric(expires_at), - token_type = token_type %||% "Bearer", + refresh_token = refresh_token, + expires_at = expires_at, + token_type = token_type, issuer = sub("/+$", "", issuer), client_id = client_id ) } +.vmx_token_string <- function(value, field) { + if (!is.character(value) || length(value) != 1L || is.na(value) || + !nzchar(trimws(value))) { + vmx_abort( + sprintf("OIDC token %s is invalid.", field), + class = "vmx_auth_error" + ) + } + value +} + .vmx_token_expired <- function(token, now = as.numeric(Sys.time()), skew = .vmx_oidc_expiry_skew) { now >= (token$expires_at - skew) @@ -98,11 +121,14 @@ vmx_oidc_config <- function(issuer = NULL, client_id = NULL, scopes = NULL) { # Build a token from a raw OAuth token-endpoint response body. .vmx_token_from_body <- function(config, body) { access <- body$access_token - if (!is.character(access) || !length(access) || !nzchar(access)) { + if (!is.character(access) || length(access) != 1L || is.na(access) || + !nzchar(trimws(access))) { vmx_abort("OIDC token response did not contain an access_token.", class = "vmx_auth_error") } ttl <- suppressWarnings(as.numeric(body$expires_in %||% 300)) - if (is.na(ttl)) ttl <- 300 + if (length(ttl) != 1L || is.na(ttl) || !is.finite(ttl) || ttl <= 0) { + vmx_abort("OIDC token response contained an invalid expires_in.", class = "vmx_auth_error") + } .vmx_token( access_token = access, refresh_token = body$refresh_token, @@ -116,14 +142,18 @@ vmx_oidc_config <- function(issuer = NULL, client_id = NULL, scopes = NULL) { # Build a token from the httr2_token object oauth_flow_device() returns. .vmx_token_from_httr2 <- function(config, token) { access <- token$access_token - if (is.null(access) || !nzchar(access)) { + if (!is.character(access) || length(access) != 1L || is.na(access) || + !nzchar(trimws(access))) { vmx_abort("OIDC device-code flow returned no access token.", class = "vmx_auth_error") } expires_at <- token$expires_at if (is.null(expires_at)) { issued <- as.numeric(token$.date %||% Sys.time()) ttl <- suppressWarnings(as.numeric(token$expires_in %||% 300)) - if (is.na(ttl)) ttl <- 300 + if (length(issued) != 1L || is.na(issued) || !is.finite(issued) || + length(ttl) != 1L || is.na(ttl) || !is.finite(ttl) || ttl <= 0) { + vmx_abort("OIDC device-code flow returned an invalid token expiry.", class = "vmx_auth_error") + } expires_at <- issued + ttl } .vmx_token( @@ -167,17 +197,19 @@ vmx_oidc_config <- function(issuer = NULL, client_id = NULL, scopes = NULL) { .vmx_token_from_json <- function(data) { need <- c("access_token", "expires_at", "issuer", "client_id") - if (!all(need %in% names(data))) stop("incomplete token cache", call. = FALSE) + if (!is.list(data) || !all(need %in% names(data))) { + stop("incomplete token cache", call. = FALSE) + } .vmx_token( - access_token = as.character(data[["access_token"]]), + access_token = data[["access_token"]], refresh_token = { rt <- data[["refresh_token"]] - if (is.null(rt) || !length(rt) || is.na(rt[1])) NULL else as.character(rt[1]) + if (is.null(rt) || !length(rt) || is.na(rt[1])) NULL else rt }, - expires_at = as.numeric(data[["expires_at"]]), - token_type = as.character(data[["token_type"]] %||% "Bearer"), - issuer = as.character(data[["issuer"]]), - client_id = as.character(data[["client_id"]]) + expires_at = data[["expires_at"]], + token_type = data[["token_type"]] %||% "Bearer", + issuer = data[["issuer"]], + client_id = data[["client_id"]] ) } @@ -197,16 +229,56 @@ vmx_oidc_config <- function(issuer = NULL, client_id = NULL, scopes = NULL) { # write to an unpredictable temp name in the same dir (no fixed-name symlink # target; same filesystem -> atomic rename), then replace the target. .vmx_save_cached_token <- function(token, path = .vmx_oidc_cache_path()) { + token <- .vmx_token( + access_token = token$access_token, + refresh_token = token$refresh_token, + expires_at = token$expires_at, + token_type = token$token_type, + issuer = token$issuer, + client_id = token$client_id + ) dir <- dirname(path) - if (!dir.exists(dir)) dir.create(dir, recursive = TRUE, showWarnings = FALSE, mode = "0700") + if (!dir.exists(dir) && + !dir.create(dir, recursive = TRUE, showWarnings = FALSE, mode = "0700")) { + vmx_abort("Could not create the OIDC token-cache directory.", class = "vmx_auth_error") + } old_umask <- Sys.umask("0177") on.exit(Sys.umask(old_umask), add = TRUE) tmp <- tempfile(tmpdir = dir, fileext = ".tmp") on.exit(if (file.exists(tmp)) unlink(tmp), add = TRUE) - writeLines(.vmx_token_json(token), tmp) - Sys.chmod(tmp, mode = "0600", use_umask = FALSE) - file.rename(tmp, path) - Sys.chmod(path, mode = "0600", use_umask = FALSE) + tryCatch( + writeLines(.vmx_token_json(token), tmp), + error = function(e) { + vmx_abort( + "Could not write the OIDC token cache.", + class = "vmx_auth_error", + parent = e + ) + } + ) + .vmx_secure_token_file(tmp) + if (!.vmx_atomic_rename(tmp, path)) { + vmx_abort( + "Could not atomically replace the OIDC token cache.", + class = "vmx_auth_error" + ) + } + .vmx_secure_token_file(path) + invisible(path) +} + +.vmx_atomic_rename <- function(from, to) { + file.rename(from, to) +} + +.vmx_secure_token_file <- function(path) { + if (.Platform$OS.type != "windows" && + !isTRUE(Sys.chmod(path, mode = "0600", use_umask = FALSE))) { + vmx_abort( + "Could not restrict permissions on the OIDC token cache.", + class = "vmx_auth_error" + ) + } invisible(path) } @@ -360,14 +432,13 @@ vmx_oidc_config <- function(issuer = NULL, client_id = NULL, scopes = NULL) { #' same path and shape the `vmx` CLI uses, with `0600` permissions), so one #' `vmx_login()` serves both R and the terminal CLI and the session survives a #' fresh R process or workspace pod restart. Because the refresh token is -#' persisted on the home PVC, you log in **once per refresh-token lifetime** -#' (~30 days). +#' persisted on the home PVC, you log in once per provider-configured +#' refresh-token lifetime. #' #' Configuration is read from environment variables (matching the CLI): #' `VMX_OIDC_ISSUER`, `VMX_OIDC_CLIENT_ID`, and optionally `VMX_OIDC_SCOPES`. -#' Confirmed-working staging values: issuer -#' `https://auth.staging.gnrbl.co/application/o/generable-staging-vmx-cli/`, -#' client id `generable-staging-vmx-cli`. +#' Workspace deployments provision the issuer and client id; vmxr does not +#' assume values from a different workspace or environment. #' #' @param issuer OIDC issuer base URL. Defaults to `VMX_OIDC_ISSUER`. #' @param client_id Public OIDC client id. Defaults to `VMX_OIDC_CLIENT_ID`. diff --git a/R/poll.R b/R/poll.R index 94911d7..69c12ff 100644 --- a/R/poll.R +++ b/R/poll.R @@ -8,9 +8,25 @@ .vmx_nca_failed <- c("failed") .vmx_build_success <- c("succeeded", "degraded") .vmx_build_failed <- c("failed", "cancelled") +.vmx_dosing_success <- c("succeeded") +.vmx_dosing_failed <- c("failed") .vmx_sim_success <- c("succeeded") .vmx_sim_failed <- c("failed", "cancelled") +.vmx_prep_statuses <- c( + "uploaded", "queued", "formatting", "awaiting_input", "formatted", + "ineligible", "failed", "cancelled" +) +.vmx_nca_statuses <- c("queued", "running", "completed", "degraded", "failed") +.vmx_build_statuses <- c( + "queued", "validating", "running", "cancelling", "succeeded", "degraded", + "failed", "cancelled" +) +.vmx_dosing_statuses <- c("queued", "running", "succeeded", "failed") +.vmx_sim_statuses <- c( + "queued", "running", "cancelling", "succeeded", "failed", "cancelled" +) + #' Block until an async handle reaches a terminal state #' #' An S3 generic dispatching on the handle type. Each method has a sensible @@ -20,9 +36,16 @@ #' @param x A pollable handle: a dataset / prep-status or an NCA analysis (more #' types as the API surface lands: model-build-run, simulation-job). #' @param until Target terminal state(s); a sensible default per type when -#' `NULL`. -#' @param timeout Timeout in seconds. -#' @param interval Poll interval in seconds (exponential backoff up to 30s). +#' `NULL`. An explicitly requested failure state is returned; any other +#' terminal failure still raises immediately. +#' @param timeout Timeout in seconds. Resource methods use long-running defaults: +#' 70 minutes for prep, NCA, and dosing input; 130 minutes for simulation; and +#' 24 hours 10 minutes for model builds. The NCA/modeling worker defaults +#' include a short persistence cushion beyond their execution ceilings; prep +#' uses a client-side wait policy because its worker has no equivalent hard +#' wall-clock ceiling. +#' @param interval Positive poll interval in seconds (exponential backoff up +#' to 30s). #' @param progress Show a progress message each poll; defaults to #' [interactive()]. #' @param client A `vmx_client`. @@ -44,48 +67,63 @@ vmx_wait.default <- function(x, until = NULL, timeout = 900, interval = 5, } #' @export -vmx_wait.vmx_dataset <- function(x, until = NULL, timeout = 900, interval = 5, +vmx_wait.vmx_dataset <- function(x, until = NULL, timeout = 4200, interval = 5, progress = interactive(), client = vmx_client(), ...) { id <- vmx_id(x, "ds", arg = "x") vmx_poll_status(id, function(i) vmx_prep_status(i, client = client), .vmx_prep_success, .vmx_prep_failed, - until, timeout, interval, progress, "Dataset") + .vmx_prep_statuses, until, timeout, interval, progress, + "Dataset") } #' @export -vmx_wait.vmx_prep_status <- function(x, until = NULL, timeout = 900, interval = 5, +vmx_wait.vmx_prep_status <- function(x, until = NULL, timeout = 4200, interval = 5, progress = interactive(), client = vmx_client(), ...) { id <- vmx_id(x, "ds", arg = "x") vmx_poll_status(id, function(i) vmx_prep_status(i, client = client), .vmx_prep_success, .vmx_prep_failed, - until, timeout, interval, progress, "Dataset") + .vmx_prep_statuses, until, timeout, interval, progress, + "Dataset") } #' @export -vmx_wait.vmx_nca_analysis <- function(x, until = NULL, timeout = 900, interval = 5, +vmx_wait.vmx_nca_analysis <- function(x, until = NULL, timeout = 4200, interval = 5, progress = interactive(), client = vmx_client(), ...) { id <- vmx_id(x, "nca", arg = "x") vmx_poll_status(id, function(i) vmx_nca_get(i, client = client), .vmx_nca_success, .vmx_nca_failed, - until, timeout, interval, progress, "NCA analysis") + .vmx_nca_statuses, until, timeout, interval, progress, + "NCA analysis") } #' @export -vmx_wait.vmx_model_build_run <- function(x, until = NULL, timeout = 900, interval = 5, +vmx_wait.vmx_model_build_run <- function(x, until = NULL, timeout = 87000, interval = 5, progress = interactive(), client = vmx_client(), ...) { id <- vmx_id(x, "run", arg = "x") vmx_poll_status(id, function(i) vmx_model_build_status(i, client = client), .vmx_build_success, .vmx_build_failed, - until, timeout, interval, progress, "Model build run") + .vmx_build_statuses, until, timeout, interval, progress, + "Model build run") +} + +#' @export +vmx_wait.vmx_dosing_input <- function(x, until = NULL, timeout = 4200, interval = 5, + progress = interactive(), client = vmx_client(), ...) { + id <- vmx_dosing_input_id(x) + vmx_poll_status(id, function(i) vmx_dosing_input_status(i, client = client), + .vmx_dosing_success, .vmx_dosing_failed, + .vmx_dosing_statuses, until, timeout, interval, progress, + "Dosing input") } #' @export -vmx_wait.vmx_simulation_job <- function(x, until = NULL, timeout = 900, interval = 5, +vmx_wait.vmx_simulation_job <- function(x, until = NULL, timeout = 7800, interval = 5, progress = interactive(), client = vmx_client(), ...) { id <- vmx_id(x, "simjob", arg = "x") vmx_poll_status(id, function(i) vmx_sim_status(i, client = client), .vmx_sim_success, .vmx_sim_failed, - until, timeout, interval, progress, "Simulation job") + .vmx_sim_statuses, until, timeout, interval, progress, + "Simulation job") } #' Generic status poller with exponential backoff @@ -94,27 +132,73 @@ vmx_wait.vmx_simulation_job <- function(x, until = NULL, timeout = 900, interval #' @param fetch A function taking `id` and returning the refreshed object #' (something with a `$status`). #' @param success,failed Character vectors of terminal states. +#' @param known Closed status vocabulary for this resource. #' @param until Explicit target state(s), overriding the defaults. #' @param label Human label for messages. #' @keywords internal #' @noRd -vmx_poll_status <- function(id, fetch, success, failed, until, timeout, +vmx_poll_status <- function(id, fetch, success, failed, known, until, timeout, interval, progress, label) { - stop_at <- until %||% c(success, failed) + if (!is.numeric(timeout) || length(timeout) != 1L || is.na(timeout) || + !is.finite(timeout) || timeout <= 0) { + vmx_abort("`timeout` must be one finite positive number.", + class = "vmx_usage_error") + } + if (!is.numeric(interval) || length(interval) != 1L || is.na(interval) || + !is.finite(interval) || interval <= 0) { + vmx_abort("`interval` must be one finite positive number.", + class = "vmx_usage_error") + } + if (!is.null(until)) { + if (!is.character(until) || !length(until) || anyNA(until) || + any(!until %in% known)) { + vmx_abort( + sprintf( + "`until` must contain known %s statuses: %s.", + tolower(label), paste(known, collapse = ", ") + ), + class = "vmx_usage_error" + ) + } + } + targets <- until %||% success deadline <- Sys.time() + timeout wait <- interval repeat { obj <- fetch(id) status <- obj$status %||% "" - if (status %in% stop_at) { - if (is.null(until) && status %in% failed) { - vmx_abort( - sprintf("%s %s reached terminal status '%s'.", label, id, status), - class = "vmx_api_error", status = status, data = unclass(obj) - ) - } + if (!is.character(status) || length(status) != 1L || is.na(status) || + !status %in% known) { + vmx_abort_response( + sprintf("%s status response contains an unknown status.", label), + field = "status" + ) + } + if (status %in% targets) { return(obj) } + if (status %in% failed) { + detail <- vmx_job_failure_detail(obj) + suffix <- if (is.null(detail)) "" else paste0(" ", detail) + vmx_abort( + sprintf("%s %s reached terminal status '%s'.%s", + label, id, status, suffix), + class = c("vmx_job_error", "vmx_api_error"), + resource_status = status, + data = unclass(obj) + ) + } + if (status %in% success) { + vmx_abort( + sprintf( + "%s %s reached terminal status '%s' before the requested status.", + label, id, status + ), + class = "vmx_job_error", + resource_status = status, + data = unclass(obj) + ) + } if (Sys.time() >= deadline) { vmx_abort( sprintf("Timed out after %gs waiting on %s; last status '%s'.", @@ -129,3 +213,17 @@ vmx_poll_status <- function(id, fetch, success, failed, until, timeout, wait <- min(wait * 2, 30) } } + +vmx_job_failure_detail <- function(obj) { + candidates <- list(obj$failure_reason, obj$error_message) + if (is.list(obj$progress)) { + candidates[[length(candidates) + 1L]] <- obj$progress$message + } + for (candidate in candidates) { + if (is.character(candidate) && length(candidate) == 1L && + !is.na(candidate) && nzchar(trimws(candidate))) { + return(trimws(candidate)) + } + } + NULL +} diff --git a/R/prep.R b/R/prep.R index f2bb82c..cb98406 100644 --- a/R/prep.R +++ b/R/prep.R @@ -11,43 +11,165 @@ vmx_prep_status <- function(dataset, client = vmx_client()) { id <- vmx_id(dataset, "ds", arg = "dataset") data <- vmx_get(client, paste0("/datasets/", id, "/prep-status")) + vmx_validate_response_id(data, "dataset_id", id, "prep status") new_vmx_resource(data, "vmx_prep_status", "dataset_id") } #' Questions raised by prep (when awaiting input) #' @param dataset A dataset id or `vmx_dataset`. #' @param client A `vmx_client`. -#' @return A tibble of pending questions. +#' @return A tibble of pending questions. Variable-shape values such as +#' `options`, `default`, and `data_preview` are retained as list-columns. #' @export vmx_prep_questions <- function(dataset, client = vmx_client()) { ps <- if (inherits(dataset, "vmx_prep_status")) dataset else vmx_prep_status(dataset, client = client) - fields <- ps$prompt$fields - if (is.null(fields) || !length(fields)) { - return(tibble::tibble(field = character(0), question = character(0), required = logical(0))) + prompt <- ps[["prompt"]] + if (is.null(prompt)) { + return(vmx_empty_prep_questions()) } - rows <- lapply(fields, function(f) { + if (!is.list(prompt) || is.null(names(prompt)) || + anyDuplicated(names(prompt))) { + vmx_abort_response( + "field 'prep status.prompt' must be an object.", + field = "prompt" + ) + } + fields <- vmx_response_field( + prompt, "fields", "prep status.prompt.fields" + ) + if (!is.list(fields) || !is.null(names(fields))) { + vmx_abort_response( + "field 'prep status.prompt.fields' must be an array.", + field = "prompt.fields" + ) + } + if (!length(fields)) { + return(vmx_empty_prep_questions()) + } + rows <- lapply(seq_along(fields), function(i) { + f <- fields[[i]] + context <- sprintf("prep status.prompt.fields[%d]", i) + if (!is.list(f) || is.null(names(f)) || anyDuplicated(names(f))) { + vmx_abort_response( + sprintf("%s must be an object.", context), + field = "prompt.fields" + ) + } + field <- vmx_response_scalar( + vmx_response_field(f, "field", paste0(context, ".field")), + paste0(context, ".field"), + type = "character", + nonempty = TRUE + ) + question <- vmx_response_scalar( + vmx_response_field(f, "question", paste0(context, ".question")), + paste0(context, ".question"), + type = "character", + nonempty = TRUE + ) + required <- vmx_response_scalar( + vmx_response_field(f, "required", paste0(context, ".required")), + paste0(context, ".required"), + type = "logical" + ) + resolution <- f[["resolution"]] + if (!is.null(resolution) && + (!is.list(resolution) || is.null(names(resolution)) || + anyDuplicated(names(resolution)))) { + vmx_abort_response( + sprintf("field '%s.resolution' must be an object or null.", context), + field = "prompt.fields.resolution" + ) + } tibble::tibble( - field = f$field %||% NA_character_, - question = f$question %||% NA_character_, - required = isTRUE(f$required), - format = f$format %||% NA_character_, - options = list(f$options), - rationale = f$rationale %||% NA_character_ + field = field, + question = question, + required = required, + format = vmx_optional_prompt_string(f, "format", context), + options = list(f[["options"]]), + referent = vmx_optional_prompt_string(f, "referent", context), + rationale = vmx_optional_prompt_string(f, "rationale", context), + data_preview = list(f[["data_preview"]]), + resolution_kind = vmx_optional_prompt_string( + resolution, "kind", paste0(context, ".resolution") + ), + resolution_hint = vmx_optional_prompt_string( + resolution, "hint", paste0(context, ".resolution") + ), + default = list(f[["default"]]), + group = vmx_optional_prompt_string(f, "group", context) ) }) - vctrs::vec_rbind(!!!rows) + out <- vctrs::vec_rbind(!!!rows) + if (anyDuplicated(out$field)) { + vmx_abort_response( + "field 'prep status.prompt.fields' contains duplicate answer keys.", + field = "prompt.fields.field" + ) + } + out } #' Answer prep questions and resume formatting #' @param dataset A dataset id or `vmx_dataset`. #' @param answers A named list mapping each prompt `field` to its answer value. #' @param client A `vmx_client`. +#' @param idempotency_key Optional idempotency key for safely repeating the +#' submission. #' @export -vmx_prep_answer <- function(dataset, answers, client = vmx_client()) { - if (!is.list(answers) || is.null(names(answers))) { - vmx_abort("`answers` must be a named list of field -> value.", class = "vmx_usage_error") +vmx_prep_answer <- function(dataset, answers, client = vmx_client(), + idempotency_key = NULL) { + if (!is.list(answers) || !length(answers) || is.null(names(answers)) || + any(!nzchar(names(answers))) || anyDuplicated(names(answers))) { + vmx_abort( + "`answers` must be a non-empty named list with unique field names.", + class = "vmx_usage_error" + ) + } + if ("idempotency_key" %in% names(answers)) { + vmx_abort( + "`idempotency_key` is reserved; pass it through the argument of that name.", + class = "vmx_usage_error" + ) + } + body <- answers + if (!is.null(idempotency_key)) { + vmx_id_like_scalar(idempotency_key, "idempotency_key") + body$idempotency_key <- idempotency_key } id <- vmx_id(dataset, "ds", arg = "dataset") - data <- vmx_post(client, paste0("/datasets/", id, "/prep-answers"), as.list(answers)) + data <- vmx_post( + client, paste0("/datasets/", id, "/prep-answers"), body + ) + vmx_validate_response_id(data, "dataset_id", id, "prep answer") new_vmx_resource(data, "vmx_prep_status", "dataset_id") } + +vmx_optional_prompt_string <- function(x, name, context) { + if (is.null(x) || !name %in% names(x) || is.null(x[[name]])) { + return(NA_character_) + } + vmx_response_scalar( + x[[name]], + paste0(context, ".", name), + type = "character", + nonempty = TRUE + ) +} + +vmx_empty_prep_questions <- function() { + tibble::tibble( + field = character(0), + question = character(0), + required = logical(0), + format = character(0), + options = list(), + referent = character(0), + rationale = character(0), + data_preview = list(), + resolution_kind = character(0), + resolution_hint = character(0), + default = list(), + group = character(0) + ) +} diff --git a/R/resources.R b/R/resources.R index 1326134..ff62822 100644 --- a/R/resources.R +++ b/R/resources.R @@ -10,6 +10,18 @@ #' @keywords internal #' @noRd new_vmx_resource <- function(data, subclass, id_field) { + if (!is.list(data) || is.null(names(data)) || anyDuplicated(names(data))) { + vmx_abort_response( + sprintf("resource <%s> must be a named object.", subclass), + field = id_field + ) + } + vmx_response_scalar( + vmx_response_field(data, id_field, paste0(subclass, ".", id_field)), + paste0(subclass, ".", id_field), + type = "character", + nonempty = TRUE + ) structure( data, vmx_id_field = id_field, @@ -22,12 +34,23 @@ new_vmx_resource <- function(data, subclass, id_field) { #' @noRd vmx_resource_id <- function(x) { field <- attr(x, "vmx_id_field") - if (!is.null(field) && !is.null(x[[field]])) { - return(x[[field]]) + if (!is.null(field)) { + return(vmx_response_scalar( + vmx_response_field(x, field, paste0(class(x)[[1]], ".", field)), + paste0(class(x)[[1]], ".", field), + type = "character", + nonempty = TRUE + )) } # Fall back to the first `*_id` element. ids <- grep("_id$", names(x), value = TRUE) - if (length(ids)) x[[ids[[1]]]] else NULL + if (!length(ids)) { + vmx_abort_response( + sprintf("resource <%s> has no declared identifier.", class(x)[[1]]), + field = "id" + ) + } + vmx_response_scalar(x[[ids[[1]]]], ids[[1]], type = "character", nonempty = TRUE) } #' Resolve an argument that may be an id string or a vmx resource object @@ -44,13 +67,16 @@ vmx_resource_id <- function(x) { #' @noRd vmx_id <- function(x, prefix = NULL, arg = "id") { id <- if (inherits(x, "vmx_resource")) vmx_resource_id(x) else x - if (!is.character(id) || length(id) != 1L || is.na(id) || !nzchar(id)) { + if (!is.character(id) || length(id) != 1L || is.na(id) || + !nzchar(trimws(id))) { vmx_abort( sprintf("`%s` must be a single id string or a vmx object.", arg), class = "vmx_usage_error" ) } - if (!is.null(prefix) && !startsWith(id, paste0(prefix, "_"))) { + if (!is.null(prefix) && + (!startsWith(id, paste0(prefix, "_")) || + nchar(id) <= nchar(prefix) + 1L)) { vmx_abort( sprintf("`%s` should be a '%s_*' id, got '%s'.", arg, prefix, id), class = "vmx_usage_error" @@ -59,6 +85,33 @@ vmx_id <- function(x, prefix = NULL, arg = "id") { id } +# Validate a scalar or vector of non-blank strings without silently coercing +# numbers or other values into API text fields. +vmx_nonempty_strings <- function(x, arg, exactly_one = FALSE, + unique = FALSE) { + if (is.factor(x)) x <- as.character(x) + valid <- is.character(x) && length(x) > 0L && !anyNA(x) && + all(nzchar(trimws(x))) + if (!valid || (isTRUE(exactly_one) && length(x) != 1L)) { + count <- if (isTRUE(exactly_one)) { + "one non-empty string" + } else { + "one or more non-empty strings" + } + vmx_abort( + sprintf("`%s` must be %s.", arg, count), + class = "vmx_usage_error" + ) + } + if (isTRUE(unique) && anyDuplicated(x)) { + vmx_abort( + sprintf("`%s` must not contain duplicates.", arg), + class = "vmx_usage_error" + ) + } + as.character(x) +} + #' Convert a `DvTable` envelope (columns + row-objects) into a typed tibble #' #' Coerces each column per the server-declared type; column metadata is kept on @@ -66,10 +119,65 @@ vmx_id <- function(x, prefix = NULL, arg = "id") { #' @keywords internal #' @noRd vmx_dvtable_to_tibble <- function(tbl) { - cols <- tbl$columns %||% list() - rows <- tbl$rows %||% list() - names_ <- vapply(cols, function(col) col$name, character(1)) - data <- lapply(cols, function(col) vmx_coerce_col(lapply(rows, function(r) r[[col$name]]), col$type)) + cols <- vmx_response_field(tbl, "columns", "data-version table.columns") + rows <- vmx_response_field(tbl, "rows", "data-version table.rows") + if (!is.list(cols) || !is.null(names(cols)) || + !is.list(rows) || !is.null(names(rows))) { + vmx_abort_response( + "data-version table 'columns' and 'rows' must be arrays.", + field = "columns" + ) + } + names_ <- vapply(seq_along(cols), function(i) { + col <- cols[[i]] + vmx_response_scalar( + vmx_response_field(col, "name", sprintf("data-version table.columns[%d].name", i)), + sprintf("data-version table.columns[%d].name", i), + type = "character", + nonempty = TRUE + ) + }, character(1)) + if (anyDuplicated(names_)) { + vmx_abort_response( + "data-version table contains duplicate column names.", + field = "columns" + ) + } + types <- vapply(seq_along(cols), function(i) { + type <- vmx_response_scalar( + vmx_response_field(cols[[i]], "type", sprintf("data-version table.columns[%d].type", i)), + sprintf("data-version table.columns[%d].type", i), + type = "character", + nonempty = TRUE + ) + if (!type %in% c("string", "number", "integer", "boolean", "categorical")) { + vmx_abort_response( + "data-version table contains an unknown declared column type.", + field = "columns.type" + ) + } + type + }, character(1)) + for (i in seq_along(rows)) { + row <- rows[[i]] + if (!is.list(row) || is.null(names(row)) || + any(!nzchar(names(row))) || anyDuplicated(names(row)) || + !setequal(names(row), names_)) { + vmx_abort_response( + "data-version table row fields do not exactly match the declared columns.", + field = "rows" + ) + } + } + values <- lapply(seq_along(names_), function(j) { + lapply(seq_along(rows), function(i) { + row <- rows[[i]] + row[[names_[[j]]]] + }) + }) + data <- lapply(seq_along(cols), function(i) { + vmx_coerce_col(values[[i]], types[[i]]) + }) out <- tibble::as_tibble(stats::setNames(data, names_)) attr(out, "columns") <- cols out @@ -80,55 +188,35 @@ vmx_coerce_col <- function(vals, type) { is_na <- function(x) is.null(x) || length(x) == 0 switch( type %||% "string", - number = , - integer = vapply(vals, function(x) if (is_na(x)) NA_real_ else as.numeric(x), numeric(1)), - boolean = vapply(vals, function(x) if (is_na(x)) NA else as.logical(x), logical(1)), - vapply(vals, function(x) if (is_na(x)) NA_character_ else as.character(x), character(1)) + number = vapply(vals, function(x) { + if (is_na(x)) return(NA_real_) + vmx_response_scalar(x, "data-version table numeric cell", type = "numeric") + }, numeric(1)), + integer = vapply(vals, function(x) { + if (is_na(x)) return(NA_integer_) + value <- vmx_response_scalar( + x, "data-version table integer cell", type = "numeric" + ) + integer_value <- suppressWarnings(as.integer(value)) + if (is.na(integer_value) || value != integer_value) { + vmx_abort_response( + "data-version table integer cell is outside the supported integer range or is not an integer.", + field = "rows" + ) + } + integer_value + }, integer(1)), + boolean = vapply(vals, function(x) { + if (is_na(x)) return(NA) + vmx_response_scalar(x, "data-version table boolean cell", type = "logical") + }, logical(1)), + vapply(vals, function(x) { + if (is_na(x)) return(NA_character_) + vmx_response_scalar(x, "data-version table string cell", type = "character") + }, character(1)) ) } -#' Group the equal-length parallel arrays of a block into a tibble -#' -#' Data-driven: columns are the block elements whose length equals the modal -#' array length (the observation rows); nested / non-conforming elements (e.g. -#' quantile bands) are returned on the `"extra"` attribute rather than guessed -#' into columns. -#' @keywords internal -#' @noRd -vmx_columns_to_tibble <- function(block) { - if (!is.list(block) || is.null(names(block)) || !length(block)) return(tibble::tibble()) - col_len <- function(v) { - if (is.atomic(v) && !is.null(v)) return(length(v)) - if (is.list(v) && length(v) && all(vapply(v, function(e) length(e) <= 1, logical(1)))) return(length(v)) - NA_integer_ - } - lens <- vapply(block, col_len, integer(1)) - valid <- lens[!is.na(lens) & lens > 0] - if (!length(valid)) return(tibble::tibble()) - modal <- as.integer(names(sort(table(valid), decreasing = TRUE))[[1]]) - keep <- names(block)[!is.na(lens) & lens == modal] - cols <- lapply(keep, function(nm) vmx_simplify_col(block[[nm]])) - out <- tibble::as_tibble(stats::setNames(cols, keep)) - extra <- setdiff(names(block), keep) - if (length(extra)) attr(out, "extra") <- block[extra] - out -} - -# Coerce an atomic vector or list-of-scalars to a typed vector (NA for nulls). -vmx_simplify_col <- function(v) { - if (is.atomic(v)) return(v) - vals <- lapply(v, function(x) if (length(x) == 0) NULL else x[[1]]) - nonnull <- Filter(Negate(is.null), vals) - cls <- if (length(nonnull)) class(nonnull[[1]])[[1]] else "character" - if (cls %in% c("numeric", "double", "integer")) { - vapply(vals, function(x) if (is.null(x)) NA_real_ else as.numeric(x), numeric(1)) - } else if (cls == "logical") { - vapply(vals, function(x) if (is.null(x)) NA else as.logical(x), logical(1)) - } else { - vapply(vals, function(x) if (is.null(x)) NA_character_ else as.character(x), character(1)) - } -} - #' Resolve an optional id argument (`NULL` passes through) #' @keywords internal #' @noRd @@ -161,11 +249,58 @@ as_tibble.vmx_resource <- function(x, ...) { #' @keywords internal #' @noRd vmx_items_to_tibble <- function(items) { + if (!is.list(items) || !is.null(names(items))) { + vmx_abort_response("pagination field 'items' must be an array.", field = "items") + } if (!length(items)) return(tibble::tibble()) rows <- lapply(items, vmx_flatten_row) vctrs::vec_rbind(!!!rows) } +#' Convert one canonical API page into a tibble +#' +#' The cursor remains opaque and is attached for the internal paginator to +#' return unchanged on the next request. +#' @keywords internal +#' @noRd +vmx_page_to_tibble <- function(page, context = "collection response") { + if (!is.list(page) || is.null(names(page))) { + vmx_abort_response(sprintf("%s must be an object.", context), field = "page") + } + items <- vmx_response_field(page, "items", paste0(context, ".items")) + next_cursor <- vmx_response_field( + page, "next_cursor", paste0(context, ".next_cursor"), + allow_null = TRUE + ) + if (!is.null(next_cursor)) { + next_cursor <- vmx_response_scalar( + next_cursor, + paste0(context, ".next_cursor"), + type = "character", + nonempty = TRUE + ) + } + has_next_page <- vmx_response_scalar( + vmx_response_field(page, "has_next_page", paste0(context, ".has_next_page")), + paste0(context, ".has_next_page"), + type = "logical" + ) + if (!identical(has_next_page, !is.null(next_cursor))) { + vmx_abort_response( + sprintf("%s has inconsistent 'has_next_page' and 'next_cursor'.", context), + field = "has_next_page" + ) + } + out <- vmx_items_to_tibble(items) + attr(out, "next_cursor") <- next_cursor + attr(out, "has_next_page") <- has_next_page + attr(out, "vmx_metadata") <- page[setdiff( + names(page), + c("items", "next_cursor", "has_next_page") + )] + out +} + #' Flatten one resource dict into a single-row tibble #' #' Scalars become columns; one level of named sub-objects is flattened with a @@ -174,20 +309,139 @@ vmx_items_to_tibble <- function(items) { #' @keywords internal #' @noRd vmx_flatten_row <- function(item) { + if (!is.list(item) || is.null(names(item)) || !length(item) || + any(!nzchar(names(item))) || anyDuplicated(names(item))) { + vmx_abort_response("collection item must be a named object.", field = "items") + } flat <- list() + put <- function(name, value) { + if (name %in% names(flat)) { + vmx_abort_response( + "collection item contains fields that collide when flattened.", + field = name + ) + } + flat[[name]] <<- value + } for (nm in names(item)) { val <- item[[nm]] if (is.null(val)) { - flat[[nm]] <- NA + put(nm, NA) } else if (is.list(val) && !is.null(names(val)) && length(val)) { + if (any(!nzchar(names(val))) || anyDuplicated(names(val))) { + vmx_abort_response( + "collection item contains an invalid nested object.", + field = nm + ) + } for (sub in names(val)) { - flat[[paste0(nm, "_", sub)]] <- val[[sub]] %||% NA + nested <- val[[sub]] + put(paste0(nm, "_", sub), if (is.null(nested)) { + NA + } else if (!is.list(nested) && length(nested) == 1L) { + nested + } else { + list(nested) + }) } } else if (length(val) == 1 && !is.list(val)) { - flat[[nm]] <- val + put(nm, val) } else { - flat[[nm]] <- list(val) + put(nm, list(val)) } } tibble::as_tibble(flat) } + +# ---- Successful-response validation --------------------------------------- + +# Pull a required named response field. `allow_null` distinguishes an explicit +# JSON null from an absent field by checking the object's names first. +vmx_response_field <- function(x, name, path = name, allow_null = FALSE) { + if (!is.list(x) || is.null(names(x)) || anyDuplicated(names(x)) || + !name %in% names(x)) { + vmx_abort_response(sprintf("required field '%s' is missing.", path), field = path) + } + value <- x[[name]] + if (is.null(value) && !isTRUE(allow_null)) { + vmx_abort_response(sprintf("required field '%s' is null.", path), field = path) + } + value +} + +# Validate and coerce a JSON scalar without accepting an array and silently +# taking its first member. +vmx_response_scalar <- function(x, path, type = c("character", "numeric", "logical"), + nonempty = FALSE) { + type <- match.arg(type) + if (is.list(x) || length(x) != 1L || is.na(x)) { + vmx_abort_response(sprintf("field '%s' must be one %s value.", path, type), field = path) + } + valid <- switch( + type, + character = is.character(x), + numeric = is.numeric(x) && is.finite(x), + logical = is.logical(x) + ) + if (!isTRUE(valid)) { + vmx_abort_response(sprintf("field '%s' must be one %s value.", path, type), field = path) + } + if (isTRUE(nonempty) && type == "character" && !nzchar(trimws(x))) { + vmx_abort_response(sprintf("field '%s' must not be blank.", path), field = path) + } + switch(type, character = as.character(x), numeric = as.numeric(x), logical = as.logical(x)) +} + +# Validate and coerce a JSON array of scalars. Nullable arrays retain JSON null +# cells as typed NA; required estimate arrays reject them. +vmx_response_vector <- function(x, path, type = c("character", "numeric", "logical"), + size = NULL, nullable = FALSE) { + type <- match.arg(type) + if (!is.list(x) || !is.null(names(x))) { + vmx_abort_response(sprintf("field '%s' must be an array.", path), field = path) + } + if (!is.null(size) && length(x) != size) { + vmx_abort_response( + sprintf("field '%s' has length %d; expected %d.", path, length(x), size), + field = path + ) + } + missing_value <- switch(type, character = NA_character_, numeric = NA_real_, logical = NA) + values <- lapply(seq_along(x), function(i) { + value <- x[[i]] + missing <- is.null(value) || length(value) == 0L || + (!is.list(value) && length(value) == 1L && is.na(value)) + if (missing) { + if (isTRUE(nullable)) return(missing_value) + vmx_abort_response( + sprintf("field '%s' contains a null value.", path), + field = path + ) + } + vmx_response_scalar(value, path, type = type) + }) + switch( + type, + character = vapply(values, identity, character(1)), + numeric = vapply(values, identity, numeric(1)), + logical = vapply(values, identity, logical(1)) + ) +} + +# Verify that a response belongs to the resource requested by the caller before +# associating or reshaping its data. +vmx_validate_response_id <- function(x, field, expected, context) { + actual <- vmx_response_scalar( + vmx_response_field(x, field, paste0(context, ".", field)), + paste0(context, ".", field), + type = "character", + nonempty = TRUE + ) + if (!identical(actual, expected)) { + vmx_abort_response( + sprintf("%s field '%s' does not match the requested resource.", context, field), + field = field + ) + } + invisible(actual) +} diff --git a/R/simulation.R b/R/simulation.R index 43fde5c..c8b885f 100644 --- a/R/simulation.R +++ b/R/simulation.R @@ -7,15 +7,23 @@ #' @param fit A fit id (`mf_...`) or `vmx_model_fit`. #' @param dosing_text The dosing regimen text. #' @param scenario_name One or more scenario names. +#' @param wait If `TRUE`, block until parsing succeeds or fails. +#' @param ... Polling controls forwarded to [vmx_wait()]. #' @param client A `vmx_client`. #' @return A `vmx_dosing_input` (carries `dosing_input_id`). #' @export vmx_dosing_input <- function(fit, dosing_text, scenario_name, - client = vmx_client()) { + client = vmx_client(), wait = FALSE, ...) { + dosing_text <- vmx_nonempty_strings(dosing_text, "dosing_text", exactly_one = TRUE) + scenario_name <- vmx_nonempty_strings( + scenario_name, "scenario_name", unique = TRUE + ) body <- list(dosing_text = dosing_text, scenario_names = as.list(scenario_name)) data <- vmx_post(client, paste0("/model-fits/", vmx_id(fit, "mf", "fit"), "/simulation-dosing-inputs"), body) - new_vmx_resource(data, "vmx_dosing_input", "dosing_input_id") + input <- new_vmx_resource(data, "vmx_dosing_input", "dosing_input_id") + vmx_dosing_input_id(input) + if (isTRUE(wait)) vmx_wait(input, client = client, ...) else input } #' Dosing-input status @@ -24,7 +32,9 @@ vmx_dosing_input <- function(fit, dosing_text, scenario_name, #' @return A `vmx_dosing_input`. #' @export vmx_dosing_input_status <- function(dosing_input, client = vmx_client()) { - data <- vmx_get(client, paste0("/simulation-dosing-inputs/", vmx_dosing_input_id(dosing_input))) + input_id <- vmx_dosing_input_id(dosing_input) + data <- vmx_get(client, paste0("/simulation-dosing-inputs/", input_id)) + vmx_validate_response_id(data, "dosing_input_id", input_id, "dosing-input status") new_vmx_resource(data, "vmx_dosing_input", "dosing_input_id") } @@ -69,6 +79,7 @@ vmx_sim_existing_subject_from_text <- function(fit, dosing_text, subjects, idempotency_key = NULL, retried_from = NULL, min_timepoints = NULL, wait = FALSE, ..., client = vmx_client()) { + dosing_text <- vmx_nonempty_strings(dosing_text, "dosing_text", exactly_one = TRUE) body <- vmx_compact(list( dosing_text = dosing_text, subjects = vmx_rows_to_records(subjects, c("gen_subject_uuid", "subject_name")), @@ -120,6 +131,7 @@ vmx_sim_hypothetical_subject_from_text <- function(fit, dosing_text, subjects, idempotency_key = NULL, retried_from = NULL, min_timepoints = NULL, wait = FALSE, ..., client = vmx_client()) { + dosing_text <- vmx_nonempty_strings(dosing_text, "dosing_text", exactly_one = TRUE) body <- vmx_compact(list( dosing_text = dosing_text, subjects = vmx_hypothetical_records(subjects), @@ -148,6 +160,7 @@ vmx_sim_population <- function(fit, dosing_input, scenario_name, idempotency_key = NULL, retried_from = NULL, min_timepoints = NULL, wait = FALSE, ..., client = vmx_client()) { + scenario_name <- vmx_nonempty_strings(scenario_name, "scenario_name", exactly_one = TRUE) body <- vmx_compact(list( dosing_input_id = vmx_dosing_input_id(dosing_input), scenario_name = scenario_name, @@ -170,6 +183,8 @@ vmx_sim_population_from_text <- function(fit, dosing_text, scenario_name, idempotency_key = NULL, retried_from = NULL, min_timepoints = NULL, wait = FALSE, ..., client = vmx_client()) { + dosing_text <- vmx_nonempty_strings(dosing_text, "dosing_text", exactly_one = TRUE) + scenario_name <- vmx_nonempty_strings(scenario_name, "scenario_name", exactly_one = TRUE) body <- vmx_compact(list( dosing_text = dosing_text, scenario_name = scenario_name, @@ -183,10 +198,13 @@ vmx_sim_population_from_text <- function(fit, dosing_text, scenario_name, #' List simulation jobs for a model fit #' @param fit A fit id or `vmx_model_fit`. #' @param client A `vmx_client`. -#' @return A tibble. +#' @return A tibble containing all simulation jobs for the fit. #' @export vmx_sim_jobs <- function(fit, client = vmx_client()) { - vmx_items_to_tibble(vmx_paginate(client, paste0("/model-fits/", vmx_id(fit, "mf", "fit"), "/simulation-jobs"))) + vmx_paginate( + client, + paste0("/model-fits/", vmx_id(fit, "mf", "fit"), "/simulation-jobs") + ) } #' Simulation job status @@ -195,15 +213,17 @@ vmx_sim_jobs <- function(fit, client = vmx_client()) { #' @return A `vmx_simulation_job`. #' @export vmx_sim_status <- function(job, client = vmx_client()) { - data <- vmx_get(client, paste0("/simulation-jobs/", vmx_id(job, "simjob", "job"))) + job_id <- vmx_id(job, "simjob", "job") + data <- vmx_get(client, paste0("/simulation-jobs/", job_id)) + vmx_validate_response_id(data, "simulation_job_id", job_id, "simulation status") new_vmx_resource(data, "vmx_simulation_job", "simulation_job_id") } #' Simulation result #' #' `GET /simulation-jobs/{id}/result`. Returns the parsed result payload -#' (subject/time series with prediction bands). Tibble reshaping is deferred -#' pending confirmation of the artifact shape; see the package NEWS. +#' containing model-implied response trajectories with the server-provided +#' point statistic and interval. The nested wire shape is retained verbatim. #' #' @param job A job id or `vmx_simulation_job`. #' @param grouping_variable Optional server-side grouping. @@ -211,8 +231,19 @@ vmx_sim_status <- function(job, client = vmx_client()) { #' @return A list (the parsed result). #' @export vmx_sim_result <- function(job, grouping_variable = NULL, client = vmx_client()) { - vmx_get(client, paste0("/simulation-jobs/", vmx_id(job, "simjob", "job"), "/result"), - list(grouping_variable = grouping_variable)) + job_id <- vmx_id(job, "simjob", "job") + if (!is.null(grouping_variable)) { + grouping_variable <- vmx_nonempty_strings( + grouping_variable, "grouping_variable", exactly_one = TRUE + ) + } + out <- vmx_get( + client, + paste0("/simulation-jobs/", job_id, "/result"), + list(grouping_variable = grouping_variable) + ) + vmx_validate_sim_result(out, job, grouping_variable) + out } #' Cancel a simulation job @@ -221,43 +252,273 @@ vmx_sim_result <- function(job, grouping_variable = NULL, client = vmx_client()) #' @return A `vmx_simulation_job`. #' @export vmx_sim_cancel <- function(job, client = vmx_client()) { - data <- vmx_post(client, paste0("/simulation-jobs/", vmx_id(job, "simjob", "job"), "/cancel")) + job_id <- vmx_id(job, "simjob", "job") + data <- vmx_post(client, paste0("/simulation-jobs/", job_id, "/cancel")) + vmx_validate_response_id(data, "simulation_job_id", job_id, "simulation cancellation") new_vmx_resource(data, "vmx_simulation_job", "simulation_job_id") } # -- internals --------------------------------------------------------------- vmx_create_sim_job <- function(fit, endpoint, body, wait, client, ...) { - data <- vmx_post(client, paste0("/model-fits/", vmx_id(fit, "mf", "fit"), "/", endpoint), body) + fit_id <- vmx_id(fit, "mf", "fit") + if ("min_timepoints" %in% names(body)) { + body$min_timepoints <- vmx_sim_min_timepoints(body$min_timepoints) + } + if ("idempotency_key" %in% names(body)) { + vmx_id_like_scalar(body$idempotency_key, "idempotency_key") + } + if ("retried_from" %in% names(body)) { + body$retried_from <- vmx_id( + body$retried_from, "simjob", "retried_from" + ) + } + data <- vmx_post( + client, paste0("/model-fits/", fit_id, "/", endpoint), body + ) + vmx_validate_response_id( + data, "model_fit_id", fit_id, "simulation creation" + ) job <- new_vmx_resource(data, "vmx_simulation_job", "simulation_job_id") if (isTRUE(wait)) vmx_wait(job, client = client, ...) else job } vmx_dosing_input_id <- function(x) { - if (inherits(x, "vmx_resource")) return(vmx_resource_id(x)) - vmx_id(x, NULL, "dosing_input") + id <- if (inherits(x, "vmx_resource")) vmx_resource_id(x) else x + vmx_id(id, "simdose", "dosing_input") } -# data.frame -> list of records with the named columns; pass a list through. +# data.frame -> validated list of records with exactly the named columns. vmx_rows_to_records <- function(x, cols) { if (is.data.frame(x)) { - lapply(seq_len(nrow(x)), function(i) lapply(cols, function(cn) x[[cn]][[i]]) |> stats::setNames(cols)) - } else { - x + missing <- setdiff(cols, names(x)) + extra <- setdiff(names(x), cols) + if (length(missing) || length(extra)) { + vmx_abort( + sprintf( + "`subjects` must have exactly these columns: %s.", + paste(cols, collapse = ", ") + ), + class = "vmx_usage_error" + ) + } + if (!nrow(x)) { + vmx_abort("`subjects` must contain at least one row.", + class = "vmx_usage_error") + } + return(lapply(seq_len(nrow(x)), function(i) { + stats::setNames( + lapply(cols, function(cn) vmx_subject_string(x[[cn]][[i]], paste0("subjects$", cn))), + cols + ) + })) + } + if (!is.list(x) || !length(x)) { + vmx_abort("`subjects` must be a non-empty data frame or list of records.", + class = "vmx_usage_error") } + lapply(seq_along(x), function(i) { + record <- x[[i]] + if (!is.list(record) || is.null(names(record)) || + !setequal(names(record), cols) || anyDuplicated(names(record))) { + vmx_abort( + sprintf( + "`subjects[[%d]]` must have exactly these fields: %s.", + i, paste(cols, collapse = ", ") + ), + class = "vmx_usage_error" + ) + } + stats::setNames( + lapply(cols, function(cn) { + vmx_subject_string(record[[cn]], sprintf("subjects[[%d]]$%s", i, cn)) + }), + cols + ) + }) } # data.frame with subject_name + covariate columns -> {subject_name, covariates} vmx_hypothetical_records <- function(x) { if (is.data.frame(x)) { + if (!"subject_name" %in% names(x) || anyDuplicated(names(x))) { + vmx_abort( + "`subjects` must have one `subject_name` column plus optional covariate columns.", + class = "vmx_usage_error" + ) + } + if (!nrow(x)) { + vmx_abort("`subjects` must contain at least one row.", + class = "vmx_usage_error") + } covcols <- setdiff(names(x), "subject_name") - lapply(seq_len(nrow(x)), function(i) { + return(lapply(seq_len(nrow(x)), function(i) { list( - subject_name = x[["subject_name"]][[i]], - covariates = lapply(covcols, function(cn) x[[cn]][[i]]) |> stats::setNames(covcols) + subject_name = vmx_subject_string( + x[["subject_name"]][[i]], "subjects$subject_name" + ), + covariates = lapply(covcols, function(cn) { + vmx_covariate_value(x[[cn]][[i]], paste0("subjects$", cn)) + }) |> stats::setNames(covcols) + ) + })) + } + if (!is.list(x) || !length(x)) { + vmx_abort("`subjects` must be a non-empty data frame or list of records.", + class = "vmx_usage_error") + } + lapply(seq_along(x), function(i) { + record <- x[[i]] + if (!is.list(record) || is.null(names(record)) || + !setequal(names(record), c("subject_name", "covariates")) || + anyDuplicated(names(record))) { + vmx_abort( + sprintf( + "`subjects[[%d]]` must have exactly `subject_name` and `covariates`.", + i + ), + class = "vmx_usage_error" + ) + } + covariates <- record$covariates + if (!is.list(covariates) || + (length(covariates) && (is.null(names(covariates)) || + anyDuplicated(names(covariates)) || any(!nzchar(names(covariates)))))) { + vmx_abort( + sprintf("`subjects[[%d]]$covariates` must be a named list.", i), + class = "vmx_usage_error" + ) + } + list( + subject_name = vmx_subject_string( + record$subject_name, sprintf("subjects[[%d]]$subject_name", i) + ), + covariates = lapply(seq_along(covariates), function(j) { + vmx_covariate_value( + covariates[[j]], + sprintf("subjects[[%d]]$covariates$%s", i, names(covariates)[[j]]) + ) + }) |> stats::setNames(names(covariates)) + ) + }) +} + +vmx_subject_string <- function(x, arg) { + if (is.factor(x)) x <- as.character(x) + vmx_nonempty_strings(x, arg, exactly_one = TRUE) + as.character(x) +} + +vmx_covariate_value <- function(x, arg) { + if (is.factor(x)) x <- as.character(x) + valid_type <- is.character(x) || is.logical(x) || is.numeric(x) + if (!valid_type || length(x) != 1L || is.na(x) || + (is.numeric(x) && !is.finite(x))) { + vmx_abort( + sprintf("`%s` must be one non-missing string, number, or logical value.", arg), + class = "vmx_usage_error" + ) + } + x +} + +vmx_sim_min_timepoints <- function(x) { + if (!is.numeric(x) || length(x) != 1L || is.na(x) || + !is.finite(x) || x != floor(x) || x < 10L || x > 600L) { + vmx_abort( + "`min_timepoints` must be one integer between 10 and 600.", + class = "vmx_usage_error" + ) + } + as.integer(x) +} + +vmx_validate_sim_result <- function(x, job, grouping_variable) { + if (!is.list(x) || is.null(names(x)) || anyDuplicated(names(x))) { + vmx_abort_response( + "simulation result must be an object.", + field = "simulation_result" + ) + } + for (field in c( + "schema_version", "simulation_version_id", "model_fit_id", "model_type", + "time_basis", "simulation_kind" + )) { + value <- vmx_response_scalar( + vmx_response_field(x, field, paste0("simulation result.", field)), + paste0("simulation result.", field), + type = "character", + nonempty = TRUE + ) + if (field == "simulation_version_id") { + vmx_id(value, "sv", field) + } else if (field == "model_fit_id") { + vmx_id(value, "mf", field) + } + } + if (!x$model_type %in% c("pk", "pd")) { + vmx_abort_response( + "field 'simulation result.model_type' must be 'pk' or 'pd'.", + field = "model_type" + ) + } + if (!x$simulation_kind %in% + c("existing_subject", "hypothetical_subject", "population")) { + vmx_abort_response( + "field 'simulation result.simulation_kind' is unknown.", + field = "simulation_kind" + ) + } + series <- vmx_response_field(x, "series", "simulation result.series") + quantities <- vmx_response_field( + x, "quantities", "simulation result.quantities" + ) + if (!is.list(series) || !is.null(names(series))) { + vmx_abort_response( + "field 'simulation result.series' must be an array.", + field = "series" + ) + } + if (!is.list(quantities) || + (length(quantities) && is.null(names(quantities))) || + anyDuplicated(names(quantities))) { + vmx_abort_response( + "field 'simulation result.quantities' must be an object.", + field = "quantities" + ) + } + for (i in seq_along(series)) { + if (!is.list(series[[i]]) || is.null(names(series[[i]])) || + anyDuplicated(names(series[[i]]))) { + vmx_abort_response( + "each simulation result series entry must be an object.", + field = "series" + ) + } + } + if (inherits(job, "vmx_resource") && !is.null(job[["model_fit_id"]])) { + vmx_validate_response_id( + x, + "model_fit_id", + vmx_id(job[["model_fit_id"]], "mf", "job$model_fit_id"), + "simulation result" + ) + } + if (!is.null(grouping_variable)) { + returned_grouping <- vmx_response_scalar( + vmx_response_field( + x, "grouping_variable", "simulation result.grouping_variable" + ), + "simulation result.grouping_variable", + type = "character", + nonempty = TRUE + ) + if (!identical(returned_grouping, grouping_variable)) { + vmx_abort_response( + "simulation result grouping does not match the requested grouping.", + field = "grouping_variable" ) - }) - } else { - x + } } + invisible(x) } diff --git a/R/studies.R b/R/studies.R index 6a80d91..9537cc1 100644 --- a/R/studies.R +++ b/R/studies.R @@ -4,15 +4,19 @@ #' @param treatment A treatment id (`tmt_...`) or `vmx_treatment`; `NULL` lists #' across all treatments. #' @param status Optional status filter. +#' @param created_since Optional lower creation-time bound: a +#' `POSIXct`/`Date` or ISO-8601 string. #' @param client A `vmx_client`. -#' @return A tibble, one row per study. +#' @return A tibble containing all matching studies. #' @export -vmx_studies <- function(treatment = NULL, status = NULL, client = vmx_client()) { +vmx_studies <- function(treatment = NULL, status = NULL, client = vmx_client(), + created_since = NULL) { params <- list( treatment_id = vmx_opt_id(treatment, "tmt", "treatment"), - status = status + status = status, + created_since = vmx_format_time(created_since, arg = "created_since") ) - vmx_items_to_tibble(vmx_paginate(client, "/studies", params)) + vmx_paginate(client, "/studies", params) } #' Fetch one study @@ -21,7 +25,9 @@ vmx_studies <- function(treatment = NULL, status = NULL, client = vmx_client()) #' @return A `vmx_study`. #' @export vmx_study <- function(id, client = vmx_client()) { - data <- vmx_get(client, paste0("/studies/", vmx_id(id, "std"))) + study_id <- vmx_id(id, "std") + data <- vmx_get(client, paste0("/studies/", study_id)) + vmx_validate_response_id(data, "study_id", study_id, "study") new_vmx_resource(data, "vmx_study", "study_id") } @@ -37,16 +43,46 @@ vmx_study <- function(id, client = vmx_client()) { #' @export vmx_study_create <- function(treatment, name, study_type = "clinical", phase = NULL, ..., client = vmx_client()) { + treatment_id <- vmx_id(treatment, "tmt", "treatment") + name <- vmx_nonempty_strings(name, "name", exactly_one = TRUE) + if (!is.null(study_type)) { + study_type <- vmx_nonempty_strings( + study_type, "study_type", exactly_one = TRUE + ) + } + if (!is.null(phase)) { + phase <- vmx_nonempty_strings(phase, "phase", exactly_one = TRUE) + } + extra <- list(...) + if (length(extra)) { + vmx_validate_update_body( + extra, + allowed = c("description", "route_of_administration", "pd_markers"), + nullable = c("description", "route_of_administration"), + resource = "study creation" + ) + } + if ("pd_markers" %in% names(extra) && + (!is.list(extra$pd_markers) || !is.null(names(extra$pd_markers)))) { + vmx_abort( + "`pd_markers` must be an array of marker objects.", + class = "vmx_usage_error" + ) + } body <- vmx_compact(c( list( - treatment_id = vmx_id(treatment, "tmt", "treatment"), + treatment_id = treatment_id, name = name, study_type = study_type, phase = phase ), - list(...) + extra )) - new_vmx_resource(vmx_post(client, "/studies", body), "vmx_study", "study_id") + data <- vmx_post(client, "/studies", body) + vmx_validate_response_id( + data, "treatment_id", treatment_id, "study creation" + ) + new_vmx_resource(data, "vmx_study", "study_id") } #' Update a study @@ -59,7 +95,29 @@ vmx_study_create <- function(treatment, name, study_type = "clinical", #' @return A `vmx_study`. #' @export vmx_study_update <- function(id, ..., client = vmx_client()) { - body <- vmx_compact(list(...)) - data <- vmx_put(client, paste0("/studies/", vmx_id(id, "std")), body) + # Preserve explicit NULL so callers can clear nullable set-the-field values + # such as route_of_administration; omitted arguments remain absent. + body <- list(...) + vmx_validate_update_body( + body, + allowed = c( + "name", "description", "study_type", "phase", "status", + "route_of_administration", "pd_markers" + ), + nullable = c( + "description", "study_type", "phase", "route_of_administration" + ), + resource = "study" + ) + if ("pd_markers" %in% names(body) && + (!is.list(body$pd_markers) || !is.null(names(body$pd_markers)))) { + vmx_abort( + "`pd_markers` must be an array of marker objects; use `list()` to clear it.", + class = "vmx_usage_error" + ) + } + study_id <- vmx_id(id, "std") + data <- vmx_put(client, paste0("/studies/", study_id), body) + vmx_validate_response_id(data, "study_id", study_id, "study update") new_vmx_resource(data, "vmx_study", "study_id") } diff --git a/R/treatments.R b/R/treatments.R index c087cfb..cfa35f1 100644 --- a/R/treatments.R +++ b/R/treatments.R @@ -3,11 +3,10 @@ #' List treatments #' @param status Optional status filter. #' @param client A `vmx_client`. -#' @return A tibble, one row per treatment. +#' @return A tibble containing all matching treatments. #' @export vmx_treatments <- function(status = NULL, client = vmx_client()) { - items <- vmx_paginate(client, "/treatments", list(status = status)) - vmx_items_to_tibble(items) + vmx_paginate(client, "/treatments", list(status = status)) } #' Fetch one treatment @@ -16,7 +15,9 @@ vmx_treatments <- function(status = NULL, client = vmx_client()) { #' @return A `vmx_treatment`. #' @export vmx_treatment <- function(id, client = vmx_client()) { - data <- vmx_get(client, paste0("/treatments/", vmx_id(id, "tmt"))) + treatment_id <- vmx_id(id, "tmt") + data <- vmx_get(client, paste0("/treatments/", treatment_id)) + vmx_validate_response_id(data, "treatment_id", treatment_id, "treatment") new_vmx_resource(data, "vmx_treatment", "treatment_id") } @@ -29,6 +30,17 @@ vmx_treatment <- function(id, client = vmx_client()) { #' @export vmx_treatment_create <- function(name, indication = NULL, description = NULL, client = vmx_client()) { + name <- vmx_nonempty_strings(name, "name", exactly_one = TRUE) + if (!is.null(indication)) { + indication <- vmx_nonempty_strings( + indication, "indication", exactly_one = TRUE + ) + } + if (!is.null(description)) { + description <- vmx_nonempty_strings( + description, "description", exactly_one = TRUE + ) + } body <- vmx_compact(list(name = name, indication = indication, description = description)) new_vmx_resource(vmx_post(client, "/treatments", body), "vmx_treatment", "treatment_id") @@ -44,7 +56,54 @@ vmx_treatment_create <- function(name, indication = NULL, description = NULL, #' @return A `vmx_treatment`. #' @export vmx_treatment_update <- function(id, ..., client = vmx_client()) { - body <- vmx_compact(list(...)) - data <- vmx_put(client, paste0("/treatments/", vmx_id(id, "tmt")), body) + # Do not compact this body: an explicitly supplied NULL is JSON null and + # clears nullable fields; an omitted argument is absent from list(...). + body <- list(...) + vmx_validate_update_body( + body, + allowed = c("name", "indication", "description", "status"), + nullable = c("indication", "description"), + resource = "treatment" + ) + treatment_id <- vmx_id(id, "tmt") + data <- vmx_put(client, paste0("/treatments/", treatment_id), body) + vmx_validate_response_id( + data, "treatment_id", treatment_id, "treatment update" + ) new_vmx_resource(data, "vmx_treatment", "treatment_id") } + +vmx_validate_update_body <- function(body, allowed, nullable, resource) { + fields <- names(body) + if (is.null(fields) || any(!nzchar(fields)) || anyDuplicated(fields)) { + vmx_abort( + sprintf("The %s update must use unique named fields.", resource), + class = "vmx_usage_error" + ) + } + unknown <- setdiff(fields, allowed) + if (length(unknown)) { + vmx_abort( + sprintf( + "Unknown %s update field%s: %s.", + resource, + if (length(unknown) == 1L) "" else "s", + paste(unknown, collapse = ", ") + ), + class = "vmx_usage_error" + ) + } + invalid_null <- fields[vapply(body, is.null, logical(1)) & !fields %in% nullable] + if (length(invalid_null)) { + vmx_abort( + sprintf( + "%s update field%s cannot be NULL: %s.", + tools::toTitleCase(resource), + if (length(invalid_null) == 1L) "" else "s", + paste(invalid_null, collapse = ", ") + ), + class = "vmx_usage_error" + ) + } + invisible(body) +} diff --git a/R/workflow.R b/R/workflow.R index 1b09578..3d4aaf9 100644 --- a/R/workflow.R +++ b/R/workflow.R @@ -4,41 +4,75 @@ #' Audit / analysis log for a study #' -#' `GET /studies/{std_id}/analysis-log` — the unified newest-first event feed, -#' auto-paginated into a tibble with a `kind` discriminator per row. +#' `GET /studies/{std_id}/analysis-log` — the complete unified newest-first +#' event feed, with a `kind` discriminator per row. #' #' @param study A study id (`std_...`) or `vmx_study`. #' @param kind Optional kind filter. #' @param event_type Optional event-type filter. +#' @param event_code Optional event-code filter. #' @param outcome Optional outcome filter. #' @param severity Optional severity filter. +#' @param requires_staff_review Optional staff-review filter. #' @param since Optional lower time bound: a `POSIXct`/`Date` (formatted to #' ISO-8601 UTC) or an ISO-8601 string. #' @param resource Optional resource id (or object) to scope to. #' @param client A `vmx_client`. -#' @return A tibble. +#' @return A tibble containing all matching events, newest first. #' @export vmx_analysis_log <- function(study, kind = NULL, event_type = NULL, - outcome = NULL, severity = NULL, since = NULL, - resource = NULL, client = vmx_client()) { + outcome = NULL, severity = NULL, + since = NULL, resource = NULL, + client = vmx_client(), event_code = NULL, + requires_staff_review = NULL) { + study_id <- vmx_id(study, "std") resource_id <- if (inherits(resource, "vmx_resource")) vmx_resource_id(resource) else resource params <- list( kind = kind, event_type = event_type, + event_code = event_code, outcome = outcome, severity = severity, + requires_staff_review = requires_staff_review, since = vmx_format_time(since), resource_id = resource_id ) - vmx_items_to_tibble(vmx_paginate(client, paste0("/studies/", vmx_id(study, "std"), "/analysis-log"), params)) + path <- paste0("/studies/", study_id, "/analysis-log") + vmx_paginate( + client, + path, + params, + validate_page = function(page) { + vmx_validate_response_id(page, "study_id", study_id, "analysis log") + } + ) } # Format a time filter to ISO-8601 UTC; pass character through unchanged. -vmx_format_time <- function(x) { +vmx_format_time <- function(x, arg = "since") { if (is.null(x)) return(NULL) if (inherits(x, c("POSIXct", "POSIXt", "Date"))) { - format(as.POSIXct(x, tz = "UTC"), "%Y-%m-%dT%H:%M:%SZ", tz = "UTC") - } else { - as.character(x) + if (length(x) != 1L || is.na(x)) { + vmx_abort( + sprintf("`%s` must be one non-missing date-time.", arg), + class = "vmx_usage_error" + ) + } + return(format( + as.POSIXct(x, tz = "UTC"), + "%Y-%m-%dT%H:%M:%SZ", + tz = "UTC" + )) + } + if (!is.character(x) || length(x) != 1L || is.na(x) || + !nzchar(trimws(x))) { + vmx_abort( + sprintf( + "`%s` must be one non-empty ISO-8601 string or date-time.", + arg + ), + class = "vmx_usage_error" + ) } + x } diff --git a/README.md b/README.md index 7a757d1..0902089 100644 --- a/README.md +++ b/README.md @@ -12,10 +12,11 @@ modeling → simulation workflow in ergonomic, pipe-friendly verbs that Our users are pharmacometricians who work in R/RStudio; `vmxr` keeps the whole analysis next to their data instead of shuttling files and IDs through a shell. -> **Status: functional (v0.1.1), pre-CRAN.** The client covers the full analysis -> workflow end to end — treatments, studies, datasets & prep, data-versions, +> **Status: functional (v0.2.0), pre-CRAN.** The client covers the full analysis +> workflow end to end — treatments, studies, datasets and prep, data versions, > modeling-data tables, NCA, modeling (build runs, fits, estimates), simulation, -> and the study analysis log — validated against the live API on staging. +> and the study analysis log. Contract-shaped responses are covered by the +> package test suite; a separate live smoke test is opt-in. > Deferred: the nlmixr2 / Stan·Torsten data adapters (`vmx_nlmixr_data()`, > `vmx_torsten_data()`), `vmx_dataset_download()`, and VPC-artifact tibble > reshaping — each needs validation against real data first and currently raises @@ -31,7 +32,7 @@ Targets **API `0.2.x` / CLI `0.6.x`**. | Connect / identity | `vmx_client()`, `vmx_whoami()`, `vmx_health()` | | Treatments / studies | `vmx_treatments()`, `vmx_study_create()`, … | | Upload & prep | `vmx_upload()`, `vmx_prep_status()`, `vmx_prep_questions()`, `vmx_prep_answer()`, `vmx_wait()` | -| Data versions | `vmx_data_versions()`, `vmx_data_version_create()`, `vmx_data_version_table()`, `vmx_subjects()`/`vmx_pk()`/`vmx_pd()`, `vmx_model_data()` | +| Data versions | `vmx_data_versions()`, `vmx_data_version_create()`, `vmx_data_version_table()`, `vmx_subjects()`/`vmx_pk()`/`vmx_dosing()`/`vmx_pd()`, `vmx_model_data()` | | NCA | `vmx_nca()`, `vmx_nca_result()` | | Modeling | `vmx_model_build()`, `vmx_model_fits()`, `vmx_fit_subject_estimates()`, `vmx_fit_global_estimates()`, `vmx_fit_obs_vs_pred()` | | Simulation | `vmx_dosing_input()`, `vmx_sim_population()`, `vmx_sim_result()` | @@ -73,10 +74,10 @@ environment variables — the same ones the `vmx` CLI reads — and call `vmx_login()`: ```r -# ~/.Renviron (or the workspace image sets these for you) -# VMX_API_BASE_URL = https://vmx-api.staging.gnrbl.co -# VMX_OIDC_ISSUER = https://auth.staging.gnrbl.co/application/o/generable-staging-vmx-cli/ -# VMX_OIDC_CLIENT_ID = generable-staging-vmx-cli +# ~/.Renviron (normally provisioned by the workspace) +# VMX_API_BASE_URL = +# VMX_OIDC_ISSUER = +# VMX_OIDC_CLIENT_ID = library(vmxr) vmx_login() # opens the approve page in a browser; approve once @@ -87,14 +88,17 @@ vmx_whoami() # vmx_client() now auto-authenticates from the cached token (the CLI's path and shape, `0600`), so **one login serves both R and the terminal CLI**. The refresh token is persisted on your home directory, so the access token is refreshed silently and the login **survives R / workspace -restarts** — you sign in roughly once a month. When no `VMX_API_TOKEN` is set, +restarts** for the provider-configured refresh-token lifetime. When no +`VMX_API_TOKEN` is set, `vmx_client()` (and every verb that builds one) authenticates from this cache automatically, prompting `vmx_login()` only when there's no usable cached token. ## Design The package exposes a curated, hand-written public API in `R/*.R` that adds -polling, pagination, multipart upload, and tibble/S3 conversion. The OpenAPI +polling, automatic cursor pagination, multipart upload, and tibble/S3 +conversion. Collection functions return all matching rows while keeping +server cursors opaque. The OpenAPI snapshot/codegen path is still a development task, not a shipped generated binding layer. @@ -102,4 +106,4 @@ The client holds **no business logic**: the API is the single source of truth. ## License -Proprietary — © Generable. See [LICENSE](LICENSE). +Apache License 2.0 — © Generable. See [LICENSE.md](LICENSE.md). diff --git a/docs/r-client-design.md b/docs/r-client-design.md index 7cd52ab..8045f8e 100644 --- a/docs/r-client-design.md +++ b/docs/r-client-design.md @@ -1,6 +1,7 @@ # VeloMetrix R client — design proposal -**Status:** accepted — package scaffolded in this repo (`generable/vmxr`) +**Status:** historical design record — package implemented in this repo +(`generable/vmxr`) **Author:** (proposed) **Related:** [vmx-services `clients/cli/`](https://github.com/generable/vmx-services/tree/main/clients/cli), [vmx-services PR #198](https://github.com/generable/vmx-services/pull/198) @@ -13,6 +14,10 @@ > review; where they still say "recommend `clients/r/`" read them as the > rejected alternative, with §2's reviewer note as the rationale for the > standalone choice. +> +> This document records the original proposal and is not the current API +> reference. The package function documentation and README describe shipped +> behavior; the authoritative wire semantics live in `vmx-contracts`. ## 1. Motivation @@ -36,7 +41,7 @@ workflow inside the R session next to the user's data. - First-class R client covering the full analysis workflow (treatments → studies → datasets → data-versions → NCA → modeling → simulation). -- Ergonomic, pipe-friendly verbs that hide async polling and pagination. +- Ergonomic, pipe-friendly verbs that hide async polling and cursor pagination. - Native return types: tibbles for collections, typed S3 objects for resources. - One auth model, identical to the CLI (`VMX_API_TOKEN` Authentik PAT). - **No business logic** — the API stays the single source of truth; the client @@ -167,8 +172,9 @@ clients/r/ (`op_datasets_upload()`, `op_treatments_list()`, …). Mechanical: build request, send, parse JSON to a list, surface HTTP errors. Regenerated whenever `openapi.json` changes. Users normally never call these directly. -- **Ergonomic (`R/*.R`)** — the curated public API. Adds polling, pagination, - multipart upload, tibble/S3 conversion, and the workflow verbs. This layer is +- **Ergonomic (`R/*.R`)** — the curated public API. Adds polling, automatic + cursor pagination, multipart upload, tibble/S3 conversion, and the + workflow verbs. This layer is small, stable, and is what the docs and vignettes teach. > **Codegen caveat (decide early).** The API emits **OpenAPI 3.1**. R generator @@ -221,13 +227,14 @@ in the object but **redacted in `print()`** and never logged. (`"ds_…"`) or the S3 object returned by a prior call. ID prefixes are validated client-side (matching the CLI's fail-fast behavior). - **Return types:** - - Collection endpoints → **tibble** (one row per item; list-columns for nested - fields), auto-paginated across `next_cursor` by default. + - Collection endpoints → **tibble** containing all matching rows (one row per + item; list-columns for nested fields), with opaque server cursors followed + automatically. - Single resource → typed **S3 object** (`vmx_treatment`, `vmx_dataset`, `vmx_data_version`, `vmx_nca_analysis`, …) with `print`/`format`/`as_tibble` methods. - - Raw escape hatch: every verb takes `.raw = TRUE` to return the parsed list - untouched. + - Nested artifact endpoints return their parsed list shape unchanged where a + stable tidy projection is not defined. - **Async:** any verb that kicks off server work returns immediately with a handle; `vmx_wait()` blocks and polls. Convenience verbs (`vmx_*_sync()` or a `wait = TRUE` arg) do both. @@ -293,7 +300,7 @@ vmx_prep_status(dataset, client = vmx_client()) # -> vmx_prep_status (state, d # dataset, data-version, model-build-run, simulation-job. vmx_wait(x, until = NULL, # target terminal state(s); sensible default per type - timeout = 900, # seconds + timeout = 900, # methods use worker-aligned defaults interval = 5, progress = interactive(), # show a CLI progress bar client = vmx_client()) # -> updated object, or vmx_timeout_error @@ -333,10 +340,11 @@ ecosystem adapters are where the convenience lives. #### Tidy accessors ```r -# One fetch -> three tidy tables + the metadata modelers need -md <- vmx_model_data(dv) # vmx_model_data: $subjects $pk $pd $meta +# One call -> available tidy tables + the metadata modelers need +md <- vmx_model_data(dv) # $subjects $pk $dosing $pd $meta md$subjects # one row/subject: id, covariates (WT, AGE, SEX, CRCL, ...) -md$pk # long obs+events: id, time, dv, amt, evid, cmt, mdv, rate, blq, lloq, analyte +md$pk # PK observations +md$dosing # dosing events md$pd # long: id, time, dv, marker (GEN_uuid -> name), ... md$meta # units, lloq, time_basis, analyte/marker manifest, id map, dv hash @@ -393,8 +401,7 @@ gets wrong. Build it once, correctly. #### API support this assumes - **Separate typed sub-table endpoints** rather than one flat table: - `GET /data-versions/{id}/{subjects|pk|pd}` with server-side filtering (by - analyte/marker/subject), pagination, and **Arrow/Parquet content negotiation**. + `GET /data-versions/{id}/tables/{subjects|pk|dosing|pd|labs|covariates}`. - **A manifest** on the DataVersion: analytes, PD markers (`GEN_uuid` → human name), units, LLOQ, compartment map, dose routes, available time bases — the adapters read this to assemble correct `CMT`/`RATE`/censoring without guessing. diff --git a/man/vmx_analysis_log.Rd b/man/vmx_analysis_log.Rd index 5677323..98a2421 100644 --- a/man/vmx_analysis_log.Rd +++ b/man/vmx_analysis_log.Rd @@ -12,7 +12,9 @@ vmx_analysis_log( severity = NULL, since = NULL, resource = NULL, - client = vmx_client() + client = vmx_client(), + event_code = NULL, + requires_staff_review = NULL ) } \arguments{ @@ -32,11 +34,15 @@ ISO-8601 UTC) or an ISO-8601 string.} \item{resource}{Optional resource id (or object) to scope to.} \item{client}{A \code{vmx_client}.} + +\item{event_code}{Optional event-code filter.} + +\item{requires_staff_review}{Optional staff-review filter.} } \value{ -A tibble. +A tibble containing all matching events, newest first. } \description{ -\code{GET /studies/{std_id}/analysis-log} — the unified newest-first event feed, -auto-paginated into a tibble with a \code{kind} discriminator per row. +\code{GET /studies/{std_id}/analysis-log} — the complete unified newest-first +event feed, with a \code{kind} discriminator per row. } diff --git a/man/vmx_client.Rd b/man/vmx_client.Rd index 2986e16..d41288c 100644 --- a/man/vmx_client.Rd +++ b/man/vmx_client.Rd @@ -25,7 +25,7 @@ Resolves connection config with the precedence: explicit args -> \code{\link[=print]{print()}} and never logged. } \details{ -When no token is supplied (neither \code{token=} nor \code{VMX_API_TOKEN}), the client +When no token is supplied (neither \verb{token=} nor \code{VMX_API_TOKEN}), the client \strong{auto-authenticates} via OIDC: it reads the token cached by \code{\link[=vmx_login]{vmx_login()}} (\verb{~/.config/vmx/oidc-token.json}), refreshing it silently when expired, and -- in an interactive session -- running \code{\link[=vmx_login]{vmx_login()}} if there is no usable diff --git a/man/vmx_data_versions.Rd b/man/vmx_data_versions.Rd index 2573f7f..063ab20 100644 --- a/man/vmx_data_versions.Rd +++ b/man/vmx_data_versions.Rd @@ -24,7 +24,7 @@ vmx_data_versions( \item{client}{A \code{vmx_client}.} } \value{ -A tibble. +A tibble containing all matching data versions. } \description{ List data versions diff --git a/man/vmx_dataset_files.Rd b/man/vmx_dataset_files.Rd index 94715d1..837cae5 100644 --- a/man/vmx_dataset_files.Rd +++ b/man/vmx_dataset_files.Rd @@ -12,7 +12,7 @@ vmx_dataset_files(dataset, client = vmx_client()) \item{client}{A \code{vmx_client}.} } \value{ -A tibble. +A tibble containing all files in the dataset. } \description{ List the files in a dataset diff --git a/man/vmx_datasets.Rd b/man/vmx_datasets.Rd index 07fc868..ab780ff 100644 --- a/man/vmx_datasets.Rd +++ b/man/vmx_datasets.Rd @@ -14,7 +14,7 @@ vmx_datasets(study = NULL, treatment = NULL, client = vmx_client()) \item{client}{A \code{vmx_client}.} } \value{ -A tibble. +A tibble containing all matching datasets. } \description{ List datasets diff --git a/man/vmx_dosing.Rd b/man/vmx_dosing.Rd new file mode 100644 index 0000000..03a14a9 --- /dev/null +++ b/man/vmx_dosing.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data_versions.R +\name{vmx_dosing} +\alias{vmx_dosing} +\title{Dosing events table} +\usage{ +vmx_dosing(dv, client = vmx_client()) +} +\arguments{ +\item{dv}{A data-version id or \code{vmx_data_version}.} + +\item{client}{A \code{vmx_client}.} +} +\value{ +A tibble. +} +\description{ +Dosing events table +} diff --git a/man/vmx_dosing_input.Rd b/man/vmx_dosing_input.Rd index 9f236dc..0f7f892 100644 --- a/man/vmx_dosing_input.Rd +++ b/man/vmx_dosing_input.Rd @@ -4,7 +4,14 @@ \alias{vmx_dosing_input} \title{Create a dosing input for a fit} \usage{ -vmx_dosing_input(fit, dosing_text, scenario_name, client = vmx_client()) +vmx_dosing_input( + fit, + dosing_text, + scenario_name, + client = vmx_client(), + wait = FALSE, + ... +) } \arguments{ \item{fit}{A fit id (\code{mf_...}) or \code{vmx_model_fit}.} @@ -14,6 +21,10 @@ vmx_dosing_input(fit, dosing_text, scenario_name, client = vmx_client()) \item{scenario_name}{One or more scenario names.} \item{client}{A \code{vmx_client}.} + +\item{wait}{If \code{TRUE}, block until parsing succeeds or fails.} + +\item{...}{Polling controls forwarded to \code{\link[=vmx_wait]{vmx_wait()}}.} } \value{ A \code{vmx_dosing_input} (carries \code{dosing_input_id}). diff --git a/man/vmx_fit_global_estimates.Rd b/man/vmx_fit_global_estimates.Rd index fdf17d0..121067a 100644 --- a/man/vmx_fit_global_estimates.Rd +++ b/man/vmx_fit_global_estimates.Rd @@ -15,5 +15,6 @@ vmx_fit_global_estimates(fit, client = vmx_client()) A tibble. } \description{ -One row per parameter, with the point estimate and credible interval. +One row per estimate, preserving the server-selected point statistic, +interval kind, interval level, and tagged estimate metadata. } diff --git a/man/vmx_fit_obs_vs_pred.Rd b/man/vmx_fit_obs_vs_pred.Rd index fad408c..4e9fe1c 100644 --- a/man/vmx_fit_obs_vs_pred.Rd +++ b/man/vmx_fit_obs_vs_pred.Rd @@ -15,9 +15,9 @@ vmx_fit_obs_vs_pred(fit, client = vmx_client()) A tibble (one row per PK observation). } \description{ -Reshapes the \code{pk} block's parallel observation arrays (subject ids, time, -observed concentration, BLQ/ALOQ flags, LLOQ, …) into a one-row-per- -observation tibble. Non-columnar members — notably the predicted- -concentration quantile bands — are kept on the \code{"extra"} attribute; the PD -block is on \code{"pd"} and the fit id on \code{"model_fit_id"}. +Reshapes the PK block into one row per observation. The returned prediction +columns retain the server-selected point statistic and interval semantics. +A named list of equivalently reshaped PD-marker tibbles is attached as the +\code{"pd_markers"} attribute; units and marker references remain attributes on +their respective tibbles. } diff --git a/man/vmx_fit_subject_estimates.Rd b/man/vmx_fit_subject_estimates.Rd index bdafc99..e0f6c51 100644 --- a/man/vmx_fit_subject_estimates.Rd +++ b/man/vmx_fit_subject_estimates.Rd @@ -15,6 +15,8 @@ vmx_fit_subject_estimates(fit, client = vmx_client()) A tibble. } \description{ -One row per subject x parameter, with the posterior point estimate (\code{value}) -and credible interval (\code{ci_lower}/\code{ci_upper}). +One row per subject x estimate. \code{value_statistic}, \code{interval_kind}, and +\code{interval_level} preserve the server-selected estimate semantics; +\code{interval_lower} and \code{interval_upper} are the corresponding bounds. Tagged +estimate metadata is retained as columns rather than interpreted by vmxr. } diff --git a/man/vmx_fit_vpc.Rd b/man/vmx_fit_vpc.Rd index e192942..ef71386 100644 --- a/man/vmx_fit_vpc.Rd +++ b/man/vmx_fit_vpc.Rd @@ -15,6 +15,8 @@ vmx_fit_vpc(fit, client = vmx_client()) A list (the parsed artifact). } \description{ -Returns the parsed VPC artifact (per dose-group and per-subject quantile -bands over time grids). Tibble reshaping is deferred; see the package NEWS. +Returns the parsed Visual Predictive Check artifact. Its subject and +dose-group channels contain model-implied response trajectories with the +server-provided point statistic and interval. The nested wire shape is +retained verbatim. } diff --git a/man/vmx_login.Rd b/man/vmx_login.Rd index 9d3e0e5..d40a6fd 100644 --- a/man/vmx_login.Rd +++ b/man/vmx_login.Rd @@ -26,7 +26,7 @@ Invisibly, the cached token (a list; the access/refresh tokens are secret and never printed). } \description{ -Runs the OIDC device-code flow (RFC 8628, via \code{\link[httr2:oauth_flow_device]{httr2::oauth_flow_device()}}) +Runs the OIDC device-code flow (RFC 8628, via \code{\link[httr2:req_oauth_device]{httr2::oauth_flow_device()}}) against the workspace's Authentik provider and caches the resulting token so later \code{\link[=vmx_client]{vmx_client()}} calls authenticate automatically. Endpoints are resolved from the issuer's \code{.well-known/openid-configuration} discovery document; the @@ -38,12 +38,11 @@ The token is written as plain JSON to \verb{~/.config/vmx/oidc-token.json} (the same path and shape the \code{vmx} CLI uses, with \code{0600} permissions), so one \code{vmx_login()} serves both R and the terminal CLI and the session survives a fresh R process or workspace pod restart. Because the refresh token is -persisted on the home PVC, you log in \strong{once per refresh-token lifetime} -(~30 days). +persisted on the home PVC, you log in once per provider-configured +refresh-token lifetime. Configuration is read from environment variables (matching the CLI): \code{VMX_OIDC_ISSUER}, \code{VMX_OIDC_CLIENT_ID}, and optionally \code{VMX_OIDC_SCOPES}. -Confirmed-working staging values: issuer -\code{https://auth.staging.gnrbl.co/application/o/generable-staging-vmx-cli/}, -client id \code{generable-staging-vmx-cli}. +Workspace deployments provision the issuer and client id; vmxr does not +assume values from a different workspace or environment. } diff --git a/man/vmx_model_build.Rd b/man/vmx_model_build.Rd index 035e208..cf8c151 100644 --- a/man/vmx_model_build.Rd +++ b/man/vmx_model_build.Rd @@ -21,7 +21,8 @@ vmx_model_build( \item{time_basis}{Time basis.} -\item{pd_marker}{Optional \code{"GEN_uuid:increasing"} / \code{":decreasing"} string(s).} +\item{pd_marker}{Optional \code{"GEN_uuid:increasing"} / \code{":decreasing"} +string(s). \code{NULL} or \code{character(0)} requests a PK-only build.} \item{covariate}{Optional covariate name(s).} diff --git a/man/vmx_model_build_logs.Rd b/man/vmx_model_build_logs.Rd index 7afa30e..78b3266 100644 --- a/man/vmx_model_build_logs.Rd +++ b/man/vmx_model_build_logs.Rd @@ -4,15 +4,17 @@ \alias{vmx_model_build_logs} \title{Build-run logs} \usage{ -vmx_model_build_logs(run, client = vmx_client()) +vmx_model_build_logs(run, client = vmx_client(), order = c("desc", "asc")) } \arguments{ \item{run}{A build-run id or object.} \item{client}{A \code{vmx_client}.} + +\item{order}{Newest-first (\code{"desc"}) or oldest-first (\code{"asc"}).} } \value{ -A tibble of log lines. +A tibble containing all log lines in the requested order. } \description{ Build-run logs diff --git a/man/vmx_model_build_runs.Rd b/man/vmx_model_build_runs.Rd index 700c0ae..a1f9c7d 100644 --- a/man/vmx_model_build_runs.Rd +++ b/man/vmx_model_build_runs.Rd @@ -18,7 +18,7 @@ vmx_model_build_runs( \item{client}{A \code{vmx_client}.} } \value{ -A tibble. +A tibble containing all matching model-build runs. } \description{ List model build runs diff --git a/man/vmx_model_data.Rd b/man/vmx_model_data.Rd index 57a6abe..fc79321 100644 --- a/man/vmx_model_data.Rd +++ b/man/vmx_model_data.Rd @@ -15,9 +15,9 @@ vmx_model_data(dv, client = vmx_client()) A \code{vmx_model_data} object. } \description{ -Returns a \code{vmx_model_data} bundle with \verb{$subjects}, \verb{$pk}, \verb{$pd} (each a -tibble, or \code{NULL} when the DataVersion has no such prepared table), and -\verb{$meta} (units, time bases, PD-marker manifest, subject count) read from the -DataVersion. Only domains flagged in the DV's \code{table_availability} are -fetched, so absent optional tables don't 404. +Returns a \code{vmx_model_data} bundle with \verb{$subjects}, \verb{$pk}, \verb{$dosing}, and +\verb{$pd} (each a tibble, or \code{NULL} when the DataVersion has no such prepared +table), and \verb{$meta} (units, time bases, PD-marker manifest, subject count) +read from the DataVersion. Only domains flagged in the DV's +\code{table_availability} are fetched, so absent optional tables don't 404. } diff --git a/man/vmx_model_fits.Rd b/man/vmx_model_fits.Rd index 715c34b..f3fedff 100644 --- a/man/vmx_model_fits.Rd +++ b/man/vmx_model_fits.Rd @@ -10,16 +10,33 @@ vmx_model_fits( model_type = NULL, marker_name = NULL, status = NULL, - client = vmx_client() + client = vmx_client(), + treatment = NULL, + study = NULL, + source_pk_model_fit = NULL ) } \arguments{ -\item{run, data_version, model_type, marker_name, status}{Optional filters.} +\item{run}{Optional model-build run filter.} + +\item{data_version}{Optional data-version filter.} + +\item{model_type}{Optional model-type filter.} + +\item{marker_name}{Optional marker-name filter.} + +\item{status}{Optional model-fit status filter.} \item{client}{A \code{vmx_client}.} + +\item{treatment}{Optional treatment filter.} + +\item{study}{Optional study filter.} + +\item{source_pk_model_fit}{Optional source PK model-fit filter.} } \value{ -A tibble. +A tibble containing all matching model fits. } \description{ List model fits diff --git a/man/vmx_modeling_options.Rd b/man/vmx_modeling_options.Rd index fb6cdb4..7344ba6 100644 --- a/man/vmx_modeling_options.Rd +++ b/man/vmx_modeling_options.Rd @@ -17,7 +17,8 @@ vmx_modeling_options( \item{time_basis}{Time basis.} -\item{pd_marker}{Optional PD marker gen_uuid(s) (character vector).} +\item{pd_marker}{PD marker gen_uuid(s). \code{NULL} or \code{character(0)} explicitly +previews a PK-only build; pass marker UUIDs to preview PD modeling.} \item{covariate}{Optional covariate name(s).} diff --git a/man/vmx_nca_analyses.Rd b/man/vmx_nca_analyses.Rd index 12fec30..ca032cb 100644 --- a/man/vmx_nca_analyses.Rd +++ b/man/vmx_nca_analyses.Rd @@ -28,7 +28,7 @@ vmx_nca_analyses( \item{client}{A \code{vmx_client}.} } \value{ -A tibble, one row per analysis. +A tibble containing all matching analyses. } \description{ List NCA analyses diff --git a/man/vmx_pk.Rd b/man/vmx_pk.Rd index d7a476c..ab2ae4e 100644 --- a/man/vmx_pk.Rd +++ b/man/vmx_pk.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/data_versions.R \name{vmx_pk} \alias{vmx_pk} -\title{PK observations + events table} +\title{PK observations table} \usage{ vmx_pk(dv, client = vmx_client()) } @@ -15,5 +15,5 @@ vmx_pk(dv, client = vmx_client()) A tibble. } \description{ -PK observations + events table +PK observations table } diff --git a/man/vmx_prep_answer.Rd b/man/vmx_prep_answer.Rd index 19ce196..e7e9fd5 100644 --- a/man/vmx_prep_answer.Rd +++ b/man/vmx_prep_answer.Rd @@ -4,7 +4,12 @@ \alias{vmx_prep_answer} \title{Answer prep questions and resume formatting} \usage{ -vmx_prep_answer(dataset, answers, client = vmx_client()) +vmx_prep_answer( + dataset, + answers, + client = vmx_client(), + idempotency_key = NULL +) } \arguments{ \item{dataset}{A dataset id or \code{vmx_dataset}.} @@ -12,6 +17,9 @@ vmx_prep_answer(dataset, answers, client = vmx_client()) \item{answers}{A named list mapping each prompt \code{field} to its answer value.} \item{client}{A \code{vmx_client}.} + +\item{idempotency_key}{Optional idempotency key for safely repeating the +submission.} } \description{ Answer prep questions and resume formatting diff --git a/man/vmx_prep_questions.Rd b/man/vmx_prep_questions.Rd index fba76b4..4aa5c96 100644 --- a/man/vmx_prep_questions.Rd +++ b/man/vmx_prep_questions.Rd @@ -12,7 +12,8 @@ vmx_prep_questions(dataset, client = vmx_client()) \item{client}{A \code{vmx_client}.} } \value{ -A tibble of pending questions. +A tibble of pending questions. Variable-shape values such as +\code{options}, \code{default}, and \code{data_preview} are retained as list-columns. } \description{ Questions raised by prep (when awaiting input) diff --git a/man/vmx_sim_jobs.Rd b/man/vmx_sim_jobs.Rd index 1378075..8d90e02 100644 --- a/man/vmx_sim_jobs.Rd +++ b/man/vmx_sim_jobs.Rd @@ -12,7 +12,7 @@ vmx_sim_jobs(fit, client = vmx_client()) \item{client}{A \code{vmx_client}.} } \value{ -A tibble. +A tibble containing all simulation jobs for the fit. } \description{ List simulation jobs for a model fit diff --git a/man/vmx_sim_result.Rd b/man/vmx_sim_result.Rd index 88f852f..e785542 100644 --- a/man/vmx_sim_result.Rd +++ b/man/vmx_sim_result.Rd @@ -18,6 +18,6 @@ A list (the parsed result). } \description{ \code{GET /simulation-jobs/{id}/result}. Returns the parsed result payload -(subject/time series with prediction bands). Tibble reshaping is deferred -pending confirmation of the artifact shape; see the package NEWS. +containing model-implied response trajectories with the server-provided +point statistic and interval. The nested wire shape is retained verbatim. } diff --git a/man/vmx_studies.Rd b/man/vmx_studies.Rd index baad2d7..e89b145 100644 --- a/man/vmx_studies.Rd +++ b/man/vmx_studies.Rd @@ -4,7 +4,12 @@ \alias{vmx_studies} \title{List studies for a treatment} \usage{ -vmx_studies(treatment = NULL, status = NULL, client = vmx_client()) +vmx_studies( + treatment = NULL, + status = NULL, + client = vmx_client(), + created_since = NULL +) } \arguments{ \item{treatment}{A treatment id (\code{tmt_...}) or \code{vmx_treatment}; \code{NULL} lists @@ -13,9 +18,12 @@ across all treatments.} \item{status}{Optional status filter.} \item{client}{A \code{vmx_client}.} + +\item{created_since}{Optional lower creation-time bound: a +\code{POSIXct}/\code{Date} or ISO-8601 string.} } \value{ -A tibble, one row per study. +A tibble containing all matching studies. } \description{ List studies for a treatment diff --git a/man/vmx_treatments.Rd b/man/vmx_treatments.Rd index ada231e..b5fbd9a 100644 --- a/man/vmx_treatments.Rd +++ b/man/vmx_treatments.Rd @@ -12,7 +12,7 @@ vmx_treatments(status = NULL, client = vmx_client()) \item{client}{A \code{vmx_client}.} } \value{ -A tibble, one row per treatment. +A tibble containing all matching treatments. } \description{ List treatments diff --git a/man/vmx_upload.Rd b/man/vmx_upload.Rd index 79dc965..038faf0 100644 --- a/man/vmx_upload.Rd +++ b/man/vmx_upload.Rd @@ -11,7 +11,8 @@ vmx_upload( treatment = NULL, config = NULL, wait = FALSE, - client = vmx_client() + client = vmx_client(), + ... ) } \arguments{ @@ -29,6 +30,8 @@ vmx_upload( \item{wait}{If \code{TRUE}, block until prep settles.} \item{client}{A \code{vmx_client}.} + +\item{...}{Polling controls forwarded to \code{\link[=vmx_wait]{vmx_wait()}} when \code{wait = TRUE}.} } \value{ A \code{vmx_dataset} (status \code{"uploaded"}). diff --git a/man/vmx_wait.Rd b/man/vmx_wait.Rd index 139a299..6bc12e1 100644 --- a/man/vmx_wait.Rd +++ b/man/vmx_wait.Rd @@ -19,11 +19,18 @@ vmx_wait( types as the API surface lands: model-build-run, simulation-job).} \item{until}{Target terminal state(s); a sensible default per type when -\code{NULL}.} +\code{NULL}. An explicitly requested failure state is returned; any other +terminal failure still raises immediately.} -\item{timeout}{Timeout in seconds.} +\item{timeout}{Timeout in seconds. Resource methods use long-running defaults: +70 minutes for prep, NCA, and dosing input; 130 minutes for simulation; and +24 hours 10 minutes for model builds. The NCA/modeling worker defaults +include a short persistence cushion beyond their execution ceilings; prep +uses a client-side wait policy because its worker has no equivalent hard +wall-clock ceiling.} -\item{interval}{Poll interval in seconds (exponential backoff up to 30s).} +\item{interval}{Positive poll interval in seconds (exponential backoff up +to 30s).} \item{progress}{Show a progress message each poll; defaults to \code{\link[=interactive]{interactive()}}.} diff --git a/tests/testthat/test-analysis-log-diag.R b/tests/testthat/test-analysis-log-diag.R index 4e550fa..6d89181 100644 --- a/tests/testthat/test-analysis-log-diag.R +++ b/tests/testthat/test-analysis-log-diag.R @@ -4,54 +4,203 @@ con <- vmx_client(base_url = "https://vmx.test", token = "pat_test") test_that("vmx_analysis_log paginates and forwards filters", { env <- new.env() + env$urls <- character() + i <- 0L httr2::local_mocked_responses(function(req) { env$req <- req + env$urls <- c(env$urls, req$url) + i <<- i + 1L httr2::response_json(body = list( study_id = "std_1", - items = list(list(kind = "event", event_type = "nca.completed", outcome = "success")), - next_cursor = NULL + items = list(list( + kind = "event", + event_type = if (i == 1L) "nca.completed" else "model.completed", + outcome = "success" + )), + next_cursor = if (i == 1L) "older-events" else NA_character_, + has_next_page = i == 1L )) }) tbl <- vmx_analysis_log("std_1", kind = "event", since = as.POSIXct("2026-01-01 00:00:00", tz = "UTC"), client = con) - expect_equal(nrow(tbl), 1L) + expect_equal(nrow(tbl), 2L) expect_match(env$req$url, "/studies/std_1/analysis-log") expect_match(env$req$url, "kind=event") expect_match(env$req$url, "since=2026-01-01") # POSIXct -> ISO-8601 + expect_true(all(grepl("kind=event", env$urls, fixed = TRUE))) + expect_match(env$urls[[2]], "cursor=older-events") + expect_equal(attr(tbl, "vmx_metadata")$study_id, "std_1") +}) + +test_that("vmx_analysis_log validates study identity on every page", { + i <- 0L + httr2::local_mocked_responses(function(req) { + i <<- i + 1L + httr2::response_json(body = list( + study_id = if (i == 1L) "std_1" else "std_other", + items = list(), + next_cursor = if (i == 1L) "next" else NA_character_, + has_next_page = i == 1L + )) + }) + + expect_error( + vmx_analysis_log("std_1", client = con), + class = "vmx_response_error" + ) }) test_that("vmx_analysis_log accepts a resource object", { env <- new.env() httr2::local_mocked_responses(function(req) { env$req <- req - httr2::response_json(body = list(items = list(), next_cursor = NULL)) + httr2::response_json(body = list( + study_id = "std_1", + items = list(), + next_cursor = NA_character_, + has_next_page = FALSE + )) }) dv <- new_vmx_resource(list(data_version_id = "dv_9"), "vmx_data_version", "data_version_id") vmx_analysis_log("std_1", resource = dv, client = con) expect_match(env$req$url, "resource_id=dv_9") }) -test_that("vmx_fit_obs_vs_pred groups parallel arrays; bands go to 'extra'", { +test_that("vmx_analysis_log rejects an ambiguous since vector", { + expect_error( + vmx_analysis_log( + "std_1", + since = c("2026-01-01T00:00:00Z", "2026-02-01T00:00:00Z"), + client = con + ), + class = "vmx_usage_error" + ) +}) + +test_that("vmx_fit_obs_vs_pred reshapes current Estimate envelopes", { httr2::local_mocked_responses(list(httr2::response_json(body = list( model_fit_id = "mf_1", pk = list( + gen_measurement_uuid = list( + "aaaaaaaa-aaaa-4aaa-8aaa-aaaaaaaaaaa1", + "aaaaaaaa-aaaa-4aaa-8aaa-aaaaaaaaaaa2", + "aaaaaaaa-aaaa-4aaa-8aaa-aaaaaaaaaaa3" + ), + gen_subject_uuid = list( + "11111111-1111-4111-8111-111111111111", + "11111111-1111-4111-8111-111111111111", + "22222222-2222-4222-8222-222222222222" + ), subject_id = list("1", "1", "2"), time = list(0, 1.5, 0), - observed_concentration = list(0, 12.3, 0), + observed_concentration = list(NA_character_, 12.3, 8.2), is_bloq = list(TRUE, FALSE, TRUE), - predicted_concentration = list(p05 = list(0, 1, 0), p50 = list(0, 2, 0), p95 = list(0, 3, 0)) + is_aloq = list(FALSE, FALSE, FALSE), + lloq = list(1.0, NA_character_, 1.0), + uloq = list(NA_character_, NA_character_, NA_character_), + predicted_concentration = list( + value_statistic = "mean", + value = list(0.8, 11.8, 7.9), + interval = list( + kind = "confidence", + level = 0.8, + lower = list(0.4, 10.2, 6.7), + upper = list(1.3, 13.5, 9.2) + ) + ), + units = list(time = "h", concentration = "ng/mL") ), - pd_markers = list() + pd_markers = list( + effect_score = list( + marker = list( + gen_uuid = "33333333-3333-4333-8333-333333333333", + name = "effect_score" + ), + gen_measurement_uuid = list( + "bbbbbbbb-bbbb-4bbb-8bbb-bbbbbbbbbbb1" + ), + gen_subject_uuid = list( + "11111111-1111-4111-8111-111111111111" + ), + subject_id = list("1"), + time = list(0), + observed = list(42), + predicted = list( + value_statistic = "median", + value = list(41.5), + interval = list( + kind = "credible", + level = 0.9, + lower = list(39), + upper = list(44) + ) + ), + units = list(time = "h", observed = "score", predicted = "score") + ) + ) )))) tbl <- vmx_fit_obs_vs_pred("mf_1", client = con) expect_s3_class(tbl, "tbl_df") - expect_equal(nrow(tbl), 3L) # 3 observations + expect_equal(nrow(tbl), 3L) expect_equal(tbl$subject_id, c("1", "1", "2")) - expect_equal(tbl$observed_concentration, c(0, 12.3, 0)) + expect_equal(tbl$observed_concentration, c(NA_real_, 12.3, 8.2)) expect_type(tbl$is_bloq, "logical") - # quantile bands are not columnar -> kept aside, not guessed into columns - expect_false("predicted_concentration" %in% names(tbl)) - expect_false(is.null(attr(tbl, "extra")$predicted_concentration)) + expect_equal(tbl$predicted_value, c(0.8, 11.8, 7.9)) + expect_equal(tbl$predicted_interval_lower, c(0.4, 10.2, 6.7)) + expect_equal(tbl$predicted_interval_upper, c(1.3, 13.5, 9.2)) + expect_equal(tbl$predicted_value_statistic, rep("mean", 3)) + expect_equal(tbl$predicted_interval_kind, rep("confidence", 3)) + expect_equal(tbl$predicted_interval_level, rep(0.8, 3)) + expect_equal(attr(tbl, "units"), list(time = "h", concentration = "ng/mL")) + expect_false("units" %in% names(tbl)) + + pd <- attr(tbl, "pd_markers")$effect_score + expect_equal(pd$predicted_value, 41.5) + expect_equal(pd$predicted_interval_kind, "credible") + expect_equal(pd$predicted_interval_level, 0.9) + expect_equal( + attr(pd, "units"), + list(time = "h", observed = "score", predicted = "score") + ) + expect_equal( + attr(pd, "marker")$gen_uuid, + "33333333-3333-4333-8333-333333333333" + ) expect_equal(attr(tbl, "model_fit_id"), "mf_1") }) + +test_that("vmx_fit_obs_vs_pred rejects misaligned prediction arrays", { + httr2::local_mocked_responses(list(httr2::response_json(body = list( + model_fit_id = "mf_1", + pk = list( + gen_measurement_uuid = list( + "aaaaaaaa-aaaa-4aaa-8aaa-aaaaaaaaaaa1", + "aaaaaaaa-aaaa-4aaa-8aaa-aaaaaaaaaaa2" + ), + gen_subject_uuid = list( + "11111111-1111-4111-8111-111111111111", + "22222222-2222-4222-8222-222222222222" + ), + subject_id = list("1", "2"), + time = list(0, 1), + observed_concentration = list(0, 5), + is_bloq = list(FALSE, FALSE), + is_aloq = list(FALSE, FALSE), + predicted_concentration = list( + value_statistic = "median", + value = list(0, 5), + interval = list( + kind = "credible", level = 0.95, + lower = list(0), upper = list(0, 6) + ) + ), + units = list(time = "h", concentration = "ng/mL") + ), + pd_markers = list() + )))) + expect_error( + vmx_fit_obs_vs_pred("mf_1", client = con), + class = "vmx_response_error" + ) +}) diff --git a/tests/testthat/test-client.R b/tests/testthat/test-client.R index ee8c3b7..3ca5406 100644 --- a/tests/testthat/test-client.R +++ b/tests/testthat/test-client.R @@ -15,6 +15,23 @@ test_that("vmx_client errors without a base_url", { expect_error(vmx_client(), class = "vmx_usage_error") }) +test_that("vmx_client rejects ambiguous connection values", { + expect_error( + vmx_client( + base_url = c("https://one.test", "https://two.test"), + token = "pat" + ), + class = "vmx_usage_error" + ) + expect_error( + vmx_client( + base_url = "https://example.test", + token = c("one", "two") + ), + class = "vmx_usage_error" + ) +}) + test_that("vmx_client errors without a token", { withr::local_envvar(VMX_API_TOKEN = "") expect_error( diff --git a/tests/testthat/test-datasets-prep.R b/tests/testthat/test-datasets-prep.R index 631fb26..a188214 100644 --- a/tests/testthat/test-datasets-prep.R +++ b/tests/testthat/test-datasets-prep.R @@ -15,7 +15,9 @@ test_that("vmx_datasets lists with filters into a tibble", { httr2::local_mocked_responses(function(req) { env$req <- req httr2::response_json(body = list( - items = list(list(dataset_id = "ds_1", status = "formatted")), next_cursor = NULL + items = list(list(dataset_id = "ds_1", status = "formatted")), + next_cursor = NA_character_, + has_next_page = FALSE )) }) tbl <- vmx_datasets(study = "std_1", client = con) @@ -28,7 +30,9 @@ test_that("vmx_datasets accepts a vmx_study object", { httr2::local_mocked_responses(function(req) { env$req <- req httr2::response_json(body = list( - items = list(list(dataset_id = "ds_1", status = "formatted")), next_cursor = NULL + items = list(list(dataset_id = "ds_1", status = "formatted")), + next_cursor = NA_character_, + has_next_page = FALSE )) }) study <- new_vmx_resource(list(study_id = "std_7"), "vmx_study", "study_id") @@ -42,7 +46,12 @@ test_that("vmx_upload sends config_yaml as inline form text", { writeLines("time,conc\n0,1", data_file) writeLines(c("version: 2", "datasets: []"), config_file) - env <- capture_one(list(dataset_id = "ds_1", status = "uploaded")) + env <- capture_one(list( + dataset_id = "ds_1", + treatment_id = "tmt_1", + study_id = "std_1", + status = "uploaded" + )) study <- new_vmx_resource( list(study_id = "std_1", treatment_id = "tmt_1"), "vmx_study", @@ -56,6 +65,20 @@ test_that("vmx_upload sends config_yaml as inline form text", { expect_equal(body$config_yaml, "version: 2\ndatasets: []") }) +test_that("vmx_upload rejects empty or duplicate file selections", { + expect_error( + vmx_upload("std_1", character(), treatment = "tmt_1", client = con), + class = "vmx_usage_error" + ) + expect_error( + vmx_upload( + "std_1", c("same.csv", "same.csv"), + treatment = "tmt_1", client = con + ), + class = "vmx_usage_error" + ) +}) + test_that("vmx_dataset fetches and types the resource", { httr2::local_mocked_responses(list(httr2::response_json(body = list( dataset_id = "ds_1", status = "formatted", tags = list(name = "run-A") @@ -65,10 +88,11 @@ test_that("vmx_dataset fetches and types the resource", { expect_equal(vmx_resource_id(ds), "ds_1") }) -test_that("vmx_dataset_files paginates into a tibble", { +test_that("vmx_dataset_files returns all files as a tibble", { httr2::local_mocked_responses(list(httr2::response_json(body = list( items = list(list(tagged_upload_id = "tu_1", name = "conc.csv", size = 42L)), - next_cursor = NULL + next_cursor = NA_character_, + has_next_page = FALSE )))) tbl <- vmx_dataset_files("ds_1", client = con) expect_equal(tbl$name, "conc.csv") @@ -89,6 +113,18 @@ test_that("vmx_dataset_tags handles no tags", { expect_equal(nrow(vmx_dataset_tags(ds)), 0L) }) +test_that("vmx_dataset_tags rejects malformed values", { + ds <- new_vmx_resource( + list(dataset_id = "ds_1", tags = list(name = list("nested"))), + "vmx_dataset", + "dataset_id" + ) + expect_error( + vmx_dataset_tags(ds), + class = "vmx_response_error" + ) +}) + test_that("vmx_dataset_cancel posts and returns a prep-status", { env <- capture_one(list(dataset_id = "ds_1", status = "cancelled")) ps <- vmx_dataset_cancel("ds_1", client = con) @@ -113,13 +149,22 @@ test_that("vmx_prep_questions builds a tibble from the prompt", { dataset_id = "ds_1", status = "awaiting_input", prompt = list(message = "Need info", fields = list( list(field = "dose_unit", question = "Units?", required = TRUE, - options = list("mg", "ug"), format = "enum") + options = list("mg", "ug"), format = "enum", + referent = "dosing:unit", rationale = "Needed for conversion.", + data_preview = list(list(value = 100)), + resolution = list(kind = "unit", hint = "Choose the source unit."), + default = "mg", group = "dosing") )) )))) q <- vmx_prep_questions("ds_1", client = con) expect_equal(q$field, "dose_unit") expect_true(q$required) expect_equal(q$options[[1]], list("mg", "ug")) + expect_equal(q$referent, "dosing:unit") + expect_equal(q$resolution_kind, "unit") + expect_equal(q$resolution_hint, "Choose the source unit.") + expect_equal(q$default[[1]], "mg") + expect_equal(q$data_preview[[1]], list(list(value = 100))) }) test_that("vmx_prep_questions is empty when no prompt", { @@ -131,12 +176,46 @@ test_that("vmx_prep_questions is empty when no prompt", { test_that("vmx_prep_answer posts the answers body", { env <- capture_one(list(dataset_id = "ds_1", status = "formatting")) - ps <- vmx_prep_answer("ds_1", list(dose_unit = "mg"), client = con) + ps <- vmx_prep_answer( + "ds_1", + list(dose_unit = "mg"), + client = con, + idempotency_key = "prep-answer-1" + ) expect_s3_class(ps, "vmx_prep_status") expect_equal(env$req$body$data$dose_unit, "mg") + expect_equal(env$req$body$data$idempotency_key, "prep-answer-1") expect_match(env$req$url, "/datasets/ds_1/prep-answers$") }) test_that("vmx_prep_answer rejects a non-named answers arg", { expect_error(vmx_prep_answer("ds_1", list(1, 2), client = con), class = "vmx_usage_error") + expect_error( + vmx_prep_answer("ds_1", list(), client = con), + class = "vmx_usage_error" + ) + expect_error( + vmx_prep_answer( + "ds_1", list(idempotency_key = "not-an-answer"), client = con + ), + class = "vmx_usage_error" + ) +}) + +test_that("vmx_prep_questions rejects duplicate answer keys", { + httr2::local_mocked_responses(list(httr2::response_json(body = list( + dataset_id = "ds_1", + status = "awaiting_input", + prompt = list( + message = "Need info", + fields = list( + list(field = "dose_unit", question = "Units?", required = TRUE), + list(field = "dose_unit", question = "Units again?", required = TRUE) + ) + ) + )))) + expect_error( + vmx_prep_questions("ds_1", client = con), + class = "vmx_response_error" + ) }) diff --git a/tests/testthat/test-http.R b/tests/testthat/test-http.R index 71f51b5..4b04ffa 100644 --- a/tests/testthat/test-http.R +++ b/tests/testthat/test-http.R @@ -25,27 +25,141 @@ test_that("vmx_whoami parses /me into a typed object", { expect_equal(vmx_resource_id(me), "usr_1") }) -test_that("vmx_treatments follows pagination into one tibble", { - responses <- list( - httr2::response_json(body = list(items = list(tmt_item("tmt_1", "A")), next_cursor = "c1")), - httr2::response_json(body = list(items = list(tmt_item("tmt_2", "B")), next_cursor = NULL)) - ) - httr2::local_mocked_responses(responses) - tbl <- vmx_treatments(client = con) - expect_s3_class(tbl, "tbl_df") - expect_equal(nrow(tbl), 2L) - expect_equal(tbl$treatment_id, c("tmt_1", "tmt_2")) +test_that("vmx_treatments automatically combines every cursor page", { + urls <- character() + i <- 0L + httr2::local_mocked_responses(function(req) { + urls <<- c(urls, req$url) + i <<- i + 1L + if (i == 1L) { + httr2::response_json(body = list( + items = list(tmt_item("tmt_1", "A")), + next_cursor = "c1", + has_next_page = TRUE + )) + } else { + httr2::response_json(body = list( + items = list(tmt_item("tmt_2", "B")), + next_cursor = NA_character_, + has_next_page = FALSE + )) + } + }) + + out <- vmx_treatments(status = "active", client = con) + expect_s3_class(out, "tbl_df") + expect_equal(out$treatment_id, c("tmt_1", "tmt_2")) # nested counts flattened to prefixed columns - expect_true(all(c("counts_studies", "counts_data_versions") %in% names(tbl))) + expect_true(all(c("counts_studies", "counts_data_versions") %in% names(out))) + expect_length(urls, 2L) + expect_true(all(grepl("status=active", urls, fixed = TRUE))) + expect_match(urls[[2]], "cursor=c1") }) test_that("vmx_treatments returns an empty tibble when there are none", { httr2::local_mocked_responses(list( - httr2::response_json(body = list(items = list(), next_cursor = NULL)) + httr2::response_json(body = list( + items = list(), + next_cursor = NA_character_, + has_next_page = FALSE + )) )) expect_equal(nrow(vmx_treatments(client = con)), 0L) }) +test_that("collection pages reject inconsistent cursor metadata", { + httr2::local_mocked_responses(list( + httr2::response_json(body = list( + items = list(), + next_cursor = "unexpected", + has_next_page = FALSE + )) + )) + expect_error( + vmx_treatments(client = con), + class = "vmx_response_error" + ) +}) + +test_that("automatic pagination rejects repeated cursors", { + i <- 0L + httr2::local_mocked_responses(function(req) { + i <<- i + 1L + httr2::response_json(body = list( + items = list(tmt_item(paste0("tmt_", i), paste0("T", i))), + next_cursor = "same-cursor", + has_next_page = TRUE + )) + }) + + expect_error( + vmx_treatments(client = con), + class = "vmx_response_error" + ) + expect_equal(i, 2L) +}) + +test_that("automatic pagination validates later and empty pages", { + httr2::local_mocked_responses(list( + httr2::response_json(body = list( + items = list(), + next_cursor = "c1", + has_next_page = TRUE + )), + httr2::response_json(body = list( + items = list(tmt_item("tmt_2", "B")), + next_cursor = NA_character_, + has_next_page = FALSE + )) + )) + expect_equal(vmx_treatments(client = con)$treatment_id, "tmt_2") + + httr2::local_mocked_responses(list( + httr2::response_json(body = list( + items = list(tmt_item("tmt_1", "A")), + next_cursor = "c1", + has_next_page = TRUE + )), + httr2::response_json(body = list( + items = list(), + next_cursor = "c2", + has_next_page = FALSE + )) + )) + expect_error(vmx_treatments(client = con), class = "vmx_response_error") +}) + +test_that("single-resource responses must match the requested id", { + httr2::local_mocked_responses(list( + httr2::response_json(body = tmt_item("tmt_other", "Other")) + )) + expect_error( + vmx_treatment("tmt_1", client = con), + class = "vmx_response_error" + ) +}) + +test_that("treatment updates preserve only contract-nullable NULL fields", { + captured <- new.env() + httr2::local_mocked_responses(function(req) { + captured$req <- req + httr2::response_json(body = tmt_item("tmt_1", "A")) + }) + + vmx_treatment_update("tmt_1", description = NULL, client = con) + expect_true("description" %in% names(captured$req$body$data)) + expect_null(captured$req$body$data$description) + + expect_error( + vmx_treatment_update("tmt_1", name = NULL, client = con), + class = "vmx_usage_error" + ) + expect_error( + vmx_treatment_update("tmt_1", unknown_field = "x", client = con), + class = "vmx_usage_error" + ) +}) + test_that("401 maps to vmx_auth_error", { httr2::local_mocked_responses(list( httr2::response_json( @@ -82,7 +196,7 @@ test_that("vmx_wait polls prep-status to a terminal state", { ps <- vmx_wait(structure(list(dataset_id = "ds_1"), vmx_id_field = "dataset_id", class = c("vmx_dataset", "vmx_resource")), - interval = 0, progress = FALSE, client = con) + interval = 0.001, progress = FALSE, client = con) expect_s3_class(ps, "vmx_prep_status") expect_equal(ps$status, "formatted") expect_equal(ps$data_version_id, "dv_1") @@ -96,7 +210,7 @@ test_that("vmx_wait raises on a failed terminal state", { vmx_wait(structure(list(dataset_id = "ds_1"), vmx_id_field = "dataset_id", class = c("vmx_dataset", "vmx_resource")), - interval = 0, progress = FALSE, client = con), + interval = 0.001, progress = FALSE, client = con), class = "vmx_api_error" ) }) diff --git a/tests/testthat/test-modeling-data.R b/tests/testthat/test-modeling-data.R index d67462d..8fc0821 100644 --- a/tests/testthat/test-modeling-data.R +++ b/tests/testthat/test-modeling-data.R @@ -26,7 +26,7 @@ test_that("vmx_data_version_table coerces columns by declared type", { expect_match(env$req$url, "/data-versions/dv_1/tables/pk$") expect_equal(nrow(tbl), 2L) expect_type(tbl$time, "double") - expect_type(tbl$evid, "double") # integer -> numeric + expect_type(tbl$evid, "integer") expect_type(tbl$blq, "logical") expect_equal(tbl$dv, c(NA, 12.3)) # null cell -> NA expect_equal(tbl$gen_subject_uuid, c("u1", "u1")) @@ -37,8 +37,21 @@ test_that("vmx_data_version_table validates the domain", { expect_error(vmx_data_version_table("dv_1", "bogus", client = con)) }) -test_that("vmx_pk / vmx_subjects / vmx_pd hit the right domain", { - for (d in c("pk", "subjects", "pd")) { +test_that("data-version table rows must match the declared schema", { + httr2::local_mocked_responses(list(httr2::response_json(body = list( + data_version_id = "dv_1", + domain = "pk", + columns = list(list(name = "time", type = "number")), + rows = list(list(time = 1, undeclared = "x")) + )))) + expect_error( + vmx_pk("dv_1", client = con), + class = "vmx_response_error" + ) +}) + +test_that("model-data accessors hit the right domain", { + for (d in c("pk", "subjects", "dosing", "pd")) { env <- new.env() httr2::local_mocked_responses(function(req) { env$req <- req @@ -46,7 +59,13 @@ test_that("vmx_pk / vmx_subjects / vmx_pd hit the right domain", { columns = list(list(name = "gen_subject_uuid", type = "string")), rows = list(list(gen_subject_uuid = "u1")))) }) - fn <- switch(d, pk = vmx_pk, subjects = vmx_subjects, pd = vmx_pd) + fn <- switch( + d, + pk = vmx_pk, + subjects = vmx_subjects, + dosing = vmx_dosing, + pd = vmx_pd + ) tbl <- fn("dv_1", client = con) expect_match(env$req$url, paste0("/tables/", d, "$")) expect_equal(nrow(tbl), 1L) @@ -57,13 +76,26 @@ test_that("vmx_model_data bundles available tables + meta and skips absent ones" dv <- new_vmx_resource(list( data_version_id = "dv_1", n_subjects = 8L, units = list(time = "h"), time_bases = list(), - table_availability = list(subjects = TRUE, pk = TRUE, pd = FALSE) + table_availability = list( + subjects = TRUE, + pk = TRUE, + dosing = TRUE, + pd = FALSE, + labs = FALSE, + covariates = FALSE + ) ), "vmx_data_version", "data_version_id") i <- 0 httr2::local_mocked_responses(function(req) { i <<- i + 1 - dom <- if (grepl("subjects", req$url)) "subjects" else "pk" + dom <- if (grepl("/subjects$", req$url)) { + "subjects" + } else if (grepl("/dosing$", req$url)) { + "dosing" + } else { + "pk" + } httr2::response_json(body = list(data_version_id = "dv_1", domain = dom, columns = list(list(name = "gen_subject_uuid", type = "string")), rows = list(list(gen_subject_uuid = "u1")))) @@ -72,9 +104,22 @@ test_that("vmx_model_data bundles available tables + meta and skips absent ones" expect_s3_class(md, "vmx_model_data") expect_s3_class(md$subjects, "tbl_df") expect_s3_class(md$pk, "tbl_df") + expect_s3_class(md$dosing, "tbl_df") expect_null(md$pd) # pd not available -> not fetched expect_equal(md$meta$n_subjects, 8L) - expect_equal(i, 2L) # only subjects + pk fetched + expect_equal(i, 3L) # only advertised tables fetched +}) + +test_that("vmx_model_data rejects incomplete table availability metadata", { + dv <- new_vmx_resource(list( + data_version_id = "dv_1", + table_availability = list(subjects = TRUE, pk = TRUE) + ), "vmx_data_version", "data_version_id") + + expect_error( + vmx_model_data(dv, client = con), + class = "vmx_response_error" + ) }) test_that("nlmixr2 / torsten adapters remain deferred stubs", { diff --git a/tests/testthat/test-modeling.R b/tests/testthat/test-modeling.R index ecc1e37..816c053 100644 --- a/tests/testthat/test-modeling.R +++ b/tests/testthat/test-modeling.R @@ -26,6 +26,21 @@ test_that("vmx_model_catalog flattens categories into a tibble", { expect_true("display_name" %in% names(tbl)) }) +test_that("model catalog helpers reject malformed inputs and responses", { + expect_error( + vmx_model_describe(c("one_cmt", "two_cmt"), client = con), + class = "vmx_usage_error" + ) + + httr2::local_mocked_responses(list(httr2::response_json(body = list( + pk = list(name = "not-an-array") + )))) + expect_error( + vmx_model_catalog(client = con), + class = "vmx_response_error" + ) +}) + test_that("vmx_model_build parses pd_marker shorthand and posts the body", { env <- capture_one(run_item("run_9")) run <- vmx_model_build("dv_1", "observed", @@ -38,11 +53,36 @@ test_that("vmx_model_build parses pd_marker shorthand and posts the body", { expect_equal(body$pd_markers, list(list(gen_uuid = "GEN_abc", direction = "decreasing"))) }) +test_that("PK-only modeling options and builds send an explicit empty marker selection", { + options_env <- capture_one(list( + data_version_id = "dv_1", + options = list( + pd_markers = list(), + time_basis = "observed", + covariates = list() + ), + modeling_population = list(), + available_covariates = list() + )) + vmx_modeling_options("dv_1", "observed", client = con) + expect_equal(options_env$req$body$data$pd_markers, list()) + + build_env <- capture_one(run_item("run_10")) + vmx_model_build("dv_1", "observed", client = con) + expect_equal(build_env$req$body$data$pd_markers, list()) +}) + test_that("vmx_model_build rejects malformed pd_marker", { expect_error( vmx_model_build("dv_1", "observed", pd_marker = "GEN_abc:sideways", client = con), class = "vmx_usage_error" ) + expect_error( + vmx_model_build( + "dv_1", "observed", covariate = c("WT", "WT"), client = con + ), + class = "vmx_usage_error" + ) }) test_that("vmx_model_build wait=TRUE polls to terminal", { @@ -51,7 +91,7 @@ test_that("vmx_model_build wait=TRUE polls to terminal", { httr2::response_json(body = run_item("run_9", "running")), httr2::response_json(body = run_item("run_9", "succeeded")) )) - run <- vmx_model_build("dv_1", "observed", wait = TRUE, interval = 0, + run <- vmx_model_build("dv_1", "observed", wait = TRUE, interval = 0.001, progress = FALSE, client = con) expect_equal(run$status, "succeeded") }) @@ -67,7 +107,7 @@ test_that("vmx_model_build_report_create posts report request", { test_that("vmx_wait on a build run raises on failure/cancelled", { httr2::local_mocked_responses(list(httr2::response_json(body = run_item("run_9", "cancelled")))) run <- new_vmx_resource(run_item("run_9"), "vmx_model_build_run", "run_id") - expect_error(vmx_wait(run, interval = 0, progress = FALSE, client = con), + expect_error(vmx_wait(run, interval = 0.001, progress = FALSE, client = con), class = "vmx_api_error") }) @@ -75,13 +115,16 @@ test_that("vmx_model_fits and vmx_model_fit work", { httr2::local_mocked_responses(list(httr2::response_json(body = list( items = list(list(model_fit_id = "mf_1", run_id = "run_1", data_version_id = "dv_1", model_type = "pk", status = "succeeded")), - next_cursor = NULL + next_cursor = NA_character_, + has_next_page = FALSE )))) fits <- vmx_model_fits(run = "run_1", client = con) expect_equal(fits$model_fit_id, "mf_1") httr2::local_mocked_responses(list(httr2::response_json(body = list( - metadata = list(a = 1), model = list(b = 2), inference = list(c = 3) + metadata = list(model_fit_id = "mf_1", a = 1), + model = list(b = 2), + inference = list(c = 3) )))) fit <- vmx_model_fit("mf_1", client = con) expect_s3_class(fit, "vmx_model_fit") @@ -100,13 +143,21 @@ test_that("vmx_model_fit_postprocessor_status calls the current endpoint", { test_that("vmx_fit_subject_estimates reshapes to tidy long", { httr2::local_mocked_responses(list(httr2::response_json(body = list( model_fit_id = "mf_1", - gen_subject_uuid = list("u1", "u2"), + schema_version = "1.0", + gen_subject_uuid = list( + "11111111-1111-4111-8111-111111111111", + "22222222-2222-4222-8222-222222222222" + ), subject_id = list("1", "2"), estimates = list(list( name = "CL", display_name = "Clearance", unit = "L/h", value = list(0.6, 0.8), - interval = list(lower = list(0.5, 0.7), upper = list(0.7, 0.9)), - value_statistic = "median", kind = "structural", model_type = "pk" + interval = list( + kind = "confidence", level = 0.8, + lower = list(0.5, 0.7), upper = list(0.7, 0.9) + ), + value_statistic = "mean", kind = "structural", model_type = "pk", + computation = "population_and_random_effects" )) )))) tbl <- vmx_fit_subject_estimates("mf_1", client = con) @@ -114,7 +165,17 @@ test_that("vmx_fit_subject_estimates reshapes to tidy long", { expect_equal(tbl$subject_id, c("1", "2")) expect_equal(tbl$name, c("CL", "CL")) expect_equal(tbl$value, c(0.6, 0.8)) - expect_equal(tbl$ci_lower, c(0.5, 0.7)) + expect_equal(tbl$interval_lower, c(0.5, 0.7)) + expect_equal(tbl$interval_upper, c(0.7, 0.9)) + expect_equal(tbl$value_statistic, c("mean", "mean")) + expect_equal(tbl$interval_kind, c("confidence", "confidence")) + expect_equal(tbl$interval_level, c(0.8, 0.8)) + expect_equal( + tbl$computation, + c("population_and_random_effects", "population_and_random_effects") + ) + expect_equal(attr(tbl, "model_fit_id"), "mf_1") + expect_equal(attr(tbl, "schema_version"), "1.0") }) test_that("vmx_fit_global_estimates reshapes to one row per parameter", { @@ -122,18 +183,130 @@ test_that("vmx_fit_global_estimates reshapes to one row per parameter", { model_fit_id = "mf_1", estimates = list( list(name = "CL", display_name = "Clearance", unit = "L/h", value = 0.74, - interval = list(lower = 0.62, upper = 0.92, level = 0.95), + interval = list( + kind = "credible", lower = 0.62, upper = 0.92, level = 0.95 + ), value_statistic = "median", kind = "structural", model_type = "pk"), - list(name = "sigma", display_name = "Noise", unit = "dimensionless", value = 0.04, - interval = list(lower = 0.03, upper = 0.06, level = 0.95), - value_statistic = "median", kind = "observation_model", model_type = "pk", - description = "obs noise") + list( + name = "theta_weight_CL", display_name = "weight effect on CL", + unit = "dimensionless", value = 0.04, + interval = list( + kind = "confidence", lower = 0.01, upper = 0.07, level = 0.8 + ), + value_statistic = "mean", kind = "covariate_effect", model_type = "pk", + target_parameter = "CL", covariate = "weight", + feature_scale = "log_normalized" + ) ) )))) tbl <- vmx_fit_global_estimates("mf_1", client = con) expect_equal(nrow(tbl), 2L) - expect_equal(tbl$name, c("CL", "sigma")) + expect_equal(tbl$name, c("CL", "theta_weight_CL")) expect_equal(tbl$value, c(0.74, 0.04)) - expect_equal(tbl$ci_upper, c(0.92, 0.06)) - expect_equal(tbl$level, c(0.95, 0.95)) + expect_equal(tbl$interval_upper, c(0.92, 0.07)) + expect_equal(tbl$interval_kind, c("credible", "confidence")) + expect_equal(tbl$interval_level, c(0.95, 0.8)) + expect_equal(tbl$value_statistic, c("median", "mean")) + expect_equal(tbl$target_parameter, c(NA, "CL")) + expect_equal(tbl$covariate, c(NA, "weight")) + expect_equal(tbl$feature_scale, c(NA, "log_normalized")) + expect_equal(attr(tbl, "model_fit_id"), "mf_1") +}) + +test_that("subject estimates fail loudly on misaligned arrays", { + httr2::local_mocked_responses(list(httr2::response_json(body = list( + model_fit_id = "mf_1", + gen_subject_uuid = list( + "11111111-1111-4111-8111-111111111111", + "22222222-2222-4222-8222-222222222222" + ), + subject_id = list("1", "2"), + estimates = list(list( + name = "CL", display_name = "Clearance", unit = "L/h", + value_statistic = "median", value = list(0.6), + interval = list( + kind = "credible", level = 0.95, + lower = list(0.5, 0.7), upper = list(0.7, 0.9) + ), + kind = "structural", model_type = "pk" + )) + )))) + expect_error( + vmx_fit_subject_estimates("mf_1", client = con), + class = "vmx_response_error" + ) +}) + +test_that("global estimates fail loudly when scalar values arrive as arrays", { + httr2::local_mocked_responses(list(httr2::response_json(body = list( + model_fit_id = "mf_1", + estimates = list(list( + name = "CL", display_name = "Clearance", unit = "L/h", + value_statistic = "median", value = list(0.6, 0.8), + interval = list( + kind = "credible", level = 0.95, lower = 0.5, upper = 0.9 + ), + kind = "structural", model_type = "pk" + )) + )))) + expect_error( + vmx_fit_global_estimates("mf_1", client = con), + class = "vmx_response_error" + ) +}) + +test_that("tagged estimates reject an unknown model type", { + httr2::local_mocked_responses(list(httr2::response_json(body = list( + model_fit_id = "mf_1", + estimates = list(list( + kind = "structural", + name = "CL", + display_name = "Clearance", + model_type = "unknown", + unit = "L/h", + value_statistic = "median", + value = 1, + interval = list( + kind = "credible", + level = 0.95, + lower = 0.5, + upper = 1.5 + ) + )) + )))) + expect_error( + vmx_fit_global_estimates("mf_1", client = con), + class = "vmx_response_error" + ) +}) + +test_that("vmx_fit_vpc preserves server-provided trajectory semantics", { + httr2::local_mocked_responses(list(httr2::response_json(body = list( + model_fit_id = "mf_1", + model_type = "pk", + subjects = list(list( + gen_subject_uuid = "11111111-1111-4111-8111-111111111111", + subject_id = "1", + observed = list(), + time_grids = list(list( + label = "all times", + time = list(0, 1), + trajectory_count = 20, + concentration = list( + name = "concentration", model_type = "pk", unit = "ng/mL", + value_statistic = "mean", value = list(0, 10), + interval = list( + kind = "confidence", level = 0.8, + lower = list(0, 8), upper = list(0, 12) + ) + ) + )) + )), + dose_groups = list() + )))) + out <- vmx_fit_vpc("mf_1", client = con) + estimate <- out$subjects[[1]]$time_grids[[1]]$concentration + expect_equal(estimate$value_statistic, "mean") + expect_equal(estimate$interval$kind, "confidence") + expect_equal(estimate$interval$level, 0.8) }) diff --git a/tests/testthat/test-nca.R b/tests/testthat/test-nca.R index c102f59..6ad2471 100644 --- a/tests/testthat/test-nca.R +++ b/tests/testthat/test-nca.R @@ -16,16 +16,22 @@ capture_req <- function(body) { env } -test_that("vmx_nca_analyses forwards filters and paginates", { - env <- new.env(); i <- 0 +test_that("vmx_nca_analyses returns all server-owned pages", { + env <- new.env() + i <- 0L httr2::local_mocked_responses(function(req) { - env$req <- req; i <<- i + 1 - if (i == 1) httr2::response_json(body = list(items = list(nca_item("nca_1", "completed")), next_cursor = "c")) - else httr2::response_json(body = list(items = list(nca_item("nca_2", "failed")), next_cursor = NULL)) + env$req <- req + i <<- i + 1L + httr2::response_json(body = list( + items = list(nca_item(paste0("nca_", i), "completed")), + next_cursor = if (i == 1L) "opaque-next-page" else NA_character_, + has_next_page = i == 1L + )) }) tbl <- vmx_nca_analyses(data_version = "dv_1", client = con) - expect_equal(nrow(tbl), 2L) + expect_equal(tbl$nca_id, c("nca_1", "nca_2")) expect_match(env$req$url, "data_version_id=dv_1") + expect_match(env$req$url, "cursor=opaque-next-page") }) test_that("vmx_nca creates without waiting and posts the right body", { @@ -37,13 +43,30 @@ test_that("vmx_nca creates without waiting and posts the right body", { expect_match(env$req$url, "/nca-analyses$") }) +test_that("vmx_nca validates scalar controls and retry ids", { + expect_error( + vmx_nca( + "dv_1", c("observed", "nominal"), + wait = FALSE, client = con + ), + class = "vmx_usage_error" + ) + expect_error( + vmx_nca( + "dv_1", "observed", retried_from = "run_wrong", + wait = FALSE, client = con + ), + class = "vmx_usage_error" + ) +}) + test_that("vmx_nca with wait=TRUE polls to a terminal state", { httr2::local_mocked_responses(list( httr2::response_json(body = nca_item("nca_9", "queued")), # create httr2::response_json(body = nca_item("nca_9", "running")), # poll 1 httr2::response_json(body = nca_item("nca_9", "completed")) # poll 2 )) - nca <- vmx_nca("dv_1", "observed", wait = TRUE, interval = 0, + nca <- vmx_nca("dv_1", "observed", wait = TRUE, interval = 0.001, progress = FALSE, client = con) expect_equal(nca$status, "completed") }) @@ -53,7 +76,7 @@ test_that("vmx_wait on an NCA raises on failure", { httr2::response_json(body = nca_item("nca_9", "failed")) )) nca <- new_vmx_resource(nca_item("nca_9", "queued"), "vmx_nca_analysis", "nca_id") - expect_error(vmx_wait(nca, interval = 0, progress = FALSE, client = con), + expect_error(vmx_wait(nca, interval = 0.001, progress = FALSE, client = con), class = "vmx_api_error") }) @@ -62,7 +85,7 @@ test_that("degraded is treated as a (non-error) terminal state", { httr2::response_json(body = nca_item("nca_9", "degraded")) )) nca <- new_vmx_resource(nca_item("nca_9", "queued"), "vmx_nca_analysis", "nca_id") - out <- vmx_wait(nca, interval = 0, progress = FALSE, client = con) + out <- vmx_wait(nca, interval = 0.001, progress = FALSE, client = con) expect_equal(out$status, "degraded") }) @@ -72,16 +95,110 @@ test_that("vmx_nca_result reshapes point_estimates into a tidy tibble", { nca_id = "nca_1", data_version_id = "dv_1", status = "completed", time_basis = "observed", subject_id = list("S1", "S2"), - gen_subject_uuid = list("u1", "u2"), - point_estimates = list(cmax = list(10.5, NULL), auc = list(100, 200)), - quantities = list(list(name = "cmax", display_name = "Cmax", unit = "ng/mL", - explanation = "peak")) + gen_subject_uuid = list( + "11111111-1111-4111-8111-111111111111", + "22222222-2222-4222-8222-222222222222" + ), + point_estimates = list(cmax = list(10.5, 12.2), auc_inf = list(100, 200)), + quantities = list( + list( + name = "cmax", display_name = "Cmax", unit = "ng/mL", + explanation = "Maximum observed concentration." + ), + list( + name = "auc_inf", display_name = "AUCinf", unit = "ng*h/mL", + explanation = "Area under the concentration-time curve." + ) + ), + excluded_subjects = list(list( + gen_subject_uuid = "33333333-3333-4333-8333-333333333333", + subject_id = "S3", + reasons = list("insufficient_terminal_points") + )), + units = list(cmax = "ng/mL", auc_inf = "ng*h/mL"), + worker_version = "nca/0.2.3", + trigger_source = list( + type = "system", + user_id = NA_character_, + system_component = "event_router", + reason = "data_version_eligible" + ), + retried_from = NA_character_ )) )) tbl <- vmx_nca_result("nca_1", client = con) expect_equal(nrow(tbl), 2L) expect_equal(tbl$subject_id, c("S1", "S2")) - expect_equal(tbl$cmax, c(10.5, NA_real_)) # null -> NA - expect_equal(tbl$auc, c(100, 200)) + expect_equal(tbl$cmax, c(10.5, 12.2)) + expect_equal(tbl$auc_inf, c(100, 200)) expect_equal(attr(tbl, "quantities")[[1]]$display_name, "Cmax") + expect_equal(attr(tbl, "units")$auc_inf, "ng*h/mL") + expect_equal(attr(tbl, "worker_version"), "nca/0.2.3") + expect_equal( + attr(tbl, "excluded_subjects")[[1]]$gen_subject_uuid, + "33333333-3333-4333-8333-333333333333" + ) +}) + +test_that("vmx_nca_result rejects misaligned point-estimate arrays", { + httr2::local_mocked_responses(list( + httr2::response_json(body = list( + nca_id = "nca_1", + data_version_id = "dv_1", + status = "completed", + time_basis = "observed", + subject_id = list("S1", "S2"), + gen_subject_uuid = list( + "11111111-1111-4111-8111-111111111111", + "22222222-2222-4222-8222-222222222222" + ), + point_estimates = list(cmax = list(10.5)), + quantities = list(list( + name = "cmax", display_name = "Cmax", unit = "ng/mL", + explanation = "Maximum observed concentration." + )), + excluded_subjects = list(), + units = list(cmax = "ng/mL"), + worker_version = "nca/0.2.3", + trigger_source = list( + type = "user", + user_id = "usr_1", + system_component = NA_character_, + reason = "user_request" + ), + retried_from = NA_character_ + )) + )) + expect_error( + vmx_nca_result("nca_1", client = con), + class = "vmx_response_error" + ) +}) + +test_that("vmx_nca_result protects subject-identity columns", { + httr2::local_mocked_responses(list( + httr2::response_json(body = list( + nca_id = "nca_1", + data_version_id = "dv_1", + status = "completed", + time_basis = "observed", + subject_id = list("S1"), + gen_subject_uuid = list( + "11111111-1111-4111-8111-111111111111" + ), + point_estimates = list(subject_id = list(10)), + quantities = list(), + excluded_subjects = list(), + units = list(), + trigger_source = list( + type = "system", + system_component = "event_router", + reason = "data_version_eligible" + ) + )) + )) + expect_error( + vmx_nca_result("nca_1", client = con), + class = "vmx_response_error" + ) }) diff --git a/tests/testthat/test-oidc.R b/tests/testthat/test-oidc.R index 3caaf90..9247e6b 100644 --- a/tests/testthat/test-oidc.R +++ b/tests/testthat/test-oidc.R @@ -80,6 +80,50 @@ test_that("a corrupt cache is treated as no token, not an error", { expect_null(.vmx_load_cached_token(cache)) }) +test_that("a structurally invalid token cache is treated as corrupt", { + cache <- withr::local_tempfile(fileext = ".json") + invalid <- list( + list( + access_token = "", refresh_token = NULL, expires_at = 2000000000, + token_type = "Bearer", issuer = stripped_issuer, client_id = "test-cli" + ), + list( + access_token = "acc", refresh_token = NULL, expires_at = "not-a-number", + token_type = "Bearer", issuer = stripped_issuer, client_id = "test-cli" + ), + list( + access_token = "acc", refresh_token = NULL, expires_at = 2000000000, + token_type = "Bearer", issuer = "", client_id = "test-cli" + ) + ) + + for (value in invalid) { + writeLines( + jsonlite::toJSON(value, auto_unbox = TRUE, null = "null", na = "null"), + cache + ) + expect_null(.vmx_load_cached_token(cache)) + } +}) + +test_that("token-cache replacement failure is a classed auth error", { + cache <- withr::local_tempfile(fileext = ".json") + token <- .vmx_token( + access_token = "acc", refresh_token = "ref", + expires_at = as.numeric(Sys.time()) + 600, + token_type = "Bearer", issuer = issuer, client_id = "test-cli" + ) + testthat::local_mocked_bindings( + .vmx_atomic_rename = function(from, to) FALSE + ) + + expect_error( + .vmx_save_cached_token(token, cache), + "atomically replace", + class = "vmx_auth_error" + ) +}) + test_that("expired cached token is silently refreshed and re-cached", { cache <- withr::local_tempfile(fileext = ".json") local_oidc_env(cache) diff --git a/tests/testthat/test-poll.R b/tests/testthat/test-poll.R new file mode 100644 index 0000000..168d136 --- /dev/null +++ b/tests/testthat/test-poll.R @@ -0,0 +1,86 @@ +test_that("polling fails immediately on an unrequested terminal failure", { + fetches <- 0L + fetch <- function(id) { + fetches <<- fetches + 1L + list( + status = "failed", + failure_reason = "The worker exceeded its execution time limit." + ) + } + + err <- tryCatch( + vmx_poll_status( + "job_1", fetch, + success = "succeeded", + failed = "failed", + known = c("queued", "succeeded", "failed"), + until = "succeeded", + timeout = 1, + interval = 0.001, + progress = FALSE, + label = "Job" + ), + vmx_job_error = function(e) e + ) + + expect_s3_class(err, "vmx_job_error") + expect_equal(err$resource_status, "failed") + expect_match(conditionMessage(err), "execution time limit") + expect_equal(fetches, 1L) +}) + +test_that("polling does not wait forever after an unrequested success", { + fetches <- 0L + fetch <- function(id) { + fetches <<- fetches + 1L + list(status = "succeeded") + } + + expect_error( + vmx_poll_status( + "job_1", fetch, + success = "succeeded", + failed = "failed", + known = c("queued", "succeeded", "failed"), + until = "failed", + timeout = 1, + interval = 0.001, + progress = FALSE, + label = "Job" + ), + "before the requested status", + class = "vmx_job_error" + ) + expect_equal(fetches, 1L) +}) + +test_that("polling validates controls and closed status vocabularies", { + fetch <- function(id) list(status = "new_server_state") + args <- list( + id = "job_1", + fetch = fetch, + success = "succeeded", + failed = "failed", + known = c("queued", "succeeded", "failed"), + timeout = 1, + interval = 0.001, + progress = FALSE, + label = "Job" + ) + + expect_error( + do.call(vmx_poll_status, c(args, list(until = "not-a-status"))), + class = "vmx_usage_error" + ) + expect_error( + do.call( + vmx_poll_status, + utils::modifyList(args, list(until = NULL, timeout = Inf)) + ), + class = "vmx_usage_error" + ) + expect_error( + do.call(vmx_poll_status, c(args, list(until = NULL))), + class = "vmx_response_error" + ) +}) diff --git a/tests/testthat/test-signatures.R b/tests/testthat/test-signatures.R new file mode 100644 index 0000000..0bd14f8 --- /dev/null +++ b/tests/testthat/test-signatures.R @@ -0,0 +1,80 @@ +test_that("new options do not shift existing positional client arguments", { + expect_identical( + head(names(formals(vmx_treatments)), 2), + c("status", "client") + ) + expect_identical( + head(names(formals(vmx_studies)), 3), + c("treatment", "status", "client") + ) + expect_identical( + head(names(formals(vmx_upload)), 7), + c("study", "files", "mode", "treatment", "config", "wait", "client") + ) + expect_identical( + head(names(formals(vmx_datasets)), 3), + c("study", "treatment", "client") + ) + expect_identical( + head(names(formals(vmx_dataset_files)), 2), + c("dataset", "client") + ) + expect_identical( + head(names(formals(vmx_data_versions)), 5), + c( + "treatment", "study", "include_archived", "eligible_for_modeling", + "client" + ) + ) + expect_identical( + head(names(formals(vmx_nca_analyses)), 6), + c( + "data_version", "study", "treatment", "status", "time_basis", + "client" + ) + ) + expect_identical( + head(names(formals(vmx_model_build_runs)), 5), + c("data_version", "study", "treatment", "status", "client") + ) + expect_identical( + head(names(formals(vmx_model_build_logs)), 2), + c("run", "client") + ) + expect_identical( + head(names(formals(vmx_model_fits)), 6), + c("run", "data_version", "model_type", "marker_name", "status", "client") + ) + expect_identical( + head(names(formals(vmx_dosing_input)), 4), + c("fit", "dosing_text", "scenario_name", "client") + ) + expect_identical( + head(names(formals(vmx_sim_jobs)), 2), + c("fit", "client") + ) + expect_identical( + head(names(formals(vmx_analysis_log)), 8), + c( + "study", "kind", "event_type", "outcome", "severity", "since", + "resource", "client" + ) + ) + + collection_functions <- list( + vmx_treatments, + vmx_studies, + vmx_datasets, + vmx_dataset_files, + vmx_data_versions, + vmx_nca_analyses, + vmx_model_build_runs, + vmx_model_build_logs, + vmx_model_fits, + vmx_sim_jobs, + vmx_analysis_log + ) + for (fn in collection_functions) { + expect_false(any(c("cursor", "limit") %in% names(formals(fn)))) + } +}) diff --git a/tests/testthat/test-simulation.R b/tests/testthat/test-simulation.R index 88018ef..ca04d70 100644 --- a/tests/testthat/test-simulation.R +++ b/tests/testthat/test-simulation.R @@ -3,7 +3,33 @@ con <- vmx_client(base_url = "https://vmx.test", token = "pat_test") job_item <- function(id = "simjob_1", status = "queued") { - list(simulation_job_id = id, status = status) + terminal <- status %in% c("succeeded", "failed", "cancelled") + list( + simulation_job_id = id, + data_version_id = "dv_1", + model_fit_id = "mf_1", + run_id = "run_1", + source_pk_model_fit_id = NA_character_, + dosing_input_id = "simdose_1", + kind = "population", + status = status, + trigger_source = list( + type = "user", + user_id = "usr_1", + system_component = NA_character_, + reason = "user_request" + ), + retried_from = NA_character_, + created_at = "2026-04-28T12:00:00Z", + started_at = if (status == "queued") NA_character_ else "2026-04-28T12:00:05Z", + updated_at = "2026-04-28T12:00:30Z", + completed_at = if (terminal) "2026-04-28T12:10:00Z" else NA_character_, + failure_reason = if (status == "failed") { + "Simulation exceeded the runtime limit." + } else { + NA_character_ + } + ) } capture_one <- function(body) { env <- new.env() @@ -13,12 +39,17 @@ capture_one <- function(body) { }, env = parent.frame()) env } -di <- new_vmx_resource(list(dosing_input_id = "di_1"), "vmx_dosing_input", "dosing_input_id") +di <- new_vmx_resource( + list(dosing_input_id = "simdose_1"), + "vmx_dosing_input", + "dosing_input_id" +) test_that("vmx_dosing_input posts text + scenario_names", { - env <- capture_one(list(dosing_input_id = "di_9")) + env <- capture_one(list(dosing_input_id = "simdose_9")) d <- vmx_dosing_input("mf_1", "100 mg qd x7", c("s1", "s2"), client = con) expect_s3_class(d, "vmx_dosing_input") + expect_equal(vmx_resource_id(d), "simdose_9") expect_equal(env$req$body$data$dosing_text, "100 mg qd x7") expect_equal(env$req$body$data$scenario_names, list("s1", "s2")) expect_match(env$req$url, "/model-fits/mf_1/simulation-dosing-inputs$") @@ -26,9 +57,22 @@ test_that("vmx_dosing_input posts text + scenario_names", { test_that("vmx_dosing_input_status fetches dosing input status", { httr2::local_mocked_responses(list(httr2::response_json(body = list( - dosing_input_id = "di_1", status = "succeeded" + dosing_input_id = "simdose_1", + model_fit_id = "mf_1", + status = "succeeded", + dosing_text = "100 mg once daily for 7 days", + description = "One oral dose every 24 hours for 7 days.", + assumptions = list(), + error_reason = NA_character_, + error_message = NA_character_, + trigger_source = list( + type = "user", user_id = "usr_1", reason = "simulation_dosing_input" + ), + created_at = "2026-06-01T12:00:00Z", + updated_at = "2026-06-01T12:00:05Z", + completed_at = "2026-06-01T12:00:05Z" )))) - out <- vmx_dosing_input_status("di_1", client = con) + out <- vmx_dosing_input_status("simdose_1", client = con) expect_s3_class(out, "vmx_dosing_input") expect_equal(out$status, "succeeded") }) @@ -39,7 +83,7 @@ test_that("vmx_sim_existing_subject builds subject records from a data.frame", { job <- vmx_sim_existing_subject("mf_1", di, subj, client = con) expect_s3_class(job, "vmx_simulation_job") body <- env$req$body$data - expect_equal(body$dosing_input_id, "di_1") + expect_equal(body$dosing_input_id, "simdose_1") expect_equal(body$subjects[[1]], list(gen_subject_uuid = "u1", subject_name = "A")) expect_match(env$req$url, "/existing-subject-simulation-jobs$") }) @@ -73,13 +117,38 @@ test_that("vmx_sim_hypothetical_subject_from_text nests covariates", { test_that("vmx_sim_population posts scenario_name", { env <- capture_one(job_item("simjob_9")) - vmx_sim_population("mf_1", "di_1", "high-dose", min_timepoints = 300, client = con) - expect_equal(env$req$body$data$dosing_input_id, "di_1") + vmx_sim_population( + "mf_1", "simdose_1", "high-dose", min_timepoints = 300, client = con + ) + expect_equal(env$req$body$data$dosing_input_id, "simdose_1") expect_equal(env$req$body$data$scenario_name, "high-dose") expect_equal(env$req$body$data$min_timepoints, 300) expect_match(env$req$url, "/population-simulation-jobs$") }) +test_that("simulation creation validates bounded controls and retry ids", { + expect_error( + vmx_sim_population( + "mf_1", "simdose_1", "high-dose", + min_timepoints = 9, client = con + ), + class = "vmx_usage_error" + ) + expect_error( + vmx_sim_population( + "mf_1", "simdose_1", "high-dose", + retried_from = "run_wrong", client = con + ), + class = "vmx_usage_error" + ) + expect_error( + vmx_dosing_input( + "mf_1", "100 mg qd", c("same", "same"), client = con + ), + class = "vmx_usage_error" + ) +}) + test_that("vmx_sim_population_from_text posts dosing text", { env <- capture_one(job_item("simjob_9")) vmx_sim_population_from_text("mf_1", "100 mg qd", "high-dose", client = con) @@ -90,7 +159,9 @@ test_that("vmx_sim_population_from_text posts dosing text", { test_that("vmx_sim_jobs lists jobs for a fit", { httr2::local_mocked_responses(list(httr2::response_json(body = list( - items = list(job_item("simjob_1", "succeeded")), next_cursor = NULL + items = list(job_item("simjob_1", "succeeded")), + next_cursor = NA_character_, + has_next_page = FALSE )))) out <- vmx_sim_jobs("mf_1", client = con) expect_equal(out$simulation_job_id, "simjob_1") @@ -99,6 +170,15 @@ test_that("vmx_sim_jobs lists jobs for a fit", { test_that("vmx_sim_status / cancel type the result", { httr2::local_mocked_responses(list(httr2::response_json(body = job_item("simjob_1", "running")))) expect_s3_class(vmx_sim_status("simjob_1", client = con), "vmx_simulation_job") + + httr2::local_mocked_responses(list(httr2::response_json(body = list( + simulation_job_id = "simjob_1", + status = "cancelling", + cancel_requested_at = "2026-04-28T12:01:00Z" + )))) + cancelled <- vmx_sim_cancel("simjob_1", client = con) + expect_s3_class(cancelled, "vmx_simulation_job") + expect_equal(cancelled$status, "cancelling") }) test_that("vmx_wait on a sim job polls to success and raises on failure", { @@ -107,11 +187,11 @@ test_that("vmx_wait on a sim job polls to success and raises on failure", { httr2::response_json(body = job_item("simjob_1", "succeeded")) )) job <- new_vmx_resource(job_item("simjob_1"), "vmx_simulation_job", "simulation_job_id") - out <- vmx_wait(job, interval = 0, progress = FALSE, client = con) + out <- vmx_wait(job, interval = 0.001, progress = FALSE, client = con) expect_equal(out$status, "succeeded") httr2::local_mocked_responses(list(httr2::response_json(body = job_item("simjob_1", "failed")))) - expect_error(vmx_wait(job, interval = 0, progress = FALSE, client = con), + expect_error(vmx_wait(job, interval = 0.001, progress = FALSE, client = con), class = "vmx_api_error") }) @@ -120,7 +200,94 @@ test_that("sim create with wait=TRUE forwards polling controls", { httr2::response_json(body = job_item("simjob_9", "queued")), # create httr2::response_json(body = job_item("simjob_9", "succeeded")) # poll )) - job <- vmx_sim_population("mf_1", "di_1", "s", wait = TRUE, interval = 0, + job <- vmx_sim_population("mf_1", "simdose_1", "s", wait = TRUE, interval = 0.001, progress = FALSE, client = con) expect_equal(job$status, "succeeded") }) + +test_that("vmx_sim_result preserves server-provided trajectory semantics", { + env <- capture_one(list( + schema_version = "vmm.simulation_summary.v1", + simulation_version_id = "sv_1", + model_fit_id = "mf_1", + model_type = "pk", + time_basis = "observed", + simulation_kind = "population", + simulation_description = paste( + "Estimate value and server-provided interval of simulated population-level", + "concentration and quantities grouped over simulated subjects." + ), + scenario_name = "population high-dose scenario", + grouping_variable = "dose_group", + units = list(time = "h", concentration = "ng/mL"), + series = list(list( + group_name = "dose_group", + group_level = "simulated: high", + time = list(0, 1, 2), + pk = list( + concentration = list( + name = "concentration", + model_type = "pk", + unit = "ng/mL", + value_statistic = "mean", + value = list(0, 10, 8), + interval = list( + kind = "confidence", + level = 0.8, + lower = list(0, 8, 6), + upper = list(0, 12, 10) + ) + ) + ) + )), + quantities = list( + summary_description = paste( + "Estimate value and server-provided interval of simulated", + "population-level quantities grouped over simulated subjects." + ), + group_name = "dose_group", + group_level = list("simulated: high"), + rows = list() + ) + )) + out <- vmx_sim_result( + "simjob_1", grouping_variable = "dose_group", client = con + ) + estimate <- out$series[[1]]$pk$concentration + expect_equal(estimate$value_statistic, "mean") + expect_equal(estimate$interval$kind, "confidence") + expect_equal(estimate$interval$level, 0.8) + expect_match(env$req$url, "grouping_variable=dose_group") +}) + +test_that("vmx_sim_result rejects an ambiguous grouping variable", { + expect_error( + vmx_sim_result( + "simjob_1", grouping_variable = c("arm", "dose_group"), client = con + ), + class = "vmx_usage_error" + ) +}) + +test_that("vmx_sim_result rejects a malformed success payload", { + env <- capture_one(list( + schema_version = "vmm.simulation_summary.v1", + simulation_version_id = "sv_1", + model_fit_id = "mf_1", + model_type = "pk", + time_basis = "observed", + simulation_kind = "population", + quantities = list() + )) + expect_error( + vmx_sim_result("simjob_1", client = con), + class = "vmx_response_error" + ) +}) + +test_that("simulation rejects legacy dosing-input ids", { + expect_error( + vmx_sim_population("mf_1", "di_1", "high-dose", client = con), + class = "vmx_usage_error" + ) +}) diff --git a/tests/testthat/test-studies-data-versions.R b/tests/testthat/test-studies-data-versions.R index 49850d6..9fa1525 100644 --- a/tests/testthat/test-studies-data-versions.R +++ b/tests/testthat/test-studies-data-versions.R @@ -29,17 +29,66 @@ dv_item <- function(id, study = "std_1") { source_dataset_id = "ds_1", status = "ready", eligible_for_modeling = TRUE) } -test_that("vmx_studies filters by treatment and paginates into a tibble", { +test_that("vmx_studies combines filtered pages automatically", { cm <- capturing_mock(list( - list(items = list(study_item("std_1", "A")), next_cursor = "c1"), - list(items = list(study_item("std_2", "B")), next_cursor = NULL) + list( + items = list(study_item("std_1", "A")), + next_cursor = "c1", + has_next_page = TRUE + ), + list( + items = list(study_item("std_2", "B")), + next_cursor = NA_character_, + has_next_page = FALSE + ) )) httr2::local_mocked_responses(cm$mock) - tbl <- vmx_studies("tmt_1", client = con) - expect_equal(nrow(tbl), 2L) - expect_equal(tbl$study_id, c("std_1", "std_2")) + out <- vmx_studies("tmt_1", client = con) + expect_equal(out$study_id, c("std_1", "std_2")) # treatment_id forwarded as a query param expect_match(cm$captured$req$url, "treatment_id=tmt_1") + expect_match(cm$captured$req$url, "cursor=c1") +}) + +test_that("vmx_studies forwards a validated created_since filter", { + cm <- capturing_mock(list( + items = list(), + next_cursor = NA_character_, + has_next_page = FALSE + )) + httr2::local_mocked_responses(cm$mock) + + vmx_studies( + created_since = as.POSIXct("2026-01-02 03:04:05", tz = "UTC"), + client = con + ) + + expect_match( + utils::URLdecode(cm$captured$req$url), + "created_since=2026-01-02T03:04:05Z", + fixed = TRUE + ) +}) + +test_that("collection flattening keeps nested arrays in one row", { + markers <- list( + list(name = "effect", type = "continuous"), + list(name = "response", type = "count") + ) + item <- study_item("std_1", "A") + item$pd_markers <- markers + cm <- capturing_mock(list( + items = list(item), + next_cursor = NA_character_, + has_next_page = FALSE + )) + httr2::local_mocked_responses(cm$mock) + + tbl <- vmx_studies(client = con) + + expect_equal(nrow(tbl), 1L) + expect_type(tbl$pd_markers, "list") + expect_equal(tbl$pd_markers[[1]], markers) }) test_that("vmx_studies rejects a non-treatment id", { @@ -66,8 +115,36 @@ test_that("vmx_study_create accepts a vmx_treatment object", { expect_equal(cm$captured$req$body$data$treatment_id, "tmt_7") }) +test_that("vmx_study_update preserves an explicitly supplied JSON null", { + cm <- capturing_mock(study_item("std_1", "A")) + httr2::local_mocked_responses(cm$mock) + + vmx_study_update( + "std_1", + route_of_administration = NULL, + client = con + ) + + body <- cm$captured$req$body$data + expect_true("route_of_administration" %in% names(body)) + expect_null(body$route_of_administration) + + expect_error( + vmx_study_update("std_1", pd_markers = NULL, client = con), + class = "vmx_usage_error" + ) + expect_error( + vmx_study_update("std_1", status = NULL, client = con), + class = "vmx_usage_error" + ) +}) + test_that("vmx_data_versions forwards filters as query params", { - cm <- capturing_mock(list(items = list(dv_item("dv_1")), next_cursor = NULL)) + cm <- capturing_mock(list( + items = list(dv_item("dv_1")), + next_cursor = NA_character_, + has_next_page = FALSE + )) httr2::local_mocked_responses(cm$mock) tbl <- vmx_data_versions(study = "std_1", eligible_for_modeling = TRUE, client = con) expect_equal(nrow(tbl), 1L) @@ -78,7 +155,11 @@ test_that("vmx_data_versions forwards filters as query params", { }) test_that("vmx_data_versions accepts a vmx_study object", { - cm <- capturing_mock(list(items = list(dv_item("dv_1", study = "std_7")), next_cursor = NULL)) + cm <- capturing_mock(list( + items = list(dv_item("dv_1", study = "std_7")), + next_cursor = NA_character_, + has_next_page = FALSE + )) httr2::local_mocked_responses(cm$mock) study <- new_vmx_resource(list(study_id = "std_7"), "vmx_study", "study_id") vmx_data_versions(study = study, client = con) @@ -103,6 +184,46 @@ test_that("vmx_data_version_create posts upload_ids and returns a prep-status", expect_match(cm$captured$req$url, "/datasets/ds_1/data-versions$") }) +test_that("vmx_data_version_create validates its upload composition", { + expect_error( + vmx_data_version_create("ds_1", uploads = character(), client = con), + class = "vmx_usage_error" + ) + expect_error( + vmx_data_version_create("ds_1", uploads = "ds_wrong", client = con), + class = "vmx_usage_error" + ) + expect_error( + vmx_data_version_create( + "ds_1", uploads = c("upl_a", "upl_a"), client = con + ), + class = "vmx_usage_error" + ) +}) + +test_that("vmx_data_version_export requires the canonical matching envelope", { + cm <- capturing_mock(list( + data_version_id = "dv_1", + download_url = "https://storage.test/signed", + expires_at = "2026-01-01T01:00:00Z", + byte_size = 10, + files = list() + )) + httr2::local_mocked_responses(cm$mock) + out <- vmx_data_version_export("dv_1", client = con) + expect_equal(out$download_url, "https://storage.test/signed") + + cm2 <- capturing_mock(list( + data_version_id = "dv_other", + download_url = "https://storage.test/signed" + )) + httr2::local_mocked_responses(cm2$mock) + expect_error( + vmx_data_version_export("dv_1", client = con), + class = "vmx_response_error" + ) +}) + test_that("archive/unarchive PATCH the right body", { cm <- capturing_mock(dv_item("dv_1")) httr2::local_mocked_responses(cm$mock) diff --git a/vignettes/getting-started.Rmd b/vignettes/getting-started.Rmd index 293e0a6..ad25644 100644 --- a/vignettes/getting-started.Rmd +++ b/vignettes/getting-started.Rmd @@ -54,12 +54,13 @@ vmx_nca_result(nca) dv <- vmx_data_version("dv_...") # tidy domain tables -vmx_pk(dv) # PK observations + events +vmx_pk(dv) # PK observations +vmx_dosing(dv) # dosing events vmx_subjects(dv) # one row per subject (covariates) # or the whole bundle at once md <- vmx_model_data(dv) -md$pk; md$subjects; md$meta +md$pk; md$dosing; md$subjects; md$meta ``` ## Fit a model and pull diagnostics @@ -68,7 +69,7 @@ md$pk; md$subjects; md$meta run <- vmx_model_build(dv, time_basis = "observed", wait = TRUE) fit <- vmx_model_fits(run = run) |> dplyr::slice(1) |> dplyr::pull(model_fit_id) |> vmx_model_fit() -vmx_fit_global_estimates(fit) # population parameters + credible intervals +vmx_fit_global_estimates(fit) # population estimates + server-defined intervals vmx_fit_obs_vs_pred(fit) # tidy observed-vs-predicted ```