From 78163b9e81568db38aad04f04b29244afa8aeefa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Juli=C3=A1n=20D=2E=20Ot=C3=A1lvaro?= Date: Mon, 17 Nov 2025 20:12:42 +0000 Subject: [PATCH 1/4] wip: remote executions. They kinda work, the execution is done but I'm having some problems parsing the OP object. --- Cargo.lock | 9 +- DESCRIPTION | 2 + R/PM_data.R | 3411 ++++++++++++------------ R/PM_model.R | 4126 +++++++++++++++-------------- R/PMoptions.R | 435 +-- R/PMutilities.R | 1798 ++++++------- R/hermes_remote_client.R | 222 ++ R/hermes_remote_config.R | 324 +++ R/hermes_remote_result.R | 589 ++++ R/options.R | 233 +- inst/options/PMoptions.json | 11 +- scripts/bke_remote.R | 165 ++ scripts/bke_remote_raw.R | 128 + scripts/capture_bke_payload.R | 54 + scripts/inspect_bke_fit_payload.R | 65 + scripts/inspect_cycle_log.R | 63 + src/rust/Cargo.toml | 2 +- src/rust/src/executor.rs | 2 +- 18 files changed, 6729 insertions(+), 4910 deletions(-) create mode 100644 R/hermes_remote_client.R create mode 100644 R/hermes_remote_config.R create mode 100644 R/hermes_remote_result.R create mode 100644 scripts/bke_remote.R create mode 100644 scripts/bke_remote_raw.R create mode 100644 scripts/capture_bke_payload.R create mode 100644 scripts/inspect_bke_fit_payload.R create mode 100644 scripts/inspect_cycle_log.R diff --git a/Cargo.lock b/Cargo.lock index 3c31d49bd..6fb2beda5 100755 --- a/Cargo.lock +++ b/Cargo.lock @@ -1286,9 +1286,9 @@ dependencies = [ [[package]] name = "pharmsol" -version = "0.20.0" +version = "0.21.0" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "98b8e2ab3a0e91cd4b20c28544cb3676e8df31aa490cf5680ec0531259b5fa4e" +checksum = "2fc25564d039d0cd5701013aa3785a339b14cf0b51409d7b817320bc360dc944" dependencies = [ "argmin", "argmin-math", @@ -1328,13 +1328,12 @@ dependencies = [ [[package]] name = "pmcore" -version = "0.21.1" +version = "0.22.0" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "703e83f4a6a919cc60b85936d560840947b1b07a2d8ccfa7c87144d1722b6d63" +checksum = "2719d343acdd4f12da31b87a851b7fb378ecd9cc580068326b7471ae76624029" dependencies = [ "anyhow", "argmin", - "argmin-math", "csv", "faer", "faer-ext", diff --git a/DESCRIPTION b/DESCRIPTION index a9f40c9e2..dd10c8d6b 100755 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -30,6 +30,7 @@ Imports: ggplot2, ggraph, htmlwidgets, + httr2, jsonlite, lifecycle, lubridate, @@ -41,6 +42,7 @@ Imports: R6, readr, remotes, + keyring, rlang, rmarkdown, shiny, diff --git a/R/PM_data.R b/R/PM_data.R index 89170e02e..f75f09ba8 100755 --- a/R/PM_data.R +++ b/R/PM_data.R @@ -36,402 +36,402 @@ #' #' @export PM_data <- R6::R6Class("PM_data", -public <- list( - #' @field data Data frame containing the data to be modeled - data = NULL, - #' @field standard_data Data frame containing standardized version of the data - standard_data = NULL, - #' @field pop The `$data` field from a [PM_pop] object. This makes it easy to add population predictions to a raw data plot. This field will be `NULL` until the [PM_data] object is added to the [PM_result] after a run. As examples: - #' * `dat <- PM_data$new("data.csv")`. Here, `dat$pop` will be `NULL`. - #' * `run1 <- PM_load(1)`. Here, `run1$data$pop` will be the same as `run1$pop$data`. - pop = NULL, - #' @field post The `$data` field from a [PM_post] object. See details in the `pop` argument above. - post = NULL, - #' @description - #' Create new data object - #' @details - #' Creation of a new [PM_data] objects from a file or - #' a data frame. Data will be standardized and checked - #' automatically to a fully specified, valid data object. - #' @param data A quoted name of a file with full path if not - #' in the working directory, an unquoted name of a data frame - #' in the current R environment, or a [PM_data] object, which will rebuild it. - #' @param dt Pmetrics will try a variety of date/time formats. If all 16 of - #' them fail, use this parameter to specify the correct format as a - #' character vector whose - #' first element is date format and second is time. Use the following abbreviations: - #' * Y = 4 digit year - #' * y = 2 digit year - #' * m = decimal month (1, 2, ..., 12) - #' * d = decimal day (1, 2, ..., 31) - #' * H = hours (0-23) - #' * M = minutes (0-59) - #' Example: `format = c("myd", "mh")`. Not one of the tried combinations! - #' Always check to make sure that dates/times were parsed correctly and the - #' relative times in the `PM_data$standard_data` field look correct. - #' Other date/time formats are possible. See [lubridate::parse_date_time()] for these. - #' @param quiet Quietly validate. Default is `FALSE`. - #' @param validate Check for errors. Default is `TRUE`. Strongly recommended. - #' @param ... Other arguments (not currently used). - initialize = function( + public <- list( + #' @field data Data frame containing the data to be modeled data = NULL, - dt = NULL, - quiet = FALSE, - validate = TRUE, - ...) { + #' @field standard_data Data frame containing standardized version of the data + standard_data = NULL, + #' @field pop The `$data` field from a [PM_pop] object. This makes it easy to add population predictions to a raw data plot. This field will be `NULL` until the [PM_data] object is added to the [PM_result] after a run. As examples: + #' * `dat <- PM_data$new("data.csv")`. Here, `dat$pop` will be `NULL`. + #' * `run1 <- PM_load(1)`. Here, `run1$data$pop` will be the same as `run1$pop$data`. + pop = NULL, + #' @field post The `$data` field from a [PM_post] object. See details in the `pop` argument above. + post = NULL, + #' @description + #' Create new data object + #' @details + #' Creation of a new [PM_data] objects from a file or + #' a data frame. Data will be standardized and checked + #' automatically to a fully specified, valid data object. + #' @param data A quoted name of a file with full path if not + #' in the working directory, an unquoted name of a data frame + #' in the current R environment, or a [PM_data] object, which will rebuild it. + #' @param dt Pmetrics will try a variety of date/time formats. If all 16 of + #' them fail, use this parameter to specify the correct format as a + #' character vector whose + #' first element is date format and second is time. Use the following abbreviations: + #' * Y = 4 digit year + #' * y = 2 digit year + #' * m = decimal month (1, 2, ..., 12) + #' * d = decimal day (1, 2, ..., 31) + #' * H = hours (0-23) + #' * M = minutes (0-59) + #' Example: `format = c("myd", "mh")`. Not one of the tried combinations! + #' Always check to make sure that dates/times were parsed correctly and the + #' relative times in the `PM_data$standard_data` field look correct. + #' Other date/time formats are possible. See [lubridate::parse_date_time()] for these. + #' @param quiet Quietly validate. Default is `FALSE`. + #' @param validate Check for errors. Default is `TRUE`. Strongly recommended. + #' @param ... Other arguments (not currently used). + initialize = function( + data = NULL, + dt = NULL, + quiet = FALSE, + validate = TRUE, + ...) { if (is.character(data)) { # filename self$data <- rlang::try_fetch(Pmetrics:::PMreadMatrix(data, quiet = TRUE), - error = function(e) { - cli::cli_abort("Unable to create {.cls PM_data} object", parent = e) - return(NULL) + error = function(e) { + cli::cli_abort("Unable to create {.cls PM_data} object", parent = e) + return(NULL) + } + ) + } else if (inherits(data, "PM_data")) { # R6 + self$data <- data$data + } else { # something else + self$data <- data + } + + if (!is.null(self$data) && validate) { + self$standard_data <- private$validate(self$data, quiet = quiet, dt = dt) + } + }, + #' @description + #' Save data to file + #' @details + #' Saves a delimited file (e.g. comma-separated) + #' from the `standard_data` field + #' @param file_name A quoted name of the file to create + #' with full path if not + #' in the working directory. + #' @param ... Arguments passed to [PMwriteMatrix] + save = function(file_name, ...) { + if (!is.null(self$standard_data)) { + PMwriteMatrix(self$standard_data, file_name, ...) + } else { + cli::cli_warn("Create a validated {.cls PM_data} object before writing.") + } + }, + #' @description + #' Calculate AUC + #' @details + #' See [makeAUC]. + #' @param ... Arguments passed to [makeAUC]. + auc = function(...) { + if (!is.null(self$data)) { + rlang::try_fetch(makeAUC(self, ...), + error = function(e) { + cli::cli_warn("Unable to generate AUC.", parent = e) + return(NULL) + } + ) + } else { + cli::cli_warn("Data have not been defined.") + } + }, + #' @description + #' Perform non-compartmental analysis + #' @details + #' See [makeNCA]. + #' @param ... Arguments passed to [makeNCA]. + nca = function(...) { + if (!is.null(self$data)) { + makeNCA(self, ...) + } else { + cli::cli_warn("Data have not been defined.") + } + }, + #' @description + #' Plot method + #' @details + #' See [plot.PM_data]. + #' @param ... Arguments passed to [plot.PM_data] + plot = function(...) { + if (!is.null(self$data)) { + plot.PM_data(self, ...) + } else { + cli::cli_warn("Data have not been defined.") + } + }, + #' @description + #' Print method + #' @details + #' Displays the PM_data object in a variety of ways. + #' @param standard Display the standardized data if `TRUE`. + #' Default is `FALSE`. + #' @param viewer Display the Viewer if `TRUE`. + #' Default is \code{TRUE}. + #' @param ... Other arguments to [print.data.frame]. Only + #' passed if `viewer = FALSE`. + print = function(standard = F, viewer = T, ...) { + if (is.null(self$data)) { + cat("NULL data") + return(invisible(self)) + } + if (standard) { + what <- self$standard_data + title <- "Standardized Data" + } else { + what <- self$data + title <- "Data" + } + if (viewer) { + View(what, title = title) + } else { + print(what, ...) + } + return(invisible(self)) + }, + #' @description + #' Summary method + #' @details + #' See [summary.PM_data]. + #' @param ... Arguments passed to [summary.PM_data]. + summary = function(...) { + if (!is.null(self$standard_data)) { + summary.PM_data(self$standard_data, ...) + } else { + cli::cli_warn("Create a validated PM_data object before summarizing.") + } + }, + #' @description + #' Add events to PM_data object + #' @details + #' Add lines to a PM_data object by supplying named columns and values. + #' `ID` is always required. `Time` is handled differently depending on + #' the sequence of `addEvent` calls (see **Chaining** below). + #' * It is required for the first call to `addEvent` and should be 0. + #' For example: For example: `dat <- PM_data$new()$addEvent(id = 1, time = 0, dose = 100, addl = 5, ii = 24)` + #' * For subsequent calls to `addEvent` with specific times it should be included. + #' For example: `dat <- PM_data$new()$addEvent(id = 1, time = 0, dose = 100, addl = 5, ii = 24)$addEvent(id = 1, time = 144, out = -1)` + #' Here, because `out` wasn't in the original call *and* the next call contains a value for + #' `time`, an `out` value of -1 will be added at time 144 and `out` will be set to `NA` for all the + #' previous rows. + #' * In contrast, the behavior is different if you omit `time` when your + #' data object already has rows. In this case + #' the arguments in the call to `addEvent` (without a value for `time`) + #' will add those arguments as columns in the prior data with the specified value + #' or *replace* values in those columns if they + #' already exist. Be sure this is what you want. + #' For example, building on the prior example: `dat$addEvent(id = 1, dur = 0.5)`. + #' Note that we can chain to the previously created `dat` object. Here, a duration of 0.5 hours + #' will be added to every previous row in `dat` to create the new `dat` object, but no new + #' row is added since there is no `time` associated with it. + #' + #' Adding covariates is supported, but since valid subject records in Pmetrics + #' with covariates must contain non-missing values at time 0, covariates should + #' be included with the first call to `$addEvent()`. + #' + #' As we have seen in the examples above, `ADDL` and `II` are supported. + #' + #' **Chaining** Multiple `$addEvent()` calls can be chained with `PM_data$new()` + #' to create a blank data object and then add rows. + #' This can be particularly useful for creating simulation templates. + #' See the example. + #' @param ... Column names and values. + #' @param dt Pmetrics will try a variety of date/time formats. If all 16 of + #' them fail, use this parameter to specify the correct format as a + #' character vector whose + #' first element is date format and second is time. Use the following abbreviations: + #' * Y = 4 digit year + #' * y = 2 digit year + #' * m = decimal month (1, 2, ..., 12) + #' * d = decimal day (1, 2, ..., 31) + #' * H = hours (0-23) + #' * M = minutes (0-59) + #' Example: `format = c("myd", "mh")`. Not one of the tried combinations! + #' Always check to make sure that dates/times were parsed correctly and the + #' relative times in the `PM_data$standard_data` field look correct. + #' Other date/time formats are possible. See [lubridate::parse_date_time()] for these. + #' @param quiet Quietly validate. Default is `FALSE`. + #' @param validate Validate the new row or not. Default is `FALSE` as a new row + #' added to a blank will result in a one-row data object, which is invalid. Also, + #' only one event type (dose or observation) should be added at a time, so if the + #' new object contains only doses while building, this would cause an error. You + #' should set `validate = TRUE` for the final addition. + #' @examples + #' \dontrun{ + #' PM_data$new()$addEvent(id = 1, time = 0, dose = 100, addl = 4, ii = 12, + #' out = NA, wt = 75)$addEvent(id = 1, time = 60, out = -1) + #' } + + addEvent = function(..., dt = NULL, quiet = FALSE, validate = FALSE) { + args <- list(...) + arg_names <- tolower(names(args)) + + if (!"id" %in% arg_names) { + cli::cli_abort(c("x" = "ID is required to add an event.")) + } + to_add <- data.frame(args) + + if (!is.null(self$data)) { # existing data + old_names <- names(self$data) + missing_args <- arg_names[!arg_names %in% old_names] + if (length(missing_args) > 0) { + self$data[missing_args] <- NA + } + if (!"time" %in% arg_names) { + to_add <- to_add %>% dplyr::slice(rep(1, each = nrow(self$data))) + self$data[arg_names] <- to_add + if (validate) { + self$data <- self$data %>% dplyr::select(where(~ !all(is.na(.x)))) # clean up + self$standard_data <- private$validate(self$data, dt = dt, quiet = quiet) + } else { + self$standard_data <- NULL + } + return(invisible(self)) + } + } else { + if (!"time" %in% arg_names) { + cli::cli_abort(c("x" = "Time is required to add the first event.")) } - ) - } else if (inherits(data, "PM_data")) { # R6 - self$data <- data$data - } else { # something else - self$data <- data - } - - if (!is.null(self$data) && validate) { - self$standard_data <- private$validate(self$data, quiet = quiet, dt = dt) - } - }, - #' @description - #' Save data to file - #' @details - #' Saves a delimited file (e.g. comma-separated) - #' from the `standard_data` field - #' @param file_name A quoted name of the file to create - #' with full path if not - #' in the working directory. - #' @param ... Arguments passed to [PMwriteMatrix] - save = function(file_name, ...) { - if (!is.null(self$standard_data)) { - PMwriteMatrix(self$standard_data, file_name, ...) - } else { - cli::cli_warn("Create a validated {.cls PM_data} object before writing.") - } - }, - #' @description - #' Calculate AUC - #' @details - #' See [makeAUC]. - #' @param ... Arguments passed to [makeAUC]. - auc = function(...) { - if (!is.null(self$data)) { - rlang::try_fetch(makeAUC(self, ...), - error = function(e) { - cli::cli_warn("Unable to generate AUC.", parent = e) - return(NULL) } - ) - } else { - cli::cli_warn("Data have not been defined.") - } -}, -#' @description -#' Perform non-compartmental analysis -#' @details -#' See [makeNCA]. -#' @param ... Arguments passed to [makeNCA]. -nca = function(...) { - if (!is.null(self$data)) { - makeNCA(self, ...) - } else { - cli::cli_warn("Data have not been defined.") - } -}, -#' @description -#' Plot method -#' @details -#' See [plot.PM_data]. -#' @param ... Arguments passed to [plot.PM_data] -plot = function(...) { - if (!is.null(self$data)) { - plot.PM_data(self, ...) - } else { - cli::cli_warn("Data have not been defined.") - } -}, -#' @description -#' Print method -#' @details -#' Displays the PM_data object in a variety of ways. -#' @param standard Display the standardized data if `TRUE`. -#' Default is `FALSE`. -#' @param viewer Display the Viewer if `TRUE`. -#' Default is \code{TRUE}. -#' @param ... Other arguments to [print.data.frame]. Only -#' passed if `viewer = FALSE`. -print = function(standard = F, viewer = T, ...) { - if (is.null(self$data)) { - cat("NULL data") - return(invisible(self)) - } - if (standard) { - what <- self$standard_data - title <- "Standardized Data" - } else { - what <- self$data - title <- "Data" - } - if (viewer) { - View(what, title = title) - } else { - print(what, ...) - } - return(invisible(self)) -}, -#' @description -#' Summary method -#' @details -#' See [summary.PM_data]. -#' @param ... Arguments passed to [summary.PM_data]. -summary = function(...) { - if (!is.null(self$standard_data)) { - summary.PM_data(self$standard_data, ...) - } else { - cli::cli_warn("Create a validated PM_data object before summarizing.") - } -}, -#' @description -#' Add events to PM_data object -#' @details -#' Add lines to a PM_data object by supplying named columns and values. -#' `ID` is always required. `Time` is handled differently depending on -#' the sequence of `addEvent` calls (see **Chaining** below). -#' * It is required for the first call to `addEvent` and should be 0. -#' For example: For example: `dat <- PM_data$new()$addEvent(id = 1, time = 0, dose = 100, addl = 5, ii = 24)` -#' * For subsequent calls to `addEvent` with specific times it should be included. -#' For example: `dat <- PM_data$new()$addEvent(id = 1, time = 0, dose = 100, addl = 5, ii = 24)$addEvent(id = 1, time = 144, out = -1)` -#' Here, because `out` wasn't in the original call *and* the next call contains a value for -#' `time`, an `out` value of -1 will be added at time 144 and `out` will be set to `NA` for all the -#' previous rows. -#' * In contrast, the behavior is different if you omit `time` when your -#' data object already has rows. In this case -#' the arguments in the call to `addEvent` (without a value for `time`) -#' will add those arguments as columns in the prior data with the specified value -#' or *replace* values in those columns if they -#' already exist. Be sure this is what you want. -#' For example, building on the prior example: `dat$addEvent(id = 1, dur = 0.5)`. -#' Note that we can chain to the previously created `dat` object. Here, a duration of 0.5 hours -#' will be added to every previous row in `dat` to create the new `dat` object, but no new -#' row is added since there is no `time` associated with it. -#' -#' Adding covariates is supported, but since valid subject records in Pmetrics -#' with covariates must contain non-missing values at time 0, covariates should -#' be included with the first call to `$addEvent()`. -#' -#' As we have seen in the examples above, `ADDL` and `II` are supported. -#' -#' **Chaining** Multiple `$addEvent()` calls can be chained with `PM_data$new()` -#' to create a blank data object and then add rows. -#' This can be particularly useful for creating simulation templates. -#' See the example. -#' @param ... Column names and values. -#' @param dt Pmetrics will try a variety of date/time formats. If all 16 of -#' them fail, use this parameter to specify the correct format as a -#' character vector whose -#' first element is date format and second is time. Use the following abbreviations: -#' * Y = 4 digit year -#' * y = 2 digit year -#' * m = decimal month (1, 2, ..., 12) -#' * d = decimal day (1, 2, ..., 31) -#' * H = hours (0-23) -#' * M = minutes (0-59) -#' Example: `format = c("myd", "mh")`. Not one of the tried combinations! -#' Always check to make sure that dates/times were parsed correctly and the -#' relative times in the `PM_data$standard_data` field look correct. -#' Other date/time formats are possible. See [lubridate::parse_date_time()] for these. -#' @param quiet Quietly validate. Default is `FALSE`. -#' @param validate Validate the new row or not. Default is `FALSE` as a new row -#' added to a blank will result in a one-row data object, which is invalid. Also, -#' only one event type (dose or observation) should be added at a time, so if the -#' new object contains only doses while building, this would cause an error. You -#' should set `validate = TRUE` for the final addition. -#' @examples -#' \dontrun{ -#' PM_data$new()$addEvent(id = 1, time = 0, dose = 100, addl = 4, ii = 12, -#' out = NA, wt = 75)$addEvent(id = 1, time = 60, out = -1) -#' } + # check for addl and if present, expand + if ("addl" %in% arg_names) { + addl_lines <- to_add %>% dplyr::filter(!is.na(addl) & addl > 0) + if (nrow(addl_lines) > 0) { + new_lines <- addl_lines %>% + tidyr::uncount(addl, .remove = F) %>% + dplyr::group_by(id) %>% + dplyr::mutate(time = ii * dplyr::row_number() + time) -addEvent = function(..., dt = NULL, quiet = FALSE, validate = FALSE) { - args <- list(...) - arg_names <- tolower(names(args)) - - if (!"id" %in% arg_names) { - cli::cli_abort(c("x" = "ID is required to add an event.")) - } - to_add <- data.frame(args) - - if (!is.null(self$data)) { # existing data - old_names <- names(self$data) - missing_args <- arg_names[!arg_names %in% old_names] - if (length(missing_args) > 0) { - self$data[missing_args] <- NA - } - if (!"time" %in% arg_names) { - to_add <- to_add %>% dplyr::slice(rep(1, each = nrow(self$data))) - self$data[arg_names] <- to_add + to_add <- dplyr::bind_rows(to_add, new_lines) %>% + dplyr::arrange(id, time) %>% + dplyr::mutate( + addl = ifelse(addl == -1, -1, NA), + ii = ifelse(addl == -1, ii, NA) + ) + } + } + new_data <- dplyr::bind_rows(self$data, to_add) %>% dplyr::arrange(id, time) + + + self$data <- new_data if (validate) { - self$data <- self$data %>% dplyr::select(where(~ !all(is.na(.x)))) # clean up + self$data <- self$data %>% dplyr::select(where(~ !all(is.na(.x)))) self$standard_data <- private$validate(self$data, dt = dt, quiet = quiet) } else { self$standard_data <- NULL } return(invisible(self)) - } - } else { - if (!"time" %in% arg_names) { - cli::cli_abort(c("x" = "Time is required to add the first event.")) - } - } - # check for addl and if present, expand - if ("addl" %in% arg_names) { - addl_lines <- to_add %>% dplyr::filter(!is.na(addl) & addl > 0) - if (nrow(addl_lines) > 0) { - new_lines <- addl_lines %>% - tidyr::uncount(addl, .remove = F) %>% - dplyr::group_by(id) %>% - dplyr::mutate(time = ii * dplyr::row_number() + time) - - to_add <- dplyr::bind_rows(to_add, new_lines) %>% - dplyr::arrange(id, time) %>% - dplyr::mutate( - addl = ifelse(addl == -1, -1, NA), - ii = ifelse(addl == -1, ii, NA) - ) - } - } - new_data <- dplyr::bind_rows(self$data, to_add) %>% dplyr::arrange(id, time) - - - self$data <- new_data - if (validate) { - self$data <- self$data %>% dplyr::select(where(~ !all(is.na(.x)))) - self$standard_data <- private$validate(self$data, dt = dt, quiet = quiet) - } else { - self$standard_data <- NULL - } - return(invisible(self)) -} # end addEvent -), # end public -private = list( - validate = function(dataObj, quiet, dt) { - dataObj_orig <- dataObj # keep the original to pass to PMcheck - dataNames <- names(dataObj) - standardNames <- getFixedColNames() - - covNames <- dataNames[!dataNames %in% standardNames] - if ("date" %in% covNames) { - covNames <- covNames[-which(covNames == "date")] - } - - mandatory <- c("id", "time", "dose", "out") - missingMandatory <- sapply(mandatory, function(x) !x %in% dataNames) - if (any(missingMandatory)) { - cli::cli_abort(c("x" = "Your data are missing these mandatory columns: {mandatory[missingMandatory]}")) - } - - msg <- "Data are in full format already.\n" - - if (!"evid" %in% dataNames) { - dataObj$evid <- ifelse(is.na(dataObj$dose), 0, 1) - msg <- c(msg, "EVID inferred as 0 for observations, 1 for doses.\n") - } - - if ("date" %in% dataNames) { - relTime <- PMmatrixRelTime(dataObj, format = dt) - dataObj$time <- relTime$relTime - dataObj <- dataObj %>% select(-date) - msg <- c(msg, paste0("Dates and clock times converted to relative decimal times using ", attr(relTime, "dt_format"), ".\n")) - } - - if (!"dur" %in% dataNames) { - dataObj$dur <- ifelse(is.na(dataObj$dose), NA, 0) - msg <- c(msg, "All doses assumed to be oral (DUR = 0).\n") - } - - if (!"addl" %in% dataNames) { - dataObj$addl <- NA - msg <- c(msg, "ADDL set to missing for all records.\n") - } - - if (!"ii" %in% dataNames) { - dataObj$ii <- NA - msg <- c(msg, "II set to missing for all records.\n") - } - - if (!"input" %in% dataNames) { - dataObj$input <- ifelse(is.na(dataObj$dose), NA, 1) - msg <- c(msg, "All doses assumed to be INPUT = 1.\n") - } - - if (!"outeq" %in% dataNames) { - dataObj$outeq <- ifelse(is.na(dataObj$out), NA, 1) - msg <- c(msg, "All observations assumed to be OUTEQ = 1.\n") - } - - if (!"cens" %in% dataNames) { - dataObj$cens <- ifelse(is.na(dataObj$out), NA, "none") - msg <- c(msg, "All observations assumed to be uncensored.\n") - } - - if (is.numeric(dataObj$cens)) { - dataObj$cens <- ifelse(is.na(dataObj$out), NA, - dplyr::case_when( - dataObj$cens == 0 ~ "none", - dataObj$cens == 1 ~ "bloq", - dataObj$cens == -1 ~ "aloq", - TRUE ~ "none" - ) - ) - } - - errorCoef <- c("c0", "c1", "c2", "c3") - missingError <- sapply(errorCoef, function(x) !x %in% dataNames) - if (any(missingError)) { - dataObj$c0 <- dataObj$c1 <- dataObj$c2 <- dataObj$c3 <- NA - msg <- c(msg, "One or more error coefficients not specified. Error in model object will be used.\n") - } - - # expand any ADDL > 0 - # preserve original order (necessary for EVID=4) - dataObj$row <- 1:nrow(dataObj) - addl_lines <- dataObj %>% filter(!is.na(addl) & addl > 0) - if (nrow(addl_lines) > 0) { - new_lines <- addl_lines %>% - tidyr::uncount(addl, .remove = FALSE) %>% - group_by(id, time) %>% - mutate(time = ii * row_number() + time) %>% - ungroup() - - dataObj <- bind_rows(dataObj, new_lines) %>% - dplyr::arrange(id, time) %>% - dplyr::mutate( - addl = ifelse(addl == -1, -1, NA), - ii = ifelse(addl == -1, ii, NA) - ) %>% - select(!row) - - msg <- c(msg, "ADDL > 0 rows expanded.\n") - } - dataObj <- dataObj %>% select(standardNames, dplyr::all_of(covNames)) - # dataObj <- dataObj %>% dplyr::arrange(id, time) - - if (length(msg) > 1) { - msg <- msg[-1] - } # data were not in standard format, so remove that message - - if (!quiet) { - cli::cli_h1("DATA STANDARDIZATION") - cat(msg) - } - - validData <- PMcheck(data = list(standard = dataObj, original = dataObj_orig), fix = TRUE, quiet = quiet) - return(validData) -} # end validate function -) # end private + } # end addEvent + ), # end public + private = list( + validate = function(dataObj, quiet, dt) { + dataObj_orig <- dataObj # keep the original to pass to PMcheck + dataNames <- names(dataObj) + standardNames <- getFixedColNames() + + covNames <- dataNames[!dataNames %in% standardNames] + if ("date" %in% covNames) { + covNames <- covNames[-which(covNames == "date")] + } + + mandatory <- c("id", "time", "dose", "out") + missingMandatory <- sapply(mandatory, function(x) !x %in% dataNames) + if (any(missingMandatory)) { + cli::cli_abort(c("x" = "Your data are missing these mandatory columns: {mandatory[missingMandatory]}")) + } + + msg <- "Data are in full format already.\n" + + if (!"evid" %in% dataNames) { + dataObj$evid <- ifelse(is.na(dataObj$dose), 0, 1) + msg <- c(msg, "EVID inferred as 0 for observations, 1 for doses.\n") + } + + if ("date" %in% dataNames) { + relTime <- PMmatrixRelTime(dataObj, format = dt) + dataObj$time <- relTime$relTime + dataObj <- dataObj %>% select(-date) + msg <- c(msg, paste0("Dates and clock times converted to relative decimal times using ", attr(relTime, "dt_format"), ".\n")) + } + + if (!"dur" %in% dataNames) { + dataObj$dur <- ifelse(is.na(dataObj$dose), NA, 0) + msg <- c(msg, "All doses assumed to be oral (DUR = 0).\n") + } + + if (!"addl" %in% dataNames) { + dataObj$addl <- NA + msg <- c(msg, "ADDL set to missing for all records.\n") + } + + if (!"ii" %in% dataNames) { + dataObj$ii <- NA + msg <- c(msg, "II set to missing for all records.\n") + } + + if (!"input" %in% dataNames) { + dataObj$input <- ifelse(is.na(dataObj$dose), NA, 1) + msg <- c(msg, "All doses assumed to be INPUT = 1.\n") + } + + if (!"outeq" %in% dataNames) { + dataObj$outeq <- ifelse(is.na(dataObj$out), NA, 1) + msg <- c(msg, "All observations assumed to be OUTEQ = 1.\n") + } + + if (!"cens" %in% dataNames) { + dataObj$cens <- ifelse(is.na(dataObj$out), NA, "none") + msg <- c(msg, "All observations assumed to be uncensored.\n") + } + + if (is.numeric(dataObj$cens)) { + dataObj$cens <- ifelse(is.na(dataObj$out), NA, + dplyr::case_when( + dataObj$cens == 0 ~ "none", + dataObj$cens == 1 ~ "bloq", + dataObj$cens == -1 ~ "aloq", + TRUE ~ "none" + ) + ) + } + + errorCoef <- c("c0", "c1", "c2", "c3") + missingError <- sapply(errorCoef, function(x) !x %in% dataNames) + if (any(missingError)) { + dataObj$c0 <- dataObj$c1 <- dataObj$c2 <- dataObj$c3 <- NA + msg <- c(msg, "One or more error coefficients not specified. Error in model object will be used.\n") + } + + # expand any ADDL > 0 + # preserve original order (necessary for EVID=4) + dataObj$row <- 1:nrow(dataObj) + addl_lines <- dataObj %>% filter(!is.na(addl) & addl > 0) + if (nrow(addl_lines) > 0) { + new_lines <- addl_lines %>% + tidyr::uncount(addl, .remove = FALSE) %>% + group_by(id, time) %>% + mutate(time = ii * row_number() + time) %>% + ungroup() + + dataObj <- bind_rows(dataObj, new_lines) %>% + dplyr::arrange(id, time) %>% + dplyr::mutate( + addl = ifelse(addl == -1, -1, NA), + ii = ifelse(addl == -1, ii, NA) + ) %>% + select(!row) + + msg <- c(msg, "ADDL > 0 rows expanded.\n") + } + dataObj <- dataObj %>% select(standardNames, dplyr::all_of(covNames)) + # dataObj <- dataObj %>% dplyr::arrange(id, time) + + if (length(msg) > 1) { + msg <- msg[-1] + } # data were not in standard format, so remove that message + + if (!quiet) { + cli::cli_h1("DATA STANDARDIZATION") + cat(msg) + } + + validData <- PMcheck(data = list(standard = dataObj, original = dataObj_orig), fix = TRUE, quiet = quiet) + return(validData) + } # end validate function + ) # end private ) # end PM_data # MAKE (PMreadMatrix, PMmatrixRelTime, PMcheck) --------------------------- @@ -475,64 +475,64 @@ private = list( PMreadMatrix <- function( - file, - sep = getPMoptions("sep"), - dec = getPMoptions("dec"), - quiet = FALSE, ...) { - # get data - if (missing(file)) { - cli::cli_abort(c("x" = "Please provide filename of Pmetrics data file.")) - } - - file <- normalizePath(file, mustWork = FALSE) - - if (!file.exists(file)) { - cli::cli_abort(c("x" = "The file {.code {basename(file)}} was not found in {.path {dirname(file)}}.")) - } - - # read the first line to understand the format - headers <- scan(file, - what = "character", quiet = TRUE, nlines = 1, - sep = sep, dec = dec, strip.white = T - ) - if (grepl(",", headers)[1]) { - cli::cli_abort(c("x" = "Your .csv delimiter is not a comma. Use {.code setPMoptions(sep = \";\")}, for example.")) - } - headers <- headers[headers != ""] - skip <- ifelse(grepl("POPDATA .*", headers[1]), 1, 0) # 0 if current, 1 if legacy - - args1 <- list( - file = file, delim = sep, col_names = TRUE, na = ".", - locale = readr::locale(decimal_mark = dec), - skip = skip, show_col_types = FALSE, progress = FALSE, num_threads = 1 - ) - args2 <- list(...) - - args <- modifyList(args1, args2) - - if (quiet) { - data <- suppressWarnings(purrr::exec(readr::read_delim, !!!args)) - } else { - data <- purrr::exec(readr::read_delim, !!!args) - } - - # remove commented headers and lines - if (grepl("#", names(data)[1])) { + file, + sep = getPMoptions("sep"), + dec = getPMoptions("dec"), + quiet = FALSE, ...) { + # get data + if (missing(file)) { + cli::cli_abort(c("x" = "Please provide filename of Pmetrics data file.")) + } + + file <- normalizePath(file, mustWork = FALSE) + + if (!file.exists(file)) { + cli::cli_abort(c("x" = "The file {.code {basename(file)}} was not found in {.path {dirname(file)}}.")) + } + + # read the first line to understand the format + headers <- scan(file, + what = "character", quiet = TRUE, nlines = 1, + sep = sep, dec = dec, strip.white = T + ) + if (grepl(",", headers)[1]) { + cli::cli_abort(c("x" = "Your .csv delimiter is not a comma. Use {.code setPMoptions(sep = \";\")}, for example.")) + } + headers <- headers[headers != ""] + skip <- ifelse(grepl("POPDATA .*", headers[1]), 1, 0) # 0 if current, 1 if legacy + + args1 <- list( + file = file, delim = sep, col_names = TRUE, na = ".", + locale = readr::locale(decimal_mark = dec), + skip = skip, show_col_types = FALSE, progress = FALSE, num_threads = 1 + ) + args2 <- list(...) + + args <- modifyList(args1, args2) + + if (quiet) { + data <- suppressWarnings(purrr::exec(readr::read_delim, !!!args)) + } else { + data <- purrr::exec(readr::read_delim, !!!args) + } + + # remove commented headers and lines + if (grepl("#", names(data)[1])) { names(data)[1] <- sub("#", "", names(data)[1]) } comments <- grep("#", t(data[, 1])) if (length(comments) > 0) { data <- data[-comments, ] } - + names(data) <- tolower(names(data)) - + if (!quiet) { cat(paste("The file", sQuote(file), "contains these columns:\n", sep = " ")) cat(paste(names(data), collapse = ", ")) cat("\n") } - + attr(data, "legacy") <- ifelse(skip == 1, TRUE, FALSE) # if skip = 1, set attribute to TRUE class(data) <- c("PM_data_data", "data.frame") return(data) @@ -580,90 +580,90 @@ PMreadMatrix <- function( #' @export PMmatrixRelTime <- function( - data, idCol = "id", dateCol = "date", timeCol = "time", evidCol = "evid", - format, split = F) { - dataCols <- names(data) - # convert numeric if necessary - if (is.numeric(idCol)) idCol <- dataCols[idCol] - if (is.numeric(dateCol)) dateCol <- dataCols[dateCol] - if (is.numeric(timeCol)) timeCol <- dataCols[timeCol] - if (is.numeric(evidCol)) evidCol <- dataCols[evidCol] - - # all reasonable combinations - dt_df <- tidyr::crossing(date = c("dmy", "mdy", "ymd", "ydm"), time = c("HM", "HMS", "IMOp", "IMSOp")) - dt_formats <- paste(dt_df$date, dt_df$time) - - if (!all(c(idCol, dateCol, timeCol, evidCol) %in% dataCols)) { - cli::cli_abort(c("x" = "Please provide column names for id, date, time and evid.")) - } - temp <- data.frame(id = data[, idCol], date = data[, dateCol], time = data[, timeCol], evid = data[, evidCol]) - temp$date <- as.character(temp$date) - temp$time <- as.character(temp$time) - temp$time <- unlist(lapply(temp$time, function(x) ifelse(length(gregexpr(":", x)[[1]]) == 1, paste(x, ":00", sep = ""), x))) - - get_dt_format <- function(test) { - found_formats <- table(suppressWarnings(lubridate::guess_formats(paste(temp$date, temp$time), test))) - format_str <- names(found_formats)[which(found_formats == max(found_formats))] - O_str <- grep("O", format_str) - if (length(O_str) > 0) { - format_str <- format_str[-O_str] - } - the_format <- gsub("%", "", format_str) - return(the_format) - } - - - dt <- NA - if (!missing(format) && !is.null(format)) { - if (format[2] == "HM") format[2] <- "HMS" - format <- paste(format, collapse = " ") - dt <- tryCatch(suppressWarnings(lubridate::parse_date_time(paste(temp$date, temp$time), quiet = TRUE, format)), + data, idCol = "id", dateCol = "date", timeCol = "time", evidCol = "evid", + format, split = F) { + dataCols <- names(data) + # convert numeric if necessary + if (is.numeric(idCol)) idCol <- dataCols[idCol] + if (is.numeric(dateCol)) dateCol <- dataCols[dateCol] + if (is.numeric(timeCol)) timeCol <- dataCols[timeCol] + if (is.numeric(evidCol)) evidCol <- dataCols[evidCol] + + # all reasonable combinations + dt_df <- tidyr::crossing(date = c("dmy", "mdy", "ymd", "ydm"), time = c("HM", "HMS", "IMOp", "IMSOp")) + dt_formats <- paste(dt_df$date, dt_df$time) + + if (!all(c(idCol, dateCol, timeCol, evidCol) %in% dataCols)) { + cli::cli_abort(c("x" = "Please provide column names for id, date, time and evid.")) + } + temp <- data.frame(id = data[, idCol], date = data[, dateCol], time = data[, timeCol], evid = data[, evidCol]) + temp$date <- as.character(temp$date) + temp$time <- as.character(temp$time) + temp$time <- unlist(lapply(temp$time, function(x) ifelse(length(gregexpr(":", x)[[1]]) == 1, paste(x, ":00", sep = ""), x))) + + get_dt_format <- function(test) { + found_formats <- table(suppressWarnings(lubridate::guess_formats(paste(temp$date, temp$time), test))) + format_str <- names(found_formats)[which(found_formats == max(found_formats))] + O_str <- grep("O", format_str) + if (length(O_str) > 0) { + format_str <- format_str[-O_str] + } + the_format <- gsub("%", "", format_str) + return(the_format) + } + + + dt <- NA + if (!missing(format) && !is.null(format)) { + if (format[2] == "HM") format[2] <- "HMS" + format <- paste(format, collapse = " ") + dt <- tryCatch(suppressWarnings(lubridate::parse_date_time(paste(temp$date, temp$time), quiet = TRUE, format)), error = function(e) e ) # try with specific format found_format <- get_dt_format(format) } if (all(is.na(dt))) { # didn't parse yet, try automatic parsing dt <- tryCatch(suppressWarnings(lubridate::parse_date_time(paste(temp$date, temp$time), quiet = TRUE, dt_formats)), - error = function(e) e - ) - found_format <- get_dt_format(dt_formats) -} + error = function(e) e + ) + found_format <- get_dt_format(dt_formats) + } -if (all(is.na(dt))) { - cli::cli_abort(c("x" = "All dates/times failed to parse. Please specify correct format. ")) -} + if (all(is.na(dt))) { + cli::cli_abort(c("x" = "All dates/times failed to parse. Please specify correct format. ")) + } -temp$dt <- dt # didn't have to stop, so at least some parsed + temp$dt <- dt # didn't have to stop, so at least some parsed -if (split) { - # calculate PK event numbers for each patient - for (i in unique(temp$id)) { - pk.no <- 1 - temp2 <- subset(temp, temp$id == i) - for (j in 1:nrow(temp2)) { - if (temp2$evid[j] == 4) { - pk.no <- pk.no + 1 + if (split) { + # calculate PK event numbers for each patient + for (i in unique(temp$id)) { + pk.no <- 1 + temp2 <- subset(temp, temp$id == i) + for (j in 1:nrow(temp2)) { + if (temp2$evid[j] == 4) { + pk.no <- pk.no + 1 + } + temp2$pk.no[j] <- pk.no } - temp2$pk.no[j] <- pk.no + temp$pk.no[temp$id == i] <- temp2$pk.no } - temp$pk.no[temp$id == i] <- temp2$pk.no + # make new ID of form xxxxx.x for each PK event per patient + temp$id <- temp$id + temp$pk.no / 10 + temp$evid[temp$evid == 4] <- 1 } - # make new ID of form xxxxx.x for each PK event per patient - temp$id <- temp$id + temp$pk.no / 10 - temp$evid[temp$evid == 4] <- 1 -} -# calculate relative times -temp <- makePMmatrixBlock(temp) %>% -dplyr::group_by(id, block) %>% -dplyr::mutate(relTime = (dt - dt[1]) / lubridate::dhours(1)) + # calculate relative times + temp <- makePMmatrixBlock(temp) %>% + dplyr::group_by(id, block) %>% + dplyr::mutate(relTime = (dt - dt[1]) / lubridate::dhours(1)) -temp$relTime <- round(temp$relTime, 2) -temp <- temp[, c("id", "evid", "relTime")] -attr(temp, "dt_format") <- found_format + temp$relTime <- round(temp$relTime, 2) + temp <- temp[, c("id", "evid", "relTime")] + attr(temp, "dt_format") <- found_format -return(temp) + return(temp) } #' @title Check Pmetrics Inputs for Errors #' @description @@ -812,14 +812,14 @@ PMcheck <- function(data, fix = FALSE, quiet = FALSE) { if (is.null(legacy)) { legacy <- F } - - + + # check for errors err <- errcheck(data2, quiet = quiet, source = source) if (length(err) == 1) { cli::cli_abort(c("x" = "You must at least have id, evid, and time columns to proceed with the check.")) } - + # report errors in errors.xlsx if (attr(err, "error") != 0) { # Initialize an Excel Workbook @@ -833,7 +833,7 @@ PMcheck <- function(data, fix = FALSE, quiet = FALSE) { openxlsx::saveWorkbook(wb, file = "errors.xlsx", overwrite = T) } } - + # Provide warning on console about maximum time maxTime <- tryCatch(max(data2$time, na.rm = T), error = function(e) NA) if (!is.na(maxTime) && !is.character(maxTime) && maxTime > 24 * 48 & !quiet) { @@ -845,8 +845,8 @@ PMcheck <- function(data, fix = FALSE, quiet = FALSE) { ) ) } - - + + # try to fix errors if asked if (fix) { if (attr(err, "error") == 0) { @@ -867,7 +867,7 @@ PMcheck <- function(data, fix = FALSE, quiet = FALSE) { wb <- createInstructions(wb) openxlsx::saveWorkbook(wb, file = "errors.xlsx", overwrite = TRUE) } - + return(invisible(newdata)) } } else { @@ -902,549 +902,552 @@ errcheck <- function(data2, quiet, source) { contigID = list(msg = "OK - All subject IDs are contiguous.", results = NA, col = 1, code = 12), nonNum = list(msg = "OK - All columns that must be numeric are numeric.", results = NA, col = NA, code = 13), noObs = list(msg = "OK - All subjects have at least one observation.", results = NA, col = 1, code = 14), - mal_NA = list(msg = "OK - all unrequired cells have proper NA values.", results = NA, col = NA, code = 15) ) - # set initial attribute to 0 for no error - attr(err, "error") <- 0 - - # define fixed column names - fixedColNames <- getFixedColNames() - - # define number of columns and number of covariates - numcol <- ncol(data2) - numfix <- getFixedColNum() - numcov <- getCov(data2)$ncov - - # ensure lowercase - t <- tolower(names(data2)) - - # check to make sure first 14 columns are correct - if (any(!c("id", "time", "evid") %in% t)) { - # must at least have id, evid, and time columns to proceed with the check - return(-1) - } - if (length(t) < numfix | any(!fixedColNames %in% t)) { - err$colorder$msg <- paste("FAIL - The first ", numfix, " columns must be named id, evid, time, dur, dose, addl, ii, input, out, outeq, cens, c0, c1, c2, and c3 in that order", sep = "") - attr(err, "error") <- -1 - } else { - if (!identical(t[1:numfix], fixedColNames)) { - err$colorder$msg <- paste("FAIL - The first ", numfix, " columns must be named id, evid, time, dur, dose, addl, ii, input, out, outeq, cens, c0, c1, c2, and c3 in that order.", sep = "") - attr(err, "error") <- -1 - } - } - - - # check that all records have an EVID value - t <- which(is.na(data2$evid)) - if (length(t) > 0) { - err$missEVID$msg <- "FAIL - The following row numbers have missing EVID values:" - err$missEVID$results <- t - attr(err, "error") <- -1 - } - - # check that all records have a TIME value - t <- which(is.na(data2$time)) - if (length(t) > 0) { - err$missTIME$msg <- "FAIL - The following row numbers have missing TIME values. Check date/time entries." - err$missTIME$results <- t - attr(err, "error") <- -1 - } - - # check for dur on dose records - t <- which(data2$evid != 0 & is.na(data2$dur)) - if (length(t) > 0) { - err$doseDur$msg <- "FAIL - The following row numbers are dose events without DUR (unused addl or ii should have '.' placeholders):" - err$doseDur$results <- t - attr(err, "error") <- -1 - } - - # check for dose on dose records - t <- which(data2$evid != 0 & is.na(data2$dose)) - if (length(t) > 0) { - err$doseDose$msg <- "FAIL - The following row numbers are dose events without DOSE (unused addl or ii should have '.' placeholders):" - err$doseDose$results <- t - attr(err, "error") <- -1 - } - - # check for input on dose records - t <- which(data2$evid != 0 & is.na(data2$input)) - if (length(t) > 0) { - err$doseInput$msg <- "FAIL - The following row numbers are dose events without INPUT (unused addl or ii should have '.' placeholders):" - err$doseInput$results <- t - attr(err, "error") <- -1 - } - - # check for out on observation records - t <- which(data2$evid == 0 & is.na(data2$out)) - if (length(t) > 0) { - err$obsOut$msg <- "FAIL - The following row numbers are observation events without OUT:" - err$obsOut$results <- t - attr(err, "error") <- -1 - } - - # check for outeq on observation records - t <- which(data2$evid == 0 & is.na(data2$outeq)) - if (length(t) > 0) { - err$obsOuteq$msg <- "FAIL - The following row numbers are observation events without OUTEQ:" - err$obsOuteq$results <- t - attr(err, "error") <- -1 - } - - # check for time=0 for each subject as first record - t <- which(tapply(data2$time, data2$id, function(x) x[1]) != 0) - t2 <- match(names(t), data2$id) - if (length(t) > 0) { - err$T0$msg <- "FAIL - The following row numbers do not have time=0 as first record:" - err$T0$results <- t2 - attr(err, "error") <- -1 - } - - # covariate checks - if (numcov > 0) { - covinfo <- getCov(data2) - # check for missing covariates at time 0 - time0 <- which(data2$time == 0 & data2$evid == 1) - if (length(time0) > 1) { - t <- apply(as.matrix(data2[time0, covinfo$covstart:covinfo$covend], ncol = numcov), 1, function(x) any(is.na(x))) - } else { - t <- is.na(time0) - } - if (length(time0[t]) > 0) { - err$covT0$msg <- "FAIL - The following row numbers are subjects with missing covariate data at time 0." - err$covT0$results <- time0[t] - attr(err, "error") <- -1 - } else { - err$covT0$msg <- "OK - All subjects have covariate data at time 0." - } - } - - # check that all times within a given ID block are monotonically increasing - misorder <- NA - for (i in 2:nrow(data2)) { - time_diff <- suppressWarnings(tryCatch(data2$time[i] - data2$time[i - 1], error = function(e) NA)) - # if not missing (reported elsewhere) and diff<0 in same ID and not evid=4, misordered - if (!is.na(time_diff) && (time_diff < 0 & data2$id[i] == data2$id[i - 1] & data2$evid[i] != 4)) misorder <- c(misorder, i) - } - if (length(misorder) > 1) { - err$timeOrder$msg <- "FAIL - The following rows are from subject IDs with unsorted times. Check date/time entries." - err$timeOrder$results <- misorder[-1] + mal_NA = list(msg = "OK - all unrequired cells have proper NA values.", results = NA, col = NA, code = 15) + ) + # set initial attribute to 0 for no error + attr(err, "error") <- 0 + + # define fixed column names + fixedColNames <- getFixedColNames() + + # define number of columns and number of covariates + numcol <- ncol(data2) + numfix <- getFixedColNum() + numcov <- getCov(data2)$ncov + + # ensure lowercase + t <- tolower(names(data2)) + + # check to make sure first 14 columns are correct + if (any(!c("id", "time", "evid") %in% t)) { + # must at least have id, evid, and time columns to proceed with the check + return(-1) + } + if (length(t) < numfix | any(!fixedColNames %in% t)) { + err$colorder$msg <- paste("FAIL - The first ", numfix, " columns must be named id, evid, time, dur, dose, addl, ii, input, out, outeq, cens, c0, c1, c2, and c3 in that order", sep = "") + attr(err, "error") <- -1 + } else { + if (!identical(t[1:numfix], fixedColNames)) { + err$colorder$msg <- paste("FAIL - The first ", numfix, " columns must be named id, evid, time, dur, dose, addl, ii, input, out, outeq, cens, c0, c1, c2, and c3 in that order.", sep = "") attr(err, "error") <- -1 } - - # check that all records for a given subject ID are grouped - temp <- data.frame(row = 1:nrow(data2), id = data2$id) - t <- tapply(temp$row, temp$id, function(x) any(diff(x) > 1)) - if (any(t)) { - t2 <- which(data2$id %in% sort(unique(data2$id))[t]) + } + + + # check that all records have an EVID value + t <- which(is.na(data2$evid)) + if (length(t) > 0) { + err$missEVID$msg <- "FAIL - The following row numbers have missing EVID values:" + err$missEVID$results <- t + attr(err, "error") <- -1 + } + + # check that all records have a TIME value + t <- which(is.na(data2$time)) + if (length(t) > 0) { + err$missTIME$msg <- "FAIL - The following row numbers have missing TIME values. Check date/time entries." + err$missTIME$results <- t + attr(err, "error") <- -1 + } + + # check for dur on dose records + t <- which(data2$evid != 0 & is.na(data2$dur)) + if (length(t) > 0) { + err$doseDur$msg <- "FAIL - The following row numbers are dose events without DUR (unused addl or ii should have '.' placeholders):" + err$doseDur$results <- t + attr(err, "error") <- -1 + } + + # check for dose on dose records + t <- which(data2$evid != 0 & is.na(data2$dose)) + if (length(t) > 0) { + err$doseDose$msg <- "FAIL - The following row numbers are dose events without DOSE (unused addl or ii should have '.' placeholders):" + err$doseDose$results <- t + attr(err, "error") <- -1 + } + + # check for input on dose records + t <- which(data2$evid != 0 & is.na(data2$input)) + if (length(t) > 0) { + err$doseInput$msg <- "FAIL - The following row numbers are dose events without INPUT (unused addl or ii should have '.' placeholders):" + err$doseInput$results <- t + attr(err, "error") <- -1 + } + + # check for out on observation records + t <- which(data2$evid == 0 & is.na(data2$out)) + if (length(t) > 0) { + err$obsOut$msg <- "FAIL - The following row numbers are observation events without OUT:" + err$obsOut$results <- t + attr(err, "error") <- -1 + } + + # check for outeq on observation records + t <- which(data2$evid == 0 & is.na(data2$outeq)) + if (length(t) > 0) { + err$obsOuteq$msg <- "FAIL - The following row numbers are observation events without OUTEQ:" + err$obsOuteq$results <- t + attr(err, "error") <- -1 + } + + # check for time=0 for each subject as first record + t <- which(tapply(data2$time, data2$id, function(x) x[1]) != 0) + t2 <- match(names(t), data2$id) + if (length(t) > 0) { + err$T0$msg <- "FAIL - The following row numbers do not have time=0 as first record:" + err$T0$results <- t2 + attr(err, "error") <- -1 + } + + # covariate checks + if (numcov > 0) { + covinfo <- getCov(data2) + # check for missing covariates at time 0 + time0 <- which(data2$time == 0 & data2$evid == 1) + if (length(time0) > 1) { + t <- apply(as.matrix(data2[time0, covinfo$covstart:covinfo$covend], ncol = numcov), 1, function(x) any(is.na(x))) } else { - t2 <- NULL - } - if (length(t2) > 0) { - err$contigID$msg <- "FAIL - The following rows are from subject IDs that are not contiguous." - err$contigID$results <- t2 - attr(err, "error") <- -1 + t <- is.na(time0) } - - # check that all non-missing columns other than ID and cens are numeric - - allMiss <- names(data2)[which(apply(data2, 2, function(x) all(is.na(x))))] - nonNumeric <- names(data2)[which(sapply(data2, function(x) !is.numeric(x)))] - if (length(allMiss) > 0) { - nonNumeric <- nonNumeric[!nonNumeric %in% allMiss] %>% purrr::discard(~.x %in% (c("id", "cens"))) - } - if (length(nonNumeric) > 0 ) { # exclude id, cens columns - err$nonNum$msg <- "FAIL - The following columns must be all numeric." - err$nonNum$results <- nonNumeric - attr(err, "error") <- -1 - } - - # check that all subjects have at least one observation - subjObs <- tapply(data2$evid, data2$id, function(x) sum(x == 0, na.rm = T)) - if (any(subjObs == 0)) { - subjMissObs <- unique(data2$id)[which(subjObs == 0)] - err$noObs$msg <- "FAIL - The following rows are subjects with no observations." - err$noObs$results <- which(data2$id %in% subjMissObs) + if (length(time0[t]) > 0) { + err$covT0$msg <- "FAIL - The following row numbers are subjects with missing covariate data at time 0." + err$covT0$results <- time0[t] attr(err, "error") <- -1 + } else { + err$covT0$msg <- "OK - All subjects have covariate data at time 0." } - - # check for columns with malformed NA values - mal_NA <- purrr::map(as.list(data2), ~ stringr::str_count(.x, "(?% + } + + # check that all times within a given ID block are monotonically increasing + misorder <- NA + for (i in 2:nrow(data2)) { + time_diff <- suppressWarnings(tryCatch(data2$time[i] - data2$time[i - 1], error = function(e) NA)) + # if not missing (reported elsewhere) and diff<0 in same ID and not evid=4, misordered + if (!is.na(time_diff) && (time_diff < 0 & data2$id[i] == data2$id[i - 1] & data2$evid[i] != 4)) misorder <- c(misorder, i) + } + if (length(misorder) > 1) { + err$timeOrder$msg <- "FAIL - The following rows are from subject IDs with unsorted times. Check date/time entries." + err$timeOrder$results <- misorder[-1] + attr(err, "error") <- -1 + } + + # check that all records for a given subject ID are grouped + temp <- data.frame(row = 1:nrow(data2), id = data2$id) + t <- tapply(temp$row, temp$id, function(x) any(diff(x) > 1)) + if (any(t)) { + t2 <- which(data2$id %in% sort(unique(data2$id))[t]) + } else { + t2 <- NULL + } + if (length(t2) > 0) { + err$contigID$msg <- "FAIL - The following rows are from subject IDs that are not contiguous." + err$contigID$results <- t2 + attr(err, "error") <- -1 + } + + # check that all non-missing columns other than ID and cens are numeric + + allMiss <- names(data2)[which(apply(data2, 2, function(x) all(is.na(x))))] + nonNumeric <- names(data2)[which(sapply(data2, function(x) !is.numeric(x)))] + if (length(allMiss) > 0) { + nonNumeric <- nonNumeric[!nonNumeric %in% allMiss] + } + nonNumeric <- purrr::discard(nonNumeric, ~ .x %in% c("id", "cens")) + if (length(nonNumeric) > 0) { # exclude id, cens columns + err$nonNum$msg <- "FAIL - The following columns must be all numeric." + err$nonNum$results <- nonNumeric + attr(err, "error") <- -1 + } + + # check that all subjects have at least one observation + subjObs <- tapply(data2$evid, data2$id, function(x) sum(x == 0, na.rm = T)) + if (any(subjObs == 0)) { + subjMissObs <- unique(data2$id)[which(subjObs == 0)] + err$noObs$msg <- "FAIL - The following rows are subjects with no observations." + err$noObs$results <- which(data2$id %in% subjMissObs) + attr(err, "error") <- -1 + } + + # check for columns with malformed NA values + mal_NA <- purrr::map(as.list(data2), ~ stringr::str_count(.x, "(?% map(~ which(.x == 1)) %>% purrr::map_vec(~ length(.x) > 0) %>% which() - if (length(mal_NA) > 0) { - err$mal_NA$msg <- "FAIL - The following columns contain malformed NA values." - err$mal_NA$results <- mal_NA - attr(err, "error") <- -1 - } - - - class(err) <- c("PMerr", "list") - if (!quiet) { - cli::cli_h1("DATA VALIDATION") - print(err) - flush.console() - } - - - if (!quiet) flush.console() - return(err) - } - - - # errfix ------------------------------------------------------------------ - - - # try and fix errors in the data file - errfix <- function(data2, err, quiet) { - report <- NA - numcol <- ncol(data2) - # Fix first fixed columns - if (length(grep("FAIL", err$colorder$msg)) > 0) { - fixedColNames <- getFixedColNames() - t <- tolower(names(data2)) - PMcols <- match(fixedColNames, t) - if (any(is.na(PMcols))) { - misscols <- fixedColNames[is.na(PMcols)] - report <- c(report, paste("Cannot fix columns; the following are missing: ", paste(misscols, collapse = "'', '"), ".", sep = "")) - } else { - covcols <- (1:numcol)[!(1:numcol) %in% PMcols] - data2 <- data2[, c(PMcols, covcols)] - report <- c(report, paste("Columns are now ordered appropriately.")) - } - } - - # Check for NA observations (should be -99) - if (length(grep("FAIL", err$obsMiss$msg)) > 0) { - data2 <- data2[err$obsMiss$results, "out"] < -99 - report <- c(report, paste("Missing observations for evid=0 have been replaced with -99.")) - err <- errcheck(data2 = data2, quiet = T) - } - # Check for DUR dose records - if (length(grep("FAIL", err$doseDur$msg)) > 0) { - report <- c(report, paste("Dose records (evid=1 or evid=4) must have DUR. See errors.xlsx and fix manually.")) - } - # Check for DOSE dose records - if (length(grep("FAIL", err$doseDose$msg)) > 0) { - report <- c(report, paste("Dose records (evid=1 or evid=4) must have DOSE. See errors.xlsx and fix manually.")) - } - # Check for INPUT dose records - if (length(grep("FAIL", err$doseInput$msg)) > 0) { - report <- c(report, paste("Dose records (evid=1 or evid=4) must have INPUT. See errors.xlsx and fix manually.")) - } - # Check for OUT observation records - if (length(grep("FAIL", err$obsOut$msg)) > 0) { - report <- c(report, paste("Observation records (evid=0) must have OUT. See errors.xlsx and fix manually.")) - } - # Check for OUTEQ observation records - if (length(grep("FAIL", err$obsOuteq$msg)) > 0) { - report <- c(report, paste("Observation records (evid=0) must have OUTEQ. See errors.xlsx and fix manually.")) - } - - # Insert dummy doses of 0 for those missing time=0 first events - if (length(grep("FAIL", err$T0$msg)) > 0) { - T0 <- data2[err$T0$results, ] - T0$time <- 0 - T0$evid <- 1 - T0$dose <- 0 - T0$dur <- 0 - T0$input <- 1 - T0$addl <- NA - T0$ii <- NA - data2 <- rbind(data2, T0) - data2 <- data2[order(data2$id, data2$time), ] - report <- c(report, paste("Subjects with first time > 0 have had a dummy dose of 0 inserted at time 0.")) - err <- errcheck(data2 = data2, quiet = T) - } - - # Alert for missing covariate data - if (length(grep("FAIL", err$covT0$msg)) > 0) { - report <- c(report, paste("All covariates must have values for each subject's first event. See errors.xlsx and fix manually.")) + if (length(mal_NA) > 0) { + err$mal_NA$msg <- "FAIL - The following columns contain malformed NA values." + err$mal_NA$results <- mal_NA + attr(err, "error") <- -1 + } + + + class(err) <- c("PMerr", "list") + if (!quiet) { + cli::cli_h1("DATA VALIDATION") + print(err) + flush.console() + } + + + if (!quiet) flush.console() + return(err) +} + + +# errfix ------------------------------------------------------------------ + + +# try and fix errors in the data file +errfix <- function(data2, err, quiet) { + report <- NA + numcol <- ncol(data2) + # Fix first fixed columns + if (length(grep("FAIL", err$colorder$msg)) > 0) { + fixedColNames <- getFixedColNames() + t <- tolower(names(data2)) + PMcols <- match(fixedColNames, t) + if (any(is.na(PMcols))) { + misscols <- fixedColNames[is.na(PMcols)] + report <- c(report, paste("Cannot fix columns; the following are missing: ", paste(misscols, collapse = "'', '"), ".", sep = "")) + } else { + covcols <- (1:numcol)[!(1:numcol) %in% PMcols] + data2 <- data2[, c(PMcols, covcols)] + report <- c(report, paste("Columns are now ordered appropriately.")) } - - # Reorder times - assume times are in correct block - if (length(grep("FAIL", err$timeOrder$msg)) > 0) { - data2 <- makePMmatrixBlock(data2) %>% + } + + # Check for NA observations (should be -99) + if (length(grep("FAIL", err$obsMiss$msg)) > 0) { + data2 <- data2[err$obsMiss$results, "out"] < -99 + report <- c(report, paste("Missing observations for evid=0 have been replaced with -99.")) + err <- errcheck(data2 = data2, quiet = T) + } + # Check for DUR dose records + if (length(grep("FAIL", err$doseDur$msg)) > 0) { + report <- c(report, paste("Dose records (evid=1 or evid=4) must have DUR. See errors.xlsx and fix manually.")) + } + # Check for DOSE dose records + if (length(grep("FAIL", err$doseDose$msg)) > 0) { + report <- c(report, paste("Dose records (evid=1 or evid=4) must have DOSE. See errors.xlsx and fix manually.")) + } + # Check for INPUT dose records + if (length(grep("FAIL", err$doseInput$msg)) > 0) { + report <- c(report, paste("Dose records (evid=1 or evid=4) must have INPUT. See errors.xlsx and fix manually.")) + } + # Check for OUT observation records + if (length(grep("FAIL", err$obsOut$msg)) > 0) { + report <- c(report, paste("Observation records (evid=0) must have OUT. See errors.xlsx and fix manually.")) + } + # Check for OUTEQ observation records + if (length(grep("FAIL", err$obsOuteq$msg)) > 0) { + report <- c(report, paste("Observation records (evid=0) must have OUTEQ. See errors.xlsx and fix manually.")) + } + + # Insert dummy doses of 0 for those missing time=0 first events + if (length(grep("FAIL", err$T0$msg)) > 0) { + T0 <- data2[err$T0$results, ] + T0$time <- 0 + T0$evid <- 1 + T0$dose <- 0 + T0$dur <- 0 + T0$input <- 1 + T0$addl <- NA + T0$ii <- NA + data2 <- rbind(data2, T0) + data2 <- data2[order(data2$id, data2$time), ] + report <- c(report, paste("Subjects with first time > 0 have had a dummy dose of 0 inserted at time 0.")) + err <- errcheck(data2 = data2, quiet = T) + } + + # Alert for missing covariate data + if (length(grep("FAIL", err$covT0$msg)) > 0) { + report <- c(report, paste("All covariates must have values for each subject's first event. See errors.xlsx and fix manually.")) + } + + # Reorder times - assume times are in correct block + if (length(grep("FAIL", err$timeOrder$msg)) > 0) { + data2 <- makePMmatrixBlock(data2) %>% dplyr::group_by(id, block) %>% dplyr::arrange(time, .by_group = T) %>% ungroup() %>% select(-block) - - if (any(data2$evid == 4)) { - report <- c(report, paste("Your dataset has EVID=4 events. Times ordered within each event block.")) - } else { - report <- c(report, paste("Times for each subject have been ordered.")) - } - } - # Reorder IDs - if (length(grep("FAIL", err$contigID$msg)) > 0) { - if (any(data2$evid == 4)) { - report <- c(report, paste("Your dataset has EVID=4 events. Unable to sort subjects and times automatically.")) - } else { - data2 <- data2[order(data2$id, data2$time), ] - report <- c(report, paste("Subjects have been grouped and ordered.")) - } + + if (any(data2$evid == 4)) { + report <- c(report, paste("Your dataset has EVID=4 events. Times ordered within each event block.")) + } else { + report <- c(report, paste("Times for each subject have been ordered.")) } - # Fix missing EVID - if (length(grep("FAIL", err$missEVID$msg)) > 0) { - data2$evid[err$missEVID$results] <- ifelse(is.na(data2$dose[err$missEVID$results]), 0, 1) - report <- c(report, paste("EVID for events with doses changed to 1, otherwise 0.")) + } + # Reorder IDs + if (length(grep("FAIL", err$contigID$msg)) > 0) { + if (any(data2$evid == 4)) { + report <- c(report, paste("Your dataset has EVID=4 events. Unable to sort subjects and times automatically.")) + } else { + data2 <- data2[order(data2$id, data2$time), ] + report <- c(report, paste("Subjects have been grouped and ordered.")) } - - # Fix malformed NA - if (length(grep("FAIL", err$mal_NA$msg)) > 0) { - # convert to "." then NA - data2 <- data2 %>% + } + # Fix missing EVID + if (length(grep("FAIL", err$missEVID$msg)) > 0) { + data2$evid[err$missEVID$results] <- ifelse(is.na(data2$dose[err$missEVID$results]), 0, 1) + report <- c(report, paste("EVID for events with doses changed to 1, otherwise 0.")) + } + + # Fix malformed NA + if (length(grep("FAIL", err$mal_NA$msg)) > 0) { + # convert to "." then NA + data2 <- data2 %>% mutate(across(everything(), ~ str_replace_all(.x, "(?% mutate(across(everything(), ~ dplyr::na_if(.x, "."))) - report <- c(report, paste("Malformed NAs corrected.")) - } - - - # Report missing TIME - if (length(grep("FAIL", err$missTIME$msg)) > 0) { - report <- c(report, paste("Your dataset has missing times. See errors.xlsx and fix manually.")) - } - - # Report non-numeric columns - if (length(grep("FAIL", err$nonNum$msg)) > 0) { - report <- c(report, paste("Your dataset has non-numeric columns. See errors.xlsx and fix manually.")) - } - - # Report subjects with no observations - if (length(grep("FAIL", err$noObs$msg)) > 0) { - report <- c(report, paste("Your dataset has subjects with no observations. See errors.xlsx and fix manually.")) - } - - if (!quiet) { - cli::cli_h1("FIX DATA REPORT:") - report <- report[-1] - cat(paste0("(", 1:length(report), ") ", report, collapse = "\n")) - flush.console() + report <- c(report, paste("Malformed NAs corrected.")) + } + + + # Report missing TIME + if (length(grep("FAIL", err$missTIME$msg)) > 0) { + report <- c(report, paste("Your dataset has missing times. See errors.xlsx and fix manually.")) + } + + # Report non-numeric columns + if (length(grep("FAIL", err$nonNum$msg)) > 0) { + report <- c(report, paste("Your dataset has non-numeric columns. See errors.xlsx and fix manually.")) + } + + # Report subjects with no observations + if (length(grep("FAIL", err$noObs$msg)) > 0) { + report <- c(report, paste("Your dataset has subjects with no observations. See errors.xlsx and fix manually.")) + } + + if (!quiet) { + cli::cli_h1("FIX DATA REPORT:") + report <- report[-1] + cat(paste0("(", 1:length(report), ") ", report, collapse = "\n")) + flush.console() + } + return(data2) +} + + +# writeErrorFile ---------------------------------------------------------- + +writeErrorFile <- function(dat, err, legacy, wb, sheet) { + # Definition of a table of n types of errors, each one with 'code' and 'color' properties + errorsTable <- data.frame( + comment = c( + # "ID > 11 characters", + "Missing EVID", + "Missing TIME", + "Missing DUR for dose event", + "Missing DOSE for dose event", + "Missing INPUT for dose event", + "Missing OUT for output (use -99)", + "Missing OUTEQ for observation", + "TIME not 0 at first event for subject", + "Missing one or more covariate values at TIME=0", + "TIME entry out of order", + "Non-contiguous subject ID", + "Non-numeric entry", + "Subject with no observations", + "Malformed NA value" + ), + stringsAsFactors = F + ) + numError <- nrow(errorsTable) + errorsTable$code <- 1:numError + + # assign errors with row, column, and code + errList <- lapply(err[3:length(err)], function(x) (lapply(x$results, function(y) c(y, x$col, x$code)))) + errDF <- data.frame(t(data.frame(errList))) + row.names(errDF) <- 1:nrow(errDF) + names(errDF) <- c("row", "column", "code") + errors <- errDF[!is.na(errDF$row), ] + formattedCols <- names(dat) + + if (legacy) { + pmVersion <- "POPDATA DEC_11" + formattedCols <- toupper(formattedCols) + formattedCols[1] <- "#ID" + legacy_offset <- 1 + } else { + legacy_offset <- 0 + } + + # set colors for errors + errColor <- "#FFFF00" # yellow, column specific + errColor2 <- "#00FF00" # green, across columns + errColor3 <- "#00AAFF" # blue, NA + errColor4 <- "#FFAA00" # orange, summary + + # create styles for error formatting + errStyle1 <- openxlsx::createStyle(fgFill = errColor) + errStyle2 <- openxlsx::createStyle(fgFill = errColor2) + errStyle3 <- openxlsx::createStyle(fgFill = errColor3) + errStyle4 <- openxlsx::createStyle(fgFill = errColor4) + + + # function to detect things that can't be coerced to numbers + is.char.num <- function(x) { + if (!is.na(x) && suppressWarnings(is.na(as.numeric(x)))) { + return(T) + } else { + return(F) } - return(data2) - } - - - # writeErrorFile ---------------------------------------------------------- - - writeErrorFile <- function(dat, err, legacy, wb, sheet) { - # Definition of a table of n types of errors, each one with 'code' and 'color' properties - errorsTable <- data.frame( - comment = c( - # "ID > 11 characters", - "Missing EVID", - "Missing TIME", - "Missing DUR for dose event", - "Missing DOSE for dose event", - "Missing INPUT for dose event", - "Missing OUT for output (use -99)", - "Missing OUTEQ for observation", - "TIME not 0 at first event for subject", - "Missing one or more covariate values at TIME=0", - "TIME entry out of order", - "Non-contiguous subject ID", - "Non-numeric entry", - "Subject with no observations", - "Malformed NA value" ), - stringsAsFactors = F + } + + # make second table to summarize errors + error_summary <- errors %>% filter(!code %in% c(10, 13, 15)) # we will add these back + + # Highlight the cells with errors + for (i in 1:nrow(errors)) { + thisErr <- errors[i, ] + colIndex <- thisErr$column + rowIndex <- thisErr$row + # special highlighting - overwrite some values + if (thisErr$code == 10) { + # if covariate error + covData <- getCov(dat) + colIndex <- covData$covstart + + which(is.na(dat[rowIndex, covData$covstart:covData$covend])) - 1 + rowIndex <- rowIndex + 1 + legacy_offset + error_summary <- dplyr::bind_rows( + error_summary, + data.frame( + row = rep(rowIndex, length(colIndex)), + column = colIndex, + code = 10 + ) ) - numError <- nrow(errorsTable) - errorsTable$code <- 1:numError - - # assign errors with row, column, and code - errList <- lapply(err[3:length(err)], function(x) (lapply(x$results, function(y) c(y, x$col, x$code)))) - errDF <- data.frame(t(data.frame(errList))) - row.names(errDF) <- 1:nrow(errDF) - names(errDF) <- c("row", "column", "code") - errors <- errDF[!is.na(errDF$row), ] - formattedCols <- names(dat) - - if (legacy) { - pmVersion <- "POPDATA DEC_11" - formattedCols <- toupper(formattedCols) - formattedCols[1] <- "#ID" - legacy_offset <- 1 - } else { - legacy_offset <- 0 - } - - # set colors for errors - errColor <- "#FFFF00" # yellow, column specific - errColor2 <- "#00FF00" # green, across columns - errColor3 <- "#00AAFF" # blue, NA - errColor4 <- "#FFAA00" # orange, summary - - # create styles for error formatting - errStyle1 <- openxlsx::createStyle(fgFill = errColor) - errStyle2 <- openxlsx::createStyle(fgFill = errColor2) - errStyle3 <- openxlsx::createStyle(fgFill = errColor3) - errStyle4 <- openxlsx::createStyle(fgFill = errColor4) - - - # function to detect things that can't be coerced to numbers - is.char.num <- function(x) { - if (!is.na(x) && suppressWarnings(is.na(as.numeric(x)))) { - return(T) - } else { - return(F) - } - } - - # make second table to summarize errors - error_summary <- errors %>% filter(!code %in% c(10, 13, 15)) # we will add these back - - # Highlight the cells with errors - for (i in 1:nrow(errors)) { - thisErr <- errors[i, ] - colIndex <- thisErr$column - rowIndex <- thisErr$row - # special highlighting - overwrite some values - if (thisErr$code == 10) { - # if covariate error - covData <- getCov(dat) - colIndex <- covData$covstart + - which(is.na(dat[rowIndex, covData$covstart:covData$covend])) - 1 - rowIndex <- rowIndex + 1 + legacy_offset - error_summary <- dplyr::bind_rows( - error_summary, - data.frame( - row = rep(rowIndex, length(colIndex)), - column = colIndex, - code = 10 - ) - ) - openxlsx::addStyle(wb, sheet, errStyle2, rows = rowIndex, cols = colIndex) - purrr::walk2(colIndex, rowIndex, ~ openxlsx::removeComment(wb, sheet, col = .x, row = .y)) # Excel throws a fit if two comments written - purrr::walk2(colIndex, rowIndex, ~ openxlsx::writeComment(wb, sheet, - col = .x, row = .y, - comment = openxlsx::createComment(errorsTable$comment[10], author = "Pmetrics", visible = F) - )) - } else if (thisErr$code == 12) { - # special for non-numeric columns - colIndex <- thisErr$row # because of the way the error is detected - # find the non-numeric cells in a column - rowIndex2 <- which(sapply(dplyr::pull(dat, colIndex), is.char.num)) + 1 + legacy_offset - # find the malformed NAs as a special case and remove them (separate error below) - # because openxlsx can't overwrite comments - mal_NA <- stringr::str_count(dplyr::pull(dat, colIndex), "(?% - map(~ which(.x == 1)) %>% - purrr::map_vec(~ length(.x) > 0) %>% - which() + 1 + legacy_offset - # remove any mal_NA from non-numeric - rowIndex2 <- rowIndex2[!rowIndex2 %in% mal_NA] - # highlight them if any left - if (length(rowIndex2) > 0) { - openxlsx::addStyle(wb, sheet, errStyle2, rows = rowIndex2, cols = colIndex) - purrr::walk2(colIndex, rowIndex2, ~ openxlsx::removeComment(wb, sheet, col = .x, row = .y)) # Excel throws a fit if two comments written - purrr::walk2(colIndex, rowIndex2, ~ openxlsx::writeComment(wb, sheet, - col = .x, row = .y, - comment = openxlsx::createComment(errorsTable$comment[13], author = "Pmetrics", visible = F) - )) - error_summary <- dplyr::bind_rows( - error_summary, - data.frame( - row = rowIndex2, - column = rep(colIndex, length(rowIndex2)), - code = 13 - ) - ) - } - } else if (thisErr$code == 14) { - # malformed NA - colIndex <- thisErr$row # because of the way the error is detected - rowIndex3 <- stringr::str_count(dplyr::pull(dat, colIndex), "(?% - map(~ which(.x == 1)) %>% - purrr::map_vec(~ length(.x) > 0) %>% - which() + 1 + legacy_offset - # highlight them - openxlsx::addStyle(wb, sheet, errStyle3, rows = rowIndex3, cols = colIndex) - purrr::walk2(colIndex, rowIndex3, ~ openxlsx::writeComment(wb, sheet, - col = .x, row = .y, - comment = openxlsx::createComment(errorsTable$comment[15], author = "Pmetrics", visible = F) - )) - error_summary <- dplyr::bind_rows( - error_summary, - data.frame( - row = rowIndex3, - column = rep(colIndex, length(rowIndex3)), - code = 15 - ) + openxlsx::addStyle(wb, sheet, errStyle2, rows = rowIndex, cols = colIndex) + purrr::walk2(colIndex, rowIndex, ~ openxlsx::removeComment(wb, sheet, col = .x, row = .y)) # Excel throws a fit if two comments written + purrr::walk2(colIndex, rowIndex, ~ openxlsx::writeComment(wb, sheet, + col = .x, row = .y, + comment = openxlsx::createComment(errorsTable$comment[10], author = "Pmetrics", visible = F) + )) + } else if (thisErr$code == 12) { + # special for non-numeric columns + colIndex <- thisErr$row # because of the way the error is detected + # find the non-numeric cells in a column + rowIndex2 <- which(sapply(dplyr::pull(dat, colIndex), is.char.num)) + 1 + legacy_offset + # find the malformed NAs as a special case and remove them (separate error below) + # because openxlsx can't overwrite comments + mal_NA <- stringr::str_count(dplyr::pull(dat, colIndex), "(?% + map(~ which(.x == 1)) %>% + purrr::map_vec(~ length(.x) > 0) %>% + which() + 1 + legacy_offset + # remove any mal_NA from non-numeric + rowIndex2 <- rowIndex2[!rowIndex2 %in% mal_NA] + # highlight them if any left + if (length(rowIndex2) > 0) { + openxlsx::addStyle(wb, sheet, errStyle2, rows = rowIndex2, cols = colIndex) + purrr::walk2(colIndex, rowIndex2, ~ openxlsx::removeComment(wb, sheet, col = .x, row = .y)) # Excel throws a fit if two comments written + purrr::walk2(colIndex, rowIndex2, ~ openxlsx::writeComment(wb, sheet, + col = .x, row = .y, + comment = openxlsx::createComment(errorsTable$comment[13], author = "Pmetrics", visible = F) + )) + error_summary <- dplyr::bind_rows( + error_summary, + data.frame( + row = rowIndex2, + column = rep(colIndex, length(rowIndex2)), + code = 13 ) - } else { - # add the highlighting and comments for other errors - rowIndex <- rowIndex + 1 + legacy_offset - comment <- openxlsx::createComment(errorsTable$comment[thisErr$code], author = "Pmetrics", visible = F) - openxlsx::addStyle(wb, sheet, errStyle1, rowIndex, colIndex) - openxlsx::writeComment(wb, sheet, xy = c(colIndex, rowIndex), comment = comment) - } - } # end errors for loop - - # Add summaries to each column with errors - sum_errors <- dplyr::as_tibble(table(error_summary$column, error_summary$code, dnn = c("column", "code"))) %>% - group_by(column) %>% - summarize(n_err = sum(n)) - - openxlsx::addStyle(wb, sheet, errStyle4, rows = 1 + legacy_offset, cols = as.numeric(sum_errors$column)) - comments <- purrr::map(1:nrow(sum_errors), ~ openxlsx::createComment(paste( - sum_errors$n_err[.x], - ifelse(sum_errors$n_err[.x] > 1, "errors", "error") - ), author = "Pmetrics", visible = F)) - purrr::walk(1:nrow(sum_errors), ~ openxlsx::writeComment(wb, sheet, col = as.numeric(sum_errors$column[.x]), row = 1 + legacy_offset, comment = comments[[.x]])) - - # Writing out the header of the Pmetrics data file : version line.... - if (legacy) { - openxlsx::writeData(wb, sheet, pmVersion, xy = c(1, 1)) - } # POPDATA... - - # ...and data frame column names - openxlsx::writeData(wb, sheet, t(formattedCols), xy = c(1, 1 + legacy_offset), colNames = F) - - # Add the data - openxlsx::writeData(wb, sheet, dat, - rowNames = F, colNames = F, xy = c(1, 2 + legacy_offset), - keepNA = T, na.string = "." + ) + } + } else if (thisErr$code == 14) { + # malformed NA + colIndex <- thisErr$row # because of the way the error is detected + rowIndex3 <- stringr::str_count(dplyr::pull(dat, colIndex), "(?% + map(~ which(.x == 1)) %>% + purrr::map_vec(~ length(.x) > 0) %>% + which() + 1 + legacy_offset + # highlight them + openxlsx::addStyle(wb, sheet, errStyle3, rows = rowIndex3, cols = colIndex) + purrr::walk2(colIndex, rowIndex3, ~ openxlsx::writeComment(wb, sheet, + col = .x, row = .y, + comment = openxlsx::createComment(errorsTable$comment[15], author = "Pmetrics", visible = F) + )) + error_summary <- dplyr::bind_rows( + error_summary, + data.frame( + row = rowIndex3, + column = rep(colIndex, length(rowIndex3)), + code = 15 + ) ) - - return(wb) + } else { + # add the highlighting and comments for other errors + rowIndex <- rowIndex + 1 + legacy_offset + comment <- openxlsx::createComment(errorsTable$comment[thisErr$code], author = "Pmetrics", visible = F) + openxlsx::addStyle(wb, sheet, errStyle1, rowIndex, colIndex) + openxlsx::writeComment(wb, sheet, xy = c(colIndex, rowIndex), comment = comment) } - - createInstructions <- function(wb) { - # set colors for errors - errColor <- "#FFFF00" # yellow, column header - errColor2 <- "#00FF00" # green, cell - errColor3 <- "#00AAFF" # blue, NA - errColor4 <- "#FFAA00" # orange, summary - - # create styles for error formatting - errStyle1 <- openxlsx::createStyle(fgFill = errColor) - errStyle2 <- openxlsx::createStyle(fgFill = errColor2) - errStyle3 <- openxlsx::createStyle(fgFill = errColor3) - errStyle4 <- openxlsx::createStyle(fgFill = errColor4) - textStyle <- openxlsx::createStyle(fontSize = 16) - - openxlsx::addWorksheet(wb, "Instructions", tabColour = "grey80") - openxlsx::addStyle(wb, "Instructions", textStyle, rows = 1:8, cols = 1) - openxlsx::addStyle(wb, "Instructions", textStyle, rows = 10:13, cols = 2) - openxlsx::writeData(wb, "Instructions", - c( - "'Errors' tab contains your data which has been standardized if read using PM_data$new().", - "Cells with errors are color coded according to table below.", - "Hover your mouse over each cell to read pop-up comment with details.", - "Comments on column headers in orange contain the total number of errors in that column.", - "If fix = TRUE, which is default for PM_data$new(), there will be an additional 'After_Fix' tab.", - "This tab contains your standardized data after Pmetrics attempted to repair your data.", - "Residual errors will be indicated as for the 'Errors' tab.", - "You can fix the remaining errors and save the 'After_Fix' tab as a new .csv data file." - ), - startCol = 1, startRow = 1 - ) - - openxlsx::addStyle(wb, "Instructions", errStyle1, rows = 10, cols = 1) - openxlsx::addStyle(wb, "Instructions", errStyle2, rows = 11, cols = 1) - openxlsx::addStyle(wb, "Instructions", errStyle3, rows = 12, cols = 1) - openxlsx::addStyle(wb, "Instructions", errStyle4, rows = 13, cols = 1) - - openxlsx::writeData(wb, "Instructions", + } # end errors for loop + + # Add summaries to each column with errors + sum_errors <- dplyr::as_tibble(table(error_summary$column, error_summary$code, dnn = c("column", "code"))) %>% + group_by(column) %>% + summarize(n_err = sum(n)) + + openxlsx::addStyle(wb, sheet, errStyle4, rows = 1 + legacy_offset, cols = as.numeric(sum_errors$column)) + comments <- purrr::map(1:nrow(sum_errors), ~ openxlsx::createComment(paste( + sum_errors$n_err[.x], + ifelse(sum_errors$n_err[.x] > 1, "errors", "error") + ), author = "Pmetrics", visible = F)) + purrr::walk(1:nrow(sum_errors), ~ openxlsx::writeComment(wb, sheet, col = as.numeric(sum_errors$column[.x]), row = 1 + legacy_offset, comment = comments[[.x]])) + + # Writing out the header of the Pmetrics data file : version line.... + if (legacy) { + openxlsx::writeData(wb, sheet, pmVersion, xy = c(1, 1)) + } # POPDATA... + + # ...and data frame column names + openxlsx::writeData(wb, sheet, t(formattedCols), xy = c(1, 1 + legacy_offset), colNames = F) + + # Add the data + openxlsx::writeData(wb, sheet, dat, + rowNames = F, colNames = F, xy = c(1, 2 + legacy_offset), + keepNA = T, na.string = "." + ) + + return(wb) +} + +createInstructions <- function(wb) { + # set colors for errors + errColor <- "#FFFF00" # yellow, column header + errColor2 <- "#00FF00" # green, cell + errColor3 <- "#00AAFF" # blue, NA + errColor4 <- "#FFAA00" # orange, summary + + # create styles for error formatting + errStyle1 <- openxlsx::createStyle(fgFill = errColor) + errStyle2 <- openxlsx::createStyle(fgFill = errColor2) + errStyle3 <- openxlsx::createStyle(fgFill = errColor3) + errStyle4 <- openxlsx::createStyle(fgFill = errColor4) + textStyle <- openxlsx::createStyle(fontSize = 16) + + openxlsx::addWorksheet(wb, "Instructions", tabColour = "grey80") + openxlsx::addStyle(wb, "Instructions", textStyle, rows = 1:8, cols = 1) + openxlsx::addStyle(wb, "Instructions", textStyle, rows = 10:13, cols = 2) + openxlsx::writeData(wb, "Instructions", + c( + "'Errors' tab contains your data which has been standardized if read using PM_data$new().", + "Cells with errors are color coded according to table below.", + "Hover your mouse over each cell to read pop-up comment with details.", + "Comments on column headers in orange contain the total number of errors in that column.", + "If fix = TRUE, which is default for PM_data$new(), there will be an additional 'After_Fix' tab.", + "This tab contains your standardized data after Pmetrics attempted to repair your data.", + "Residual errors will be indicated as for the 'Errors' tab.", + "You can fix the remaining errors and save the 'After_Fix' tab as a new .csv data file." + ), + startCol = 1, startRow = 1 + ) + + openxlsx::addStyle(wb, "Instructions", errStyle1, rows = 10, cols = 1) + openxlsx::addStyle(wb, "Instructions", errStyle2, rows = 11, cols = 1) + openxlsx::addStyle(wb, "Instructions", errStyle3, rows = 12, cols = 1) + openxlsx::addStyle(wb, "Instructions", errStyle4, rows = 13, cols = 1) + + openxlsx::writeData(wb, "Instructions", c( "Errors specific to a particular column", "Errors not specific to a defined column, i.e. non-numeric entries or missing covariates at time 0.", @@ -1498,8 +1501,8 @@ errcheck <- function(data2, quiet, source) { #' * If plotting data contained in a [PM_result], use "pop" or "post" to include population or posterior predictions. #' ** Example 1: `run1 <- PM_load(1); run1$data$plot(line = list(pred = "post"))` #' * If plotting data not contained in a [PM_result], you may add the -#' name of a population [PM_pop] or posterior [PM_post] prediction object in a [PM_result] object. -#' This might be useful if you want to see how the predictions from one population match +#' name of a population [PM_pop] or posterior [PM_post] prediction object in a [PM_result] object. +#' This might be useful if you want to see how the predictions from one population match #' the raw data from another. #' ** Example 2: `dat <- PM_data$new("new.csv"); dat$plot(line = list(pred = run1$post))`. #' @@ -1582,294 +1585,294 @@ errcheck <- function(data2, quiet, source) { #' @family PMplots plot.PM_data <- function( - x, - include = NULL, - exclude = NULL, - line = list(join = TRUE, pred = FALSE), - marker = TRUE, - group = NULL, - group_names = NULL, - mult = 1, - outeq = 1, - out_names = NULL, - block = 1, - tad = FALSE, - overlay = TRUE, - legend, - log = FALSE, - grid = FALSE, - xlab = "Time", - ylab = "Output", - title = "", - xlim, ylim, - print = TRUE, ...) { - # Plot parameters --------------------------------------------------------- - - # process marker - marker <- amendMarker(marker) - marker$color <- map_chr(marker$color, \(x) substr(x, 1, 7)) # remove alpha if present, controlled by opacity - - highlight_color <- opposite_color(marker$color[1]) # in plotly_Utils.R - - - # process line - if (any(!base::names(line) %in% c("join", "pred"))) { - cli::cli_warn(c("!" = "{.code line} should be a list with at most two named elements: {.code join}, {.code loess}, and/or {.code pred}.", "i" = "See {.fn Pmetrics::plot.PM_data}.")) - } - if (is.null(line$join)) { - line$join <- FALSE - } - if (is.null(line$pred)) { - line$pred <- FALSE - } - - join <- amendLine(line$join) - if (is.logical(line$pred) && !line$pred) { # if line$pred is FALSE - line$pred <- NULL - } - pred <- line$pred # process further later - - - # get the rest of the dots - layout <- amendDots(list(...)) - - # legend - if (missing(legend)) { - if (is.null(group)) { - legend <- FALSE - } else { - legend <- TRUE - } - } - - legendList <- amendLegend(legend) - layout <- modifyList(layout, list(showlegend = legendList$showlegend)) - if (length(legendList) > 1) { - layout <- modifyList(layout, list(legend = within(legendList, rm(showlegend)))) - } - - - # grid - layout$xaxis <- setGrid(layout$xaxis, grid) - layout$yaxis <- setGrid(layout$yaxis, grid) - - # axis labels if needed - layout$xaxis$title <- amendTitle(xlab) - if (is.character(ylab)) { - layout$yaxis$title <- amendTitle(ylab, layout$xaxis$title$font) + x, + include = NULL, + exclude = NULL, + line = list(join = TRUE, pred = FALSE), + marker = TRUE, + group = NULL, + group_names = NULL, + mult = 1, + outeq = 1, + out_names = NULL, + block = 1, + tad = FALSE, + overlay = TRUE, + legend, + log = FALSE, + grid = FALSE, + xlab = "Time", + ylab = "Output", + title = "", + xlim, ylim, + print = TRUE, ...) { + # Plot parameters --------------------------------------------------------- + + # process marker + marker <- amendMarker(marker) + marker$color <- map_chr(marker$color, \(x) substr(x, 1, 7)) # remove alpha if present, controlled by opacity + + highlight_color <- opposite_color(marker$color[1]) # in plotly_Utils.R + + + # process line + if (any(!base::names(line) %in% c("join", "pred"))) { + cli::cli_warn(c("!" = "{.code line} should be a list with at most two named elements: {.code join}, {.code loess}, and/or {.code pred}.", "i" = "See {.fn Pmetrics::plot.PM_data}.")) + } + if (is.null(line$join)) { + line$join <- FALSE + } + if (is.null(line$pred)) { + line$pred <- FALSE + } + + join <- amendLine(line$join) + if (is.logical(line$pred) && !line$pred) { # if line$pred is FALSE + line$pred <- NULL + } + pred <- line$pred # process further later + + + # get the rest of the dots + layout <- amendDots(list(...)) + + # legend + if (missing(legend)) { + if (is.null(group)) { + legend <- FALSE } else { - layout$yaxis$title <- amendTitle(ylab) - } - - - # axis ranges - if (!missing(xlim)) { - layout$xaxis <- modifyList(layout$xaxis, list(range = xlim)) + legend <- TRUE } - if (!missing(ylim)) { - layout$yaxis <- modifyList(layout$yaxis, list(range = ylim)) - } - - # log y axis - if (log) { - layout$yaxis <- modifyList(layout$yaxis, list(type = "log")) - } - - # title - layout$title <- amendTitle(title, default = list(size = 20)) - - # overlay - if (is.logical(overlay)) { # T/F - if (!overlay) { # F,default - nrows <- 1 - ncols <- 1 - } # if T, no need to set nrows or ncols - } else { # specified as c(rows, cols) - nrows <- overlay[1] - ncols <- overlay[2] - overlay <- FALSE - } - - # Data processing --------------------------------------------------------- - dat <- x$clone() #make copy of x to work with - - # make blocks - dat$standard_data <- makePMmatrixBlock(dat$standard_data) - - # time after dose - if (tad) { - dat$standard_data$time <- calcTAD(dat$standard_data) - dat$standard_data <- dat$standard_data %>% arrange(id, time) - } - - # filter - presub <- dat$standard_data %>% + } + + legendList <- amendLegend(legend) + layout <- modifyList(layout, list(showlegend = legendList$showlegend)) + if (length(legendList) > 1) { + layout <- modifyList(layout, list(legend = within(legendList, rm(showlegend)))) + } + + + # grid + layout$xaxis <- setGrid(layout$xaxis, grid) + layout$yaxis <- setGrid(layout$yaxis, grid) + + # axis labels if needed + layout$xaxis$title <- amendTitle(xlab) + if (is.character(ylab)) { + layout$yaxis$title <- amendTitle(ylab, layout$xaxis$title$font) + } else { + layout$yaxis$title <- amendTitle(ylab) + } + + + # axis ranges + if (!missing(xlim)) { + layout$xaxis <- modifyList(layout$xaxis, list(range = xlim)) + } + if (!missing(ylim)) { + layout$yaxis <- modifyList(layout$yaxis, list(range = ylim)) + } + + # log y axis + if (log) { + layout$yaxis <- modifyList(layout$yaxis, list(type = "log")) + } + + # title + layout$title <- amendTitle(title, default = list(size = 20)) + + # overlay + if (is.logical(overlay)) { # T/F + if (!overlay) { # F,default + nrows <- 1 + ncols <- 1 + } # if T, no need to set nrows or ncols + } else { # specified as c(rows, cols) + nrows <- overlay[1] + ncols <- overlay[2] + overlay <- FALSE + } + + # Data processing --------------------------------------------------------- + dat <- x$clone() # make copy of x to work with + + # make blocks + dat$standard_data <- makePMmatrixBlock(dat$standard_data) + + # time after dose + if (tad) { + dat$standard_data$time <- calcTAD(dat$standard_data) + dat$standard_data <- dat$standard_data %>% arrange(id, time) + } + + # filter + presub <- dat$standard_data %>% filter(outeq %in% !!outeq, block %in% !!block, evid == 0) %>% includeExclude(include, exclude) - - - - # make group column for groups - if (!is.null(group)) { - if (!group %in% base::names(dat$standard_data)) { - cli::cli_abort(c("x" = "{group} is not a column in the data.")) - } - if (is.null(group_names)) { - presub$group <- presub[[group]] - } else if (length(group_names) < length(unique(presub[[group]]))) { - cli::cli_abort(c("x" = "The number of names in {.var group_names} must be at least as long as the number of unique values in {.var group}.")) - } else { - presub$group <- factor(presub[[group]], labels = group_names) - } - } else { # group was NULL - presub <- presub %>% mutate(group = "") + + + + # make group column for groups + if (!is.null(group)) { + if (!group %in% base::names(dat$standard_data)) { + cli::cli_abort(c("x" = "{group} is not a column in the data.")) + } + if (is.null(group_names)) { + presub$group <- presub[[group]] + } else if (length(group_names) < length(unique(presub[[group]]))) { + cli::cli_abort(c("x" = "The number of names in {.var group_names} must be at least as long as the number of unique values in {.var group}.")) + } else { + presub$group <- factor(presub[[group]], labels = group_names) } - - - # make outeq labels if more than one output being plotted - if (length(outeq) > 1) { - if (is.null(out_names)) { - out_names <- paste0("Output ", 1:max(outeq)) - } else if (length(out_names) < max(outeq)) { - cli::cli_abort(c("x" = "The number of names in {.var out_names} must be at least as long as the maximum number of outputs in {.var outeq}.")) - } - # add outeq to group - presub <- presub %>% + } else { # group was NULL + presub <- presub %>% mutate(group = "") + } + + + # make outeq labels if more than one output being plotted + if (length(outeq) > 1) { + if (is.null(out_names)) { + out_names <- paste0("Output ", 1:max(outeq)) + } else if (length(out_names) < max(outeq)) { + cli::cli_abort(c("x" = "The number of names in {.var out_names} must be at least as long as the maximum number of outputs in {.var outeq}.")) + } + # add outeq to group + presub <- presub %>% rowwise() %>% mutate(group = paste0(group, ", ", out_names[outeq])) - } - - # add blocks if more than one being plotted - if (length(block) > 1) { - presub <- presub %>% + } + + # add blocks if more than one being plotted + if (length(block) > 1) { + presub <- presub %>% rowwise() %>% mutate(group = paste0(group, ", Block ", block)) - } - - # there will always be an Obs group - presub <- presub %>% + } + + # there will always be an Obs group + presub <- presub %>% rowwise() %>% mutate(group = paste0(group, ", Obs ")) - - presub$group <- stringr::str_replace(presub$group, "^\\s*,*\\s*", "") - - # add cens column if missing - if (!"cens" %in% names(presub)) { - presub$cens <- "none" - } - - # select relevant columns - sub <- presub %>% + + presub$group <- stringr::str_replace(presub$group, "^\\s*,*\\s*", "") + + # add cens column if missing + if (!"cens" %in% names(presub)) { + presub$cens <- "none" + } + + # select relevant columns + sub <- presub %>% select(id, time, out, cens, outeq, group) %>% mutate(id = as.character(id)) %>% ungroup() - sub$group <- factor(sub$group) - - # add identifier - sub$src <- "obs" - - # remove missing - sub <- sub %>% filter(out != -99) - - - # now process pred data if there - if (!is.null(pred)) { - if (inherits(pred, c("PM_post", "PM_pop"))) { # only PM_post/pop was supplied, make into a list of 1 - pred <- list(pred$data) - } else if (inherits(pred, c("PM_post_data", "PM_pop_data"))) { # only PM_post_data/PM_pop_data was supplied, make into a list of 1 - pred <- list(pred) - } else if (pred[[1]] %in% c("pop", "post")) { # pred[[1]] was "pop" or "post" - thisPred <- pred[[1]] - if (is.null(x[[thisPred]])) { # post/pop missing because x was data not from a PM_result - cli::cli_warn(c( - "!" = "{.code pred = {thisPred}} can only be used as a shortcut when plotting {.cls PM_data} from a {.cls PM_result}.", - "i" = "Supply a {.cls PM_result} object, e.g. {.code line = list(pred = run2$post)}, if you wish to add predictions otherwise." - )) - pred <- NULL - } else { # post/pop present - pred[[1]] <- x[[thisPred]] - } - } else { # pred[[1]] was not "pop", "post", PM_result$pop, or PM_result$post + sub$group <- factor(sub$group) + + # add identifier + sub$src <- "obs" + + # remove missing + sub <- sub %>% filter(out != -99) + + + # now process pred data if there + if (!is.null(pred)) { + if (inherits(pred, c("PM_post", "PM_pop"))) { # only PM_post/pop was supplied, make into a list of 1 + pred <- list(pred$data) + } else if (inherits(pred, c("PM_post_data", "PM_pop_data"))) { # only PM_post_data/PM_pop_data was supplied, make into a list of 1 + pred <- list(pred) + } else if (pred[[1]] %in% c("pop", "post")) { # pred[[1]] was "pop" or "post" + thisPred <- pred[[1]] + if (is.null(x[[thisPred]])) { # post/pop missing because x was data not from a PM_result cli::cli_warn(c( - "!" = "The {.var pred} argument is mis-specified.", - "i" = "See the help for {.code plot.PM_data}." + "!" = "{.code pred = {thisPred}} can only be used as a shortcut when plotting {.cls PM_data} from a {.cls PM_result}.", + "i" = "Supply a {.cls PM_result} object, e.g. {.code line = list(pred = run2$post)}, if you wish to add predictions otherwise." )) pred <- NULL + } else { # post/pop present + pred[[1]] <- x[[thisPred]] } - - # process pred list to determine formatting - if (length(pred) == 1) { # default - predArgs <- TRUE + } else { # pred[[1]] was not "pop", "post", PM_result$pop, or PM_result$post + cli::cli_warn(c( + "!" = "The {.var pred} argument is mis-specified.", + "i" = "See the help for {.code plot.PM_data}." + )) + pred <- NULL + } + + # process pred list to determine formatting + if (length(pred) == 1) { # default + predArgs <- TRUE + icen <- "median" + } else { # not default, but need to extract icen if present + icen <- purrr::pluck(pred, "icen") # check if icen is in list + if (is.null(icen)) { # not in list so set default icen <- "median" - } else { # not default, but need to extract icen if present - icen <- purrr::pluck(pred, "icen") # check if icen is in list - if (is.null(icen)) { # not in list so set default - icen <- "median" - } else { - purrr::pluck(pred, "icen") <- NULL - } # was in list, so remove after extraction - predArgs <- pred[-1] - } - - predArgs <- amendLine(predArgs) # color will be set by obs later - - # filter and group by id - if (!is.null(pred[[1]])) { # if pred not reset to null b/c of invalid pred[[1]] - predsub <- pred[[1]] %>% + } else { + purrr::pluck(pred, "icen") <- NULL + } # was in list, so remove after extraction + predArgs <- pred[-1] + } + + predArgs <- amendLine(predArgs) # color will be set by obs later + + # filter and group by id + if (!is.null(pred[[1]])) { # if pred not reset to null b/c of invalid pred[[1]] + predsub <- pred[[1]] %>% filter(outeq %in% !!outeq, block %in% !!block, icen == !!icen) %>% mutate(cens = "none") %>% # always none for predictions includeExclude(include, exclude) %>% group_by(id) - - # time after dose - if (tad) { - predsub$time <- calcTAD(predsub) - } - - # select relevant columns and filter missing - predsub <- predsub %>% + + # time after dose + if (tad) { + predsub$time <- calcTAD(predsub) + } + + # select relevant columns and filter missing + predsub <- predsub %>% select(id, time, out = pred, cens, outeq) %>% filter(out != -99 & (cens == "none" | cens == 0)) - - - # add group - lookup <- dplyr::distinct(sub, id, outeq, group) - predsub <- predsub %>% dplyr::left_join(lookup, by = c("id", "outeq")) %>% + + + # add group + lookup <- dplyr::distinct(sub, id, outeq, group) + predsub <- predsub %>% + dplyr::left_join(lookup, by = c("id", "outeq")) %>% mutate(group = factor(stringr::str_replace_all(group, "Obs", "Pred"))) - - # add identifier - predsub$src <- "pred" - } else { # pred was reset to NULL b/c of invalid pred[[1]] - predsub <- NULL - } - } else { # pred was NULL from beginning + + # add identifier + predsub$src <- "pred" + } else { # pred was reset to NULL b/c of invalid pred[[1]] predsub <- NULL - } # end pred processing - - - - # Plot function ---------------------------------------------------------- - - dataPlot <- function(allsub, overlay, includePred) { - - group_colors <- marker$color - group_symbols <- marker$symbol - if (!is.null(group) | length(outeq)>1 | length(block)>1) { # there was grouping beyond obs/pred - - n_colors <- length(unique(allsub$group)) - - if (length(group_colors) < n_colors) { # fewer colors than groups, need to interpolate - if (checkRequiredPackages("RColorBrewer")) { - palettes <- RColorBrewer::brewer.pal.info %>% mutate(name = rownames(.)) - if (length(group_colors) == 1) { # only one color specified - if (group_colors %in% palettes$name){# colors specified as a palette name - max_colors <- palettes$maxcolors[match(group_colors, palettes$name)] - group_colors <- colorRampPalette(RColorBrewer::brewer.pal(max_colors, group_colors))(n_colors) - } else { - group_colors <- c(group_colors, getDefaultColors(n_colors)[-1]) # in plotly_Utils, add default colors to specified color - } - } else { # length of group_colors > 1 but fewer than groups, so interpolate - group_colors <- tryCatch(colorRampPalette(group_colors)(n_colors), + } + } else { # pred was NULL from beginning + predsub <- NULL + } # end pred processing + + + + # Plot function ---------------------------------------------------------- + + dataPlot <- function(allsub, overlay, includePred) { + group_colors <- marker$color + group_symbols <- marker$symbol + if (!is.null(group) | length(outeq) > 1 | length(block) > 1) { # there was grouping beyond obs/pred + + n_colors <- length(unique(allsub$group)) + + if (length(group_colors) < n_colors) { # fewer colors than groups, need to interpolate + if (checkRequiredPackages("RColorBrewer")) { + palettes <- RColorBrewer::brewer.pal.info %>% mutate(name = rownames(.)) + if (length(group_colors) == 1) { # only one color specified + if (group_colors %in% palettes$name) { # colors specified as a palette name + max_colors <- palettes$maxcolors[match(group_colors, palettes$name)] + group_colors <- colorRampPalette(RColorBrewer::brewer.pal(max_colors, group_colors))(n_colors) + } else { + group_colors <- c(group_colors, getDefaultColors(n_colors)[-1]) # in plotly_Utils, add default colors to specified color + } + } else { # length of group_colors > 1 but fewer than groups, so interpolate + group_colors <- tryCatch(colorRampPalette(group_colors)(n_colors), error = function(e) { cli::cli_warn(c("!" = "Unable to interpolate colors, using default colors.")) getDefaultColors(n_colors) # in plotly_Utils @@ -1881,7 +1884,7 @@ plot.PM_data <- function( colors <- getDefaultColors(n_colors) # in plotly_Utils } } - + if (length(group_symbols) < n_colors) { # fewer symbols than groups, need to interpolate if (length(group_symbols) == 1) { # only one symbol specified group_symbols <- rep(group_symbols, n_colors) @@ -1889,443 +1892,451 @@ plot.PM_data <- function( group_symbols <- rep(group_symbols, length.out = n_colors) } } - } else { # no grouping other than possibly pred if (includePred | join$width > 0) { # need colors for both obs and join or pred group_colors <- rep(group_colors, 2) # observed and predicted should be the same - } + } } - - + + # assign colors and symbols to each group, editing for censoring IDstring <- ifelse(overlay, "ID: {id}\n", "") allsub <- allsub %>% - #rowwise() %>% - mutate( - color = group_colors[as.integer(group)], - symbol = group_symbols[as.integer(group)] - ) %>% - mutate( - color = ifelse(cens != "none" & cens != "0", opposite_color(color, degrees = 90), color), - symbol = dplyr::case_when( - cens == "bloq" | cens == "1" ~ "triangle-down", - cens == "none" | cens == "0" ~ as.character(symbol), - cens == "aloq" | cens == "-1" ~ "triangle-up", - .default = symbol), + # rowwise() %>% + mutate( + color = group_colors[as.integer(group)], + symbol = group_symbols[as.integer(group)] + ) %>% + mutate( + color = ifelse(cens != "none" & cens != "0", opposite_color(color, degrees = 90), color), + symbol = dplyr::case_when( + cens == "bloq" | cens == "1" ~ "triangle-down", + cens == "none" | cens == "0" ~ as.character(symbol), + cens == "aloq" | cens == "-1" ~ "triangle-up", + .default = symbol + ), text_label = dplyr::case_when( - cens == "bloq" | cens == "1" ~ glue::glue(IDstring,"Time: {round2(time)}\nBLLQ: {round2(out)}\n{group}"), - cens == "none" | cens == "0" ~ glue::glue(IDstring,"Time: {round2(time)}\nOut: {round2(out)}\n{group}"), - cens == "aloq" | cens == "-1" ~ glue::glue(IDstring,"Time: {round2(time)}\nAULQ: {round2(out)}\n{group}"), - .default = glue::glue(IDstring,"Time: {round2(time)}\nPred: {round2(out)}\n{group}") + cens == "bloq" | cens == "1" ~ glue::glue(IDstring, "Time: {round2(time)}\nBLLQ: {round2(out)}\n{group}"), + cens == "none" | cens == "0" ~ glue::glue(IDstring, "Time: {round2(time)}\nOut: {round2(out)}\n{group}"), + cens == "aloq" | cens == "-1" ~ glue::glue(IDstring, "Time: {round2(time)}\nAULQ: {round2(out)}\n{group}"), + .default = glue::glue(IDstring, "Time: {round2(time)}\nPred: {round2(out)}\n{group}") ) ) %>% ungroup() - - # if ID is numeric, arrange by numeric ID - if(!any(is.na(suppressWarnings(as.numeric(allsub$id))))) { - allsub <- allsub %>% - mutate(id = as.numeric(id)) %>% arrange(id, time) + + # if ID is numeric, arrange by numeric ID + if (!any(is.na(suppressWarnings(as.numeric(allsub$id))))) { + allsub <- allsub %>% + mutate(id = as.numeric(id)) %>% + arrange(id, time) + } + + + seen_groups <- NULL + traces <- if (overlay) { + allsub %>% dplyr::group_split(id) + } else { + list(allsub) + } + + # Build plot + p <- plot_ly() + for (i in seq_along(traces)) { + trace_data <- traces[[i]] + if (any(!unique(trace_data$group) %in% seen_groups)) { + seen_groups <- c(seen_groups, as.character(unique(trace_data$group))) + legendShow <- TRUE + } else { + legendShow <- FALSE } - - - seen_groups <- NULL - traces <- if(overlay) {allsub %>% dplyr::group_split(id)} else {list(allsub)} - - # Build plot - p <- plot_ly() - for (i in seq_along(traces)) { - trace_data <- traces[[i]] - if (any(!unique(trace_data$group) %in% seen_groups)) { - seen_groups <- c(seen_groups, as.character(unique(trace_data$group))) - legendShow <- TRUE - } else { - legendShow <- FALSE - } - this_id <- ifelse(overlay, trace_data$id[1], 1) - - p <- add_trace( - p, - data = trace_data %>% plotly::filter(src == "obs") %>% arrange(group, time), - x = ~time, y = ~ out * mult, - type = "scatter", - mode = "markers", - split = ~group, - name = ~group, - uid = as.character(this_id), - meta = list(id = this_id), - marker = list(color = ~I(color), symbol = ~I(symbol), size = marker$size, opacity = marker$opacity, - line = list(color = marker$line$color, width = marker$line$width)), - text = ~text_label, - hoverinfo = "text", - legendgroup = ~group, - showlegend = legendShow - ) - - # add joining lines if needed - if (join$width > 0){ - trace_split <- trace_data %>% filter(src == "obs") %>% dplyr::group_split(color) - for(j in seq_along(trace_split)){ - this_color <- trace_split[[j]]$color[1] - p <- add_trace( - p, - data = trace_split[[j]], - x = ~time, y = ~(out * mult), - type = "scatter", mode = "lines", - name = ~group, - uid = as.character(this_id), - meta = list(id = this_id), - line = list(color = this_color, width = join$width, dash = join$dash), - text = ~text_label, - hoverinfo = "text", - legendgroup = ~group, - showlegend = FALSE - ) - } + this_id <- ifelse(overlay, trace_data$id[1], 1) + + p <- add_trace( + p, + data = trace_data %>% plotly::filter(src == "obs") %>% arrange(group, time), + x = ~time, y = ~ out * mult, + type = "scatter", + mode = "markers", + split = ~group, + name = ~group, + uid = as.character(this_id), + meta = list(id = this_id), + marker = list( + color = ~ I(color), symbol = ~ I(symbol), size = marker$size, opacity = marker$opacity, + line = list(color = marker$line$color, width = marker$line$width) + ), + text = ~text_label, + hoverinfo = "text", + legendgroup = ~group, + showlegend = legendShow + ) + + # add joining lines if needed + if (join$width > 0) { + trace_split <- trace_data %>% + filter(src == "obs") %>% + dplyr::group_split(color) + for (j in seq_along(trace_split)) { + this_color <- trace_split[[j]]$color[1] + p <- add_trace( + p, + data = trace_split[[j]], + x = ~time, y = ~ (out * mult), + type = "scatter", mode = "lines", + name = ~group, + uid = as.character(this_id), + meta = list(id = this_id), + line = list(color = this_color, width = join$width, dash = join$dash), + text = ~text_label, + hoverinfo = "text", + legendgroup = ~group, + showlegend = FALSE + ) } - - if (includePred) { - trace_split <- trace_data %>% filter(src == "pred") %>% dplyr::group_split(color) - for(j in seq_along(trace_split)){ - this_color <- trace_split[[j]]$color[1] - p <- add_trace( - p, - data = trace_split[[j]], - x = ~time, y = ~(out * mult), - type = "scatter", mode = "lines", - name = ~group, - uid = as.character(this_id), - meta = list(id = this_id), - line = list(color = this_color, width = predArgs$width, dash = predArgs$dash), - text = ~text_label, - hoverinfo = "text", - legendgroup = ~group, - showlegend = legendShow - ) - } + } + + if (includePred) { + trace_split <- trace_data %>% + filter(src == "pred") %>% + dplyr::group_split(color) + for (j in seq_along(trace_split)) { + this_color <- trace_split[[j]]$color[1] + p <- add_trace( + p, + data = trace_split[[j]], + x = ~time, y = ~ (out * mult), + type = "scatter", mode = "lines", + name = ~group, + uid = as.character(this_id), + meta = list(id = this_id), + line = list(color = this_color, width = predArgs$width, dash = predArgs$dash), + text = ~text_label, + hoverinfo = "text", + legendgroup = ~group, + showlegend = legendShow + ) } } - - p <- p %>% plotly::layout( - xaxis = layout$xaxis, - yaxis = layout$yaxis, - title = layout$title, - showlegend = layout$showlegend, - legend = layout$legend - ) - return(invisible(p)) - } # end dataPlot - - - # Call plot --------------------------------------------------------------- - - - # if pred present, need to combine data and pred for proper display - - if (!is.null(predsub)) { - allsub <- dplyr::bind_rows(sub, predsub) %>% dplyr::arrange(id, time) - includePred <- TRUE - } else { - allsub <- sub - includePred <- FALSE } - - - # call the plot function and display appropriately - if (overlay) { - allsub <- allsub %>% dplyr::group_by(id) - p <- dataPlot(allsub, overlay = TRUE, includePred) - - if (print) print(click_plot(p, highlight_color = highlight_color)) - return(invisible(p)) - } else { # overlay = FALSE, ie. split them - - if (!checkRequiredPackages("trelliscopejs")) { - cli::cli_abort(c("x" = "Package {.pkg trelliscopejs} required to plot when {.code overlay = FALSE}.")) - } - sub_split <- allsub %>% + + p <- p %>% plotly::layout( + xaxis = layout$xaxis, + yaxis = layout$yaxis, + title = layout$title, + showlegend = layout$showlegend, + legend = layout$legend + ) + return(invisible(p)) + } # end dataPlot + + + # Call plot --------------------------------------------------------------- + + + # if pred present, need to combine data and pred for proper display + + if (!is.null(predsub)) { + allsub <- dplyr::bind_rows(sub, predsub) %>% dplyr::arrange(id, time) + includePred <- TRUE + } else { + allsub <- sub + includePred <- FALSE + } + + + # call the plot function and display appropriately + if (overlay) { + allsub <- allsub %>% dplyr::group_by(id) + p <- dataPlot(allsub, overlay = TRUE, includePred) + + if (print) print(click_plot(p, highlight_color = highlight_color)) + return(invisible(p)) + } else { # overlay = FALSE, ie. split them + + if (!checkRequiredPackages("trelliscopejs")) { + cli::cli_abort(c("x" = "Package {.pkg trelliscopejs} required to plot when {.code overlay = FALSE}.")) + } + sub_split <- allsub %>% nest(data = -id) %>% mutate(panel = trelliscopejs::map_plot(data, \(x) dataPlot(x, overlay = FALSE, includePred = includePred))) - p <- sub_split %>% + p <- sub_split %>% ungroup() %>% trelliscopejs::trelliscope(name = "Data", nrow = nrows, ncol = ncols) - if (print) print(p) - } - - return(invisible(p)) + if (print) print(p) } - # SUMMARY ----------------------------------------------------------------- - - #' @title Summarize PM_data objects - #' @description - #' `r lifecycle::badge("stable")` - #' - #' Summarize the raw data used for a Pmetrics run. - #' - #' @method summary PM_data - #' @param object A [PM_data] object. - #' @param formula Optional formula for specifying custom summaries. See [aggregate] - #' and [formula] for details on how to specify formulae in R. If, for example, the data contain - #' a covariate for weight named 'wt', then to summarize the mean dose in mg/kg per subject specify - #' `formula = dose/wt ~ id` and `FUN = mean`. - #' @param FUN The summary function to apply to [formula], if specified. This is not - #' quoted, and usual choices will be [mean], [median], [max], or [min]. - #' @param include A vector of subject IDs to include in the summary, e.g. `c(1:3,5,15)` - #' @param exclude A vector of subject IDs to exclude in the summary, e.g. `c(4,6:14,16:20)` - #' @param ... Additional arguments to `FUN`, e.g. `na.rm = TRUE` - #' @return A list of class *summary.PM_data* with the following items: - #' * **nsub** Number of subjects - #' * **ndrug** Number of drug inputs - #' * **numeqt** Number of outputs - #' * **nobsXouteq** Number of observations by outeq - #' * **missObsXouteq** Number of missing observations by outeq - #' * **loqObsXouteq** Number of observations coded as below the limit of quantification by outeq - #' * **ncov** Number of covariates - #' * **covnames** Covariate names - #' * **ndoseXid** Number of doses per input per subject - #' * **nobsXid** Number of observations per outeq per subject - #' * **doseXid** Doses per input per subject - #' * **obsXid** Observations per outeq per subject - #' * **formula** Results of including [formula] - #' @author Michael Neely - #' @seealso [aggregate] - #' @export - - summary.PM_data <- function(object, formula, FUN, include, exclude, ...) { - - if(inherits(object, "PM_data")) { - object <- object$standard_data - } - - # filter data if needed - if (!missing(include)) { - object <- subset(object, sub("[[:space:]]+", "", as.character(object$id)) %in% as.character(include)) - } - if (!missing(exclude)) { - object <- subset(object, !sub("[[:space:]]+", "", as.character(object$id)) %in% as.character(exclude)) - } - - # make results list - results <- list() - idOrder <- rank(unique(object$id)) - - results$nsub <- length(unique(object$id)) - results$ndrug <- max(object$input, na.rm = T) - results$numeqt <- max(object$outeq, na.rm = T) - results$nobsXouteq <- tapply(object$evid, object$outeq, function(x) length(x == 0)) - results$missObsXouteq <- by(object, object$outeq, function(x) length(x$out[x$evid == 0 & x$out == -99])) - - # censored - - results$bloqObsXouteq <- purrr::map_int(1:max(object$outeq, na.rm = TRUE), \(x) sum(object$cens[object$outeq == x] == "1", object$cens[object$outeq == x] == "bloq", na.rm = TRUE)) - results$aloqObsXouteq <- purrr::map_int(1:max(object$outeq, na.rm = TRUE), \(x) sum(object$cens[object$outeq == x] == "-1", object$cens[object$outeq == x] == "aloq", na.rm = TRUE)) - - covinfo <- getCov(object) - ncov <- covinfo$ncov - results$ncov <- ncov - results$covnames <- covinfo$covnames - results$ndoseXid <- as.matrix(tapply(object$evid, list(object$id, object$input), function(x) length(x != 0))[idOrder, ]) - results$nobsXid <- as.matrix(tapply(object$evid, list(object$id, object$outeq), function(x) length(x == 0))[idOrder, ]) - results$doseXid <- as.matrix(tapply(object$dose, list(object$id, object$input), function(x) x[!is.na(x)])[idOrder, ]) - results$obsXid <- as.matrix(tapply(object$out, list(object$id, object$outeq), function(x) x[!is.na(x)])[idOrder, ]) - if (ncov > 0) { - # get each subject's covariate values - results$cov <- lapply(1:ncov, function(y) { - tapply( - object[[covinfo$covstart + y - 1]], object$id, - function(z) z[!is.na(z)] - )[idOrder] - }) - names(results$cov) <- covinfo$covnames - } - if (!missing(formula)) { - results$formula <- aggregate(formula, object, FUN, ...) - } - - class(results) <- c("summary.PM_data", "list") - return(results) - } # end function - # PRINT SUMMARY ----------------------------------------------------------------- - - #' @title Print Summary of Pmetrics Data - #' @description - #' `r lifecycle::badge("stable")` - #' - #' @details - #' Print the summary of [PM_data] object. - #' - #' Summarize the raw data used for a Pmetrics run. - #' - #' @method print summary.PM_data - #' @param x An object made by [summary.PM_data]. - #' @return A printed object - #' @author Michael Neely - #' @param ... Not used. - #' @seealso [summary.PM_data] - #' @examples - #' \dontrun{ - #' dataEx$summary() - #' } - - #' @export - - print.summary.PM_data <- function(x, ...) { - # order of objects - # nsub - # ndrug - # numeqt - # nobsXouteq - # missObsXouteq - # bloqObsXouteq - # aloqObsXouteq - # ncov - # ndoseXid - # nobsXid - # doseXid - # obsXid - # cov - # formula - - cli::cli_div(theme = list( - span.blue = list(color = navy()) - )) - cli::cli_h1("Data Summary") - - cli::cli_text("Number of subjects: {.blue {x$nsub}}") - cli::cli_text("Number of inputs: {.blue {x$ndrug}}") - cli::cli_text("Number of outputs: {.blue {x$numeqt}}") - if (x$ncov > 0) { - cli::cli_text(" Covariates: {.blue {x$covnames}}") - } - cli::cli_h2("Inputs: Mean (SD), Min to Max") - for (i in 1:x$ndrug) { - if (x$ndrug > 1) { - cli::cli_h3("Input {i}") - } - cli::cli_text("Number of doses per subject: {.blue {sprintf('%.3f', mean(x$ndoseXid[, i], na.rm = T))}} ({.blue {sprintf('%.3f', sd(x$ndoseXid[, i], na.rm = T))}}), {.blue {sprintf('%.3f', min(x$ndoseXid[, i], na.rm = T))}} to {.blue {sprintf('%.3f', max(x$ndoseXid[, i], na.rm = T))}} ") - cli::cli_text("Dose amount per subject: {.blue {sprintf('%.3f', mean(unlist(x$doseXid[, i]), na.rm = T))}} ({.blue {sprintf('%.3f', sd(unlist(x$doseXid[, i]), na.rm = T))}}), {.blue {sprintf('%.3f', min(unlist(x$doseXid[, i]), na.rm = T))}} to {.blue {sprintf('%.3f', max(unlist(x$doseXid[, i]), na.rm = T))}} ") - + + return(invisible(p)) +} +# SUMMARY ----------------------------------------------------------------- + +#' @title Summarize PM_data objects +#' @description +#' `r lifecycle::badge("stable")` +#' +#' Summarize the raw data used for a Pmetrics run. +#' +#' @method summary PM_data +#' @param object A [PM_data] object. +#' @param formula Optional formula for specifying custom summaries. See [aggregate] +#' and [formula] for details on how to specify formulae in R. If, for example, the data contain +#' a covariate for weight named 'wt', then to summarize the mean dose in mg/kg per subject specify +#' `formula = dose/wt ~ id` and `FUN = mean`. +#' @param FUN The summary function to apply to [formula], if specified. This is not +#' quoted, and usual choices will be [mean], [median], [max], or [min]. +#' @param include A vector of subject IDs to include in the summary, e.g. `c(1:3,5,15)` +#' @param exclude A vector of subject IDs to exclude in the summary, e.g. `c(4,6:14,16:20)` +#' @param ... Additional arguments to `FUN`, e.g. `na.rm = TRUE` +#' @return A list of class *summary.PM_data* with the following items: +#' * **nsub** Number of subjects +#' * **ndrug** Number of drug inputs +#' * **numeqt** Number of outputs +#' * **nobsXouteq** Number of observations by outeq +#' * **missObsXouteq** Number of missing observations by outeq +#' * **loqObsXouteq** Number of observations coded as below the limit of quantification by outeq +#' * **ncov** Number of covariates +#' * **covnames** Covariate names +#' * **ndoseXid** Number of doses per input per subject +#' * **nobsXid** Number of observations per outeq per subject +#' * **doseXid** Doses per input per subject +#' * **obsXid** Observations per outeq per subject +#' * **formula** Results of including [formula] +#' @author Michael Neely +#' @seealso [aggregate] +#' @export + +summary.PM_data <- function(object, formula, FUN, include, exclude, ...) { + if (inherits(object, "PM_data")) { + object <- object$standard_data + } + + # filter data if needed + if (!missing(include)) { + object <- subset(object, sub("[[:space:]]+", "", as.character(object$id)) %in% as.character(include)) + } + if (!missing(exclude)) { + object <- subset(object, !sub("[[:space:]]+", "", as.character(object$id)) %in% as.character(exclude)) + } + + # make results list + results <- list() + idOrder <- rank(unique(object$id)) + + results$nsub <- length(unique(object$id)) + results$ndrug <- max(object$input, na.rm = T) + results$numeqt <- max(object$outeq, na.rm = T) + results$nobsXouteq <- tapply(object$evid, object$outeq, function(x) length(x == 0)) + results$missObsXouteq <- by(object, object$outeq, function(x) length(x$out[x$evid == 0 & x$out == -99])) + + # censored + + results$bloqObsXouteq <- purrr::map_int(1:max(object$outeq, na.rm = TRUE), \(x) sum(object$cens[object$outeq == x] == "1", object$cens[object$outeq == x] == "bloq", na.rm = TRUE)) + results$aloqObsXouteq <- purrr::map_int(1:max(object$outeq, na.rm = TRUE), \(x) sum(object$cens[object$outeq == x] == "-1", object$cens[object$outeq == x] == "aloq", na.rm = TRUE)) + + covinfo <- getCov(object) + ncov <- covinfo$ncov + results$ncov <- ncov + results$covnames <- covinfo$covnames + results$ndoseXid <- as.matrix(tapply(object$evid, list(object$id, object$input), function(x) length(x != 0))[idOrder, ]) + results$nobsXid <- as.matrix(tapply(object$evid, list(object$id, object$outeq), function(x) length(x == 0))[idOrder, ]) + results$doseXid <- as.matrix(tapply(object$dose, list(object$id, object$input), function(x) x[!is.na(x)])[idOrder, ]) + results$obsXid <- as.matrix(tapply(object$out, list(object$id, object$outeq), function(x) x[!is.na(x)])[idOrder, ]) + if (ncov > 0) { + # get each subject's covariate values + results$cov <- lapply(1:ncov, function(y) { + tapply( + object[[covinfo$covstart + y - 1]], object$id, + function(z) z[!is.na(z)] + )[idOrder] + }) + names(results$cov) <- covinfo$covnames + } + if (!missing(formula)) { + results$formula <- aggregate(formula, object, FUN, ...) + } + + class(results) <- c("summary.PM_data", "list") + return(results) +} # end function +# PRINT SUMMARY ----------------------------------------------------------------- + +#' @title Print Summary of Pmetrics Data +#' @description +#' `r lifecycle::badge("stable")` +#' +#' @details +#' Print the summary of [PM_data] object. +#' +#' Summarize the raw data used for a Pmetrics run. +#' +#' @method print summary.PM_data +#' @param x An object made by [summary.PM_data]. +#' @return A printed object +#' @author Michael Neely +#' @param ... Not used. +#' @seealso [summary.PM_data] +#' @examples +#' \dontrun{ +#' dataEx$summary() +#' } + +#' @export + +print.summary.PM_data <- function(x, ...) { + # order of objects + # nsub + # ndrug + # numeqt + # nobsXouteq + # missObsXouteq + # bloqObsXouteq + # aloqObsXouteq + # ncov + # ndoseXid + # nobsXid + # doseXid + # obsXid + # cov + # formula + + cli::cli_div(theme = list( + span.blue = list(color = navy()) + )) + cli::cli_h1("Data Summary") + + cli::cli_text("Number of subjects: {.blue {x$nsub}}") + cli::cli_text("Number of inputs: {.blue {x$ndrug}}") + cli::cli_text("Number of outputs: {.blue {x$numeqt}}") + if (x$ncov > 0) { + cli::cli_text(" Covariates: {.blue {x$covnames}}") + } + cli::cli_h2("Inputs: Mean (SD), Min to Max") + for (i in 1:x$ndrug) { + if (x$ndrug > 1) { + cli::cli_h3("Input {i}") } - cli::cli_h2("Outputs: Mean (SD), Min to Max") - for (i in 1:x$numeqt) { - if (x$numeqt > 1) { - cli::cli_h3("Output {i}") - } - nobs <- unlist(x$nobsXid[, i]) - mean_nobs <- mean(nobs, na.rm = T) - sd_nobs <- sd(nobs, na.rm = T) - min_nobs <- min(nobs, na.rm = T) - max_nobs <- max(nobs, na.rm = T) - - obs <- unlist(x$obsXid[, i]) - obs <- obs[obs != -99] - mean_obs <- mean(obs, na.rm = T) - sd_obs <- sd(obs, na.rm = T) - min_obs <- min(obs, na.rm = T) - max_obs <- max(obs, na.rm = T) - - if (x$bloqObsXouteq[i] > 0) { - extra_text <- ", and {.blue {x$bloqObsXouteq[i]}} ({.blue {sprintf('%.3f', 100 * x$bloqObsXouteq[i] / x$nobsXouteq[i])}%}) censored as below a lower LOQ" - } else { - extra_text <- "" - } - - if (x$aloqObsXouteq[i] > 0) { - extra_text <- paste0(extra_text, ", and {.blue {x$aloqObsXouteq[i]}} ({.blue {sprintf('%.3f', 100 * x$aloqObsXouteq[i] / x$nobsXouteq[i])}%}) censored as above an upper LOQ") - } - cli::cli_text("Total across all subjects: {.blue {x$nobsXouteq[i]}}, with {.blue {x$missObsXouteq[i]}} ({.blue {sprintf('%.3f', 100 * x$missObsXouteq[i] / x$nobsXouteq[i])}%}) missing", extra_text, ".") - cli::cli_text("Number per subject: {.blue {sprintf('%.3f', mean_nobs)}} ({.blue {sprintf('%.3f', sd_nobs)}}), {.blue {sprintf('%i', min_nobs)}} to {.blue {sprintf('%i', max_nobs)}} ") - cli::cli_text("Value per subject: {.blue {sprintf('%.3f', mean_obs)}} ({.blue {sprintf('%.3f', sd_obs)}}), {.blue {sprintf('%.3f', min_obs)}} to {.blue {sprintf('%.3f', max_obs)}} ") + cli::cli_text("Number of doses per subject: {.blue {sprintf('%.3f', mean(x$ndoseXid[, i], na.rm = T))}} ({.blue {sprintf('%.3f', sd(x$ndoseXid[, i], na.rm = T))}}), {.blue {sprintf('%.3f', min(x$ndoseXid[, i], na.rm = T))}} to {.blue {sprintf('%.3f', max(x$ndoseXid[, i], na.rm = T))}} ") + cli::cli_text("Dose amount per subject: {.blue {sprintf('%.3f', mean(unlist(x$doseXid[, i]), na.rm = T))}} ({.blue {sprintf('%.3f', sd(unlist(x$doseXid[, i]), na.rm = T))}}), {.blue {sprintf('%.3f', min(unlist(x$doseXid[, i]), na.rm = T))}} to {.blue {sprintf('%.3f', max(unlist(x$doseXid[, i]), na.rm = T))}} ") + } + cli::cli_h2("Outputs: Mean (SD), Min to Max") + for (i in 1:x$numeqt) { + if (x$numeqt > 1) { + cli::cli_h3("Output {i}") + } + nobs <- unlist(x$nobsXid[, i]) + mean_nobs <- mean(nobs, na.rm = T) + sd_nobs <- sd(nobs, na.rm = T) + min_nobs <- min(nobs, na.rm = T) + max_nobs <- max(nobs, na.rm = T) + + obs <- unlist(x$obsXid[, i]) + obs <- obs[obs != -99] + mean_obs <- mean(obs, na.rm = T) + sd_obs <- sd(obs, na.rm = T) + min_obs <- min(obs, na.rm = T) + max_obs <- max(obs, na.rm = T) + + if (x$bloqObsXouteq[i] > 0) { + extra_text <- ", and {.blue {x$bloqObsXouteq[i]}} ({.blue {sprintf('%.3f', 100 * x$bloqObsXouteq[i] / x$nobsXouteq[i])}%}) censored as below a lower LOQ" + } else { + extra_text <- "" } - if (x$ncov > 0) { - cli::cli_h2("Population level covariates: Mean (SD), Min to Max") - for (i in 1:x$ncov) { - cli::cli_text("{x$covnames[i]}: {.blue {sprintf('%.3f', mean(unlist(x$cov[[i]]), na.rm = T))}} ({.blue {sprintf('%.3f', sd(unlist(x$cov[[i]]), na.rm = T))}}), {.blue {sprintf('%.3f', min(unlist(x$cov[[i]]), na.rm = T))}} to {.blue {sprintf('%.3f', max(unlist(x$cov[[i]]), na.rm = T))}}") - } + + if (x$aloqObsXouteq[i] > 0) { + extra_text <- paste0(extra_text, ", and {.blue {x$aloqObsXouteq[i]}} ({.blue {sprintf('%.3f', 100 * x$aloqObsXouteq[i] / x$nobsXouteq[i])}%}) censored as above an upper LOQ") } - - if (!is.null(x$formula)) { - cli::cli_h2("Formula Results") - print(x$formula) + cli::cli_text("Total across all subjects: {.blue {x$nobsXouteq[i]}}, with {.blue {x$missObsXouteq[i]}} ({.blue {sprintf('%.3f', 100 * x$missObsXouteq[i] / x$nobsXouteq[i])}%}) missing", extra_text, ".") + cli::cli_text("Number per subject: {.blue {sprintf('%.3f', mean_nobs)}} ({.blue {sprintf('%.3f', sd_nobs)}}), {.blue {sprintf('%i', min_nobs)}} to {.blue {sprintf('%i', max_nobs)}} ") + cli::cli_text("Value per subject: {.blue {sprintf('%.3f', mean_obs)}} ({.blue {sprintf('%.3f', sd_obs)}}), {.blue {sprintf('%.3f', min_obs)}} to {.blue {sprintf('%.3f', max_obs)}} ") + } + if (x$ncov > 0) { + cli::cli_h2("Population level covariates: Mean (SD), Min to Max") + for (i in 1:x$ncov) { + cli::cli_text("{x$covnames[i]}: {.blue {sprintf('%.3f', mean(unlist(x$cov[[i]]), na.rm = T))}} ({.blue {sprintf('%.3f', sd(unlist(x$cov[[i]]), na.rm = T))}}), {.blue {sprintf('%.3f', min(unlist(x$cov[[i]]), na.rm = T))}} to {.blue {sprintf('%.3f', max(unlist(x$cov[[i]]), na.rm = T))}}") } - cli::cli_text("") - cli::cli_text("{.strong Note:} See {.help summary.PM_data} for more summary options using {.arg formula}.") - } # end function - # WRITE ------------------------------------------------------------------- - - #' @title Write a Pmetrics .csv Matrix File - #' @description - #' `r lifecycle::badge("superseded")` - #' - #' This function is largely superseded as the function is accessed with - #' the `$save()` method for [PM_data] objects. There is rarely a need to call - #' it directly. It is the companion function to [PMreadMatrix]. - #' It will write an appropriate R data object to a formatted .csv file. - #' @details - #' *PMwriteMatrix* will first run [PMcheck] to determine - #' if there are any errors in the structure of `data`. If the error check - #' fails, the file will not be written and a message will be printed on the console. - #' - #' @param data Must be a data.frame with appropriate structure (see [PMcheck]). - #' @param filename Name of file to create. - #' @param override Boolean operator to write even if errors are detected. Default is `FALSE`. - #' @param version Which matrix data format version to write. Default is the current version. - #' @param header Is there a header row? Default is `FALSE` as this was the legacy format. - #' @return Returns the error report (see [PMcheck] for details). - #' @author Michael Neely - #' @seealso [PM_data], [PMcheck], [PMreadMatrix] - #' @export - #' @examples - #' \dontrun{ - #' # write to the current directory - #' NPex$data$save("data.csv") - #' } - PMwriteMatrix <- function( + } + + if (!is.null(x$formula)) { + cli::cli_h2("Formula Results") + print(x$formula) + } + cli::cli_text("") + cli::cli_text("{.strong Note:} See {.help summary.PM_data} for more summary options using {.arg formula}.") +} # end function +# WRITE ------------------------------------------------------------------- + +#' @title Write a Pmetrics .csv Matrix File +#' @description +#' `r lifecycle::badge("superseded")` +#' +#' This function is largely superseded as the function is accessed with +#' the `$save()` method for [PM_data] objects. There is rarely a need to call +#' it directly. It is the companion function to [PMreadMatrix]. +#' It will write an appropriate R data object to a formatted .csv file. +#' @details +#' *PMwriteMatrix* will first run [PMcheck] to determine +#' if there are any errors in the structure of `data`. If the error check +#' fails, the file will not be written and a message will be printed on the console. +#' +#' @param data Must be a data.frame with appropriate structure (see [PMcheck]). +#' @param filename Name of file to create. +#' @param override Boolean operator to write even if errors are detected. Default is `FALSE`. +#' @param version Which matrix data format version to write. Default is the current version. +#' @param header Is there a header row? Default is `FALSE` as this was the legacy format. +#' @return Returns the error report (see [PMcheck] for details). +#' @author Michael Neely +#' @seealso [PM_data], [PMcheck], [PMreadMatrix] +#' @export +#' @examples +#' \dontrun{ +#' # write to the current directory +#' NPex$data$save("data.csv") +#' } +PMwriteMatrix <- function( data, filename, override = FALSE, version = "DEC_11", header = FALSE) { - if (!override) { - err <- PMcheck(data, quiet = TRUE) - if (length(grep("FAIL", err)) > 0) { - cli::cli_warn(c("!" = "Write failed; returning errors.")) - return(invisible(err)) - } - } else { - err <- NULL - } - # remove the block column if added during run - if ("block" %in% names(data)) { - data <- data %>% dplyr::select(-block) - } - - versionNum <- as.numeric(substr(version, 5, 7)) + switch(substr(version, 1, 3), - JAN = 1, - FEB = 2, - MAR = 3, - APR = 4, - MAY = 5, - JUN = 6, - JUL = 7, - AUG = 8, - SEP = 9, - OCT = 10, - NOV = 11, - DEC = 12 - ) / 100 - if (versionNum < 11.12) { - if (tolower(names(data)[6]) == "addl") data <- data[, c(-6, -7)] - } - OS <- getOS() - eol <- c("\r\n", "\n", "\r\n")[OS] - f <- file(filename, "w") - if (header) { - writeLines(paste("POPDATA ", version, "\n#", sep = ""), f, sep = "") + if (!override) { + err <- PMcheck(data, quiet = TRUE) + if (length(grep("FAIL", err)) > 0) { + cli::cli_warn(c("!" = "Write failed; returning errors.")) + return(invisible(err)) } - writeLines(toupper(names(data)[-ncol(data)]), sep = getPMoptions("sep"), f) - writeLines(toupper(names(data)[ncol(data)]), f) - write.table(data, f, - row.names = FALSE, na = ".", quote = F, sep = getPMoptions("sep"), - dec = getPMoptions("dec"), col.names = F, eol = eol - ) - close(f) - return(invisible(err)) + } else { + err <- NULL + } + # remove the block column if added during run + if ("block" %in% names(data)) { + data <- data %>% dplyr::select(-block) } - \ No newline at end of file + + versionNum <- as.numeric(substr(version, 5, 7)) + switch(substr(version, 1, 3), + JAN = 1, + FEB = 2, + MAR = 3, + APR = 4, + MAY = 5, + JUN = 6, + JUL = 7, + AUG = 8, + SEP = 9, + OCT = 10, + NOV = 11, + DEC = 12 + ) / 100 + if (versionNum < 11.12) { + if (tolower(names(data)[6]) == "addl") data <- data[, c(-6, -7)] + } + OS <- getOS() + eol <- c("\r\n", "\n", "\r\n")[OS] + f <- file(filename, "w") + if (header) { + writeLines(paste("POPDATA ", version, "\n#", sep = ""), f, sep = "") + } + writeLines(toupper(names(data)[-ncol(data)]), sep = getPMoptions("sep"), f) + writeLines(toupper(names(data)[ncol(data)]), f) + write.table(data, f, + row.names = FALSE, na = ".", quote = F, sep = getPMoptions("sep"), + dec = getPMoptions("dec"), col.names = F, eol = eol + ) + close(f) + return(invisible(err)) +} diff --git a/R/PM_model.R b/R/PM_model.R index d974d22d3..fb5928c0a 100644 --- a/R/PM_model.R +++ b/R/PM_model.R @@ -376,19 +376,68 @@ PM_model <- R6::R6Class( #' ``` #' @param ... Not currently used. initialize = function(x = NULL, - pri = NULL, - cov = NULL, - sec = NULL, - eqn = NULL, - lag = NULL, - fa = NULL, - ini = NULL, - out = NULL, - err = NULL, - ...) { - # Store the original function arguments - self$arg_list <- list( - # x = x, + pri = NULL, + cov = NULL, + sec = NULL, + eqn = NULL, + lag = NULL, + fa = NULL, + ini = NULL, + out = NULL, + err = NULL, + ...) { + # Store the original function arguments + self$arg_list <- list( + # x = x, + pri = pri, + cov = cov, + sec = sec, + eqn = eqn, + lag = lag, + fa = fa, + ini = ini, + out = out, + err = err + ) + + if (!is.null(x)) { + model_sections <- c("pri", "cov", "sec", "eqn", "lag", "fa", "ini", "out", "err") + if (is.character(x) && length(x) == 1) { # x is a filename + if (!file.exists(x)) { + cli::cli_abort(c( + "x" = "File {.file {x}} does not exist.", + "i" = "Current directory: {getwd()}" + )) + } + self$arg_list <- private$R6fromFile(x) # read file and populate fields + } else if (is.list(x)) { # x is a list in R + purrr::walk(model_sections, \(s) { + if (s %in% names(x)) { + self$arg_list[[s]] <- x[[s]] + } + }) + } else if (inherits(x, "PM_model")) { # x is a PM_model object + if (!"arg_list" %in% names(x)) { + cli::cli_abort(c( + "x" = "You have supplied an older {.code PM_model} format.", + "i" = "Please see for {.help Pmetrics::PM_model()} to remake it." + )) + } + + purrr::walk(model_sections, \(s) { + if (s %in% names(x$arg_list)) { + self$arg_list[[s]] <- x$arg_list[[s]] + } + }) + self$arg_list$x <- NULL + } else { + cli::cli_abort(c( + "x" = "Non supported input for {.arg x}: {typeof(x)}", + "i" = "It must be a filename, list, or current {.code PM_model} object." + )) + } + } else { # x is NULL, check if other arguments are NULL + named_args <- list( pri = pri, cov = cov, sec = sec, @@ -399,2104 +448,2141 @@ PM_model <- R6::R6Class( out = out, err = err ) - - if (!is.null(x)) { - model_sections <- c("pri", "cov", "sec", "eqn", "lag", "fa", "ini", "out", "err") - if (is.character(x) && length(x) == 1) { # x is a filename - if (!file.exists(x)) { - cli::cli_abort(c( - "x" = "File {.file {x}} does not exist.", - "i" = "Current directory: {getwd()}" - )) - } - self$arg_list <- private$R6fromFile(x) # read file and populate fields - } else if (is.list(x)) { # x is a list in R - purrr::walk(model_sections, \(s) { - if (s %in% names(x)) { - self$arg_list[[s]] <- x[[s]] - } - }) - } else if (inherits(x, "PM_model")) { # x is a PM_model object - if (!"arg_list" %in% names(x)) { - cli::cli_abort(c( - "x" = "You have supplied an older {.code PM_model} format.", - "i" = "Please see for {.help Pmetrics::PM_model()} to remake it." - )) - } - - purrr::walk(model_sections, \(s) { - if (s %in% names(x$arg_list)) { - self$arg_list[[s]] <- x$arg_list[[s]] - } - }) - self$arg_list$x <- NULL - } else { - cli::cli_abort(c( - "x" = "Non supported input for {.arg x}: {typeof(x)}", - "i" = "It must be a filename, list, or current {.code PM_model} object." - )) - } - } else { # x is NULL, check if other arguments are NULL - named_args <- list( - pri = pri, - cov = cov, - sec = sec, - eqn = eqn, - lag = lag, - fa = fa, - ini = ini, - out = out, - err = err - ) - other_args <- list(...) - all_args <- c(named_args, other_args) - if (all(sapply(all_args, is.null))) { # everything is NULL - self <- build_model() # launch the shiny app - return(invisible(self)) - } - } # no, some arguments were not NULL, so keep going - - msg <- NULL - - # check for reserved variable names - conflict_vars <- reserved_name_conflicts(self$arg_list) - if (length(conflict_vars) > 0) { - msg <- "The following {?is a/are} reserved name{?s} and cannot be used as {?a variable or covariate/variables or covariates} in the model: {.var {conflict_vars}}." - } - - # Primary parameters must be provided - if (is.null(self$arg_list$pri)) { - msg <- c(msg, "Primary parameters are missing.") - } - - - # Either an ODE-based model or an analytical model must be provided in eqn - if (is.null(self$arg_list$eqn)) { - msg <- c(msg, "No equations or template provided. Please provide either a template (see {.help model_lib}) or differential equations.") + other_args <- list(...) + all_args <- c(named_args, other_args) + if (all(sapply(all_args, is.null))) { # everything is NULL + self <- build_model() # launch the shiny app + return(invisible(self)) } - - - - # Get model template name if present (NA if absent) and set type - model_template <- get_found_model(self$arg_list$eqn) # function defined below, returns 0 if not found, -1 if error - - # change logic; need to accomodate library models that are ODEs - if (length(model_template) > 1 && model_template$analytical) { - type <- "Analytical" - } else { - if (model_template == -1) { - # length was 1, value 0 - msg <- c(msg, "A maximum of one model template can be included in a model.") - } - + } # no, some arguments were not NULL, so keep going + + msg <- NULL + + # check for reserved variable names + conflict_vars <- reserved_name_conflicts(self$arg_list) + if (length(conflict_vars) > 0) { + msg <- "The following {?is a/are} reserved name{?s} and cannot be used as {?a variable or covariate/variables or covariates} in the model: {.var {conflict_vars}}." + } + + # Primary parameters must be provided + if (is.null(self$arg_list$pri)) { + msg <- c(msg, "Primary parameters are missing.") + } + + + # Either an ODE-based model or an analytical model must be provided in eqn + if (is.null(self$arg_list$eqn)) { + msg <- c(msg, "No equations or template provided. Please provide either a template (see {.help model_lib}) or differential equations.") + } + + + + # Get model template name if present (NA if absent) and set type + model_template <- get_found_model(self$arg_list$eqn) # function defined below, returns 0 if not found, -1 if error + + # change logic; need to accomodate library models that are ODEs + if (length(model_template) > 1 && model_template$analytical) { + type <- "Analytical" + } else { + if (model_template == -1) { # length was 1, value 0 - type <- "ODE" - } - - # Number of equations - n_eqn <- if (type == "Analytical") { - model_template$ncomp - } else { - get_assignments(self$arg_list$eqn, "dx") + msg <- c(msg, "A maximum of one model template can be included in a model.") } - n_out <- get_assignments(self$arg_list$out, "y") - - ## Get the names of the parameters - parameters <- tolower(names(self$arg_list$pri)) - covariates <- tolower(names(self$arg_list$cov)) - ## check to make sure required parameters present if Analytical - if (type == "Analytical") { - # look in pri, sec, eqn, lag, fa, ini, out blocks for required parameters - required_parameters <- tolower(model_template$parameters) - pri_list <- map_lgl(required_parameters, \(x){ - if (x %in% parameters) { + + # length was 1, value 0 + type <- "ODE" + } + + # Number of equations + n_eqn <- if (type == "Analytical") { + model_template$ncomp + } else { + get_assignments(self$arg_list$eqn, "dx") + } + n_out <- get_assignments(self$arg_list$out, "y") + + ## Get the names of the parameters + parameters <- tolower(names(self$arg_list$pri)) + covariates <- tolower(names(self$arg_list$cov)) + ## check to make sure required parameters present if Analytical + if (type == "Analytical") { + # look in pri, sec, eqn, lag, fa, ini, out blocks for required parameters + required_parameters <- tolower(model_template$parameters) + pri_list <- map_lgl(required_parameters, \(x){ + if (x %in% parameters) { + return(TRUE) + } else { + return(FALSE) + } + }) + + if (length(covariates) > 0) { + cov_list <- map_lgl(required_parameters, \(x){ + if (x %in% covariates) { return(TRUE) } else { return(FALSE) } }) - - if (length(covariates) > 0) { - cov_list <- map_lgl(required_parameters, \(x){ - if (x %in% covariates) { - return(TRUE) - } else { - return(FALSE) - } - }) - } else { - cov_list <- rep(FALSE, length(required_parameters)) - } - - if (!is.null(self$arg_list$sec)) { - sec_list <- map_lgl(required_parameters, \(x){ - any(stringr::str_detect(tolower(func_to_char(self$arg_list$sec)), x)) - }) - } else { - sec_list <- rep(FALSE, length(required_parameters)) - } - - eqn_list <- map_lgl(required_parameters, \(x){ + } else { + cov_list <- rep(FALSE, length(required_parameters)) + } + + if (!is.null(self$arg_list$sec)) { + sec_list <- map_lgl(required_parameters, \(x){ + any(stringr::str_detect(tolower(func_to_char(self$arg_list$sec)), x)) + }) + } else { + sec_list <- rep(FALSE, length(required_parameters)) + } + + eqn_list <- map_lgl(required_parameters, \(x){ + any( + stringr::str_detect( + stringr::str_remove_all(tolower(func_to_char(self$arg_list$eqn)), "\\s+"), # string + paste0(x, "(?=(<-|=))") + ) # pattern + ) + }) + + if (!is.null(self$arg_lag)) { + lag_list <- map_lgl(required_parameters, \(x){ any( stringr::str_detect( - stringr::str_remove_all(tolower(func_to_char(self$arg_list$eqn)), "\\s+"), # string + stringr::str_remove_all(tolower(func_to_char(self$arg_list$lag)), "\\s+"), # string paste0(x, "(?=(<-|=))") ) # pattern ) }) - - if (!is.null(self$arg_lag)) { - lag_list <- map_lgl(required_parameters, \(x){ - any( - stringr::str_detect( - stringr::str_remove_all(tolower(func_to_char(self$arg_list$lag)), "\\s+"), # string - paste0(x, "(?=(<-|=))") - ) # pattern - ) - }) - } else { - lag_list <- rep(FALSE, length(required_parameters)) - } - - if (!is.null(self$arg_fa)) { - lag_list <- map_lgl(required_parameters, \(x){ - any( - stringr::str_detect( - stringr::str_remove_all(tolower(func_to_char(self$arg_list$fa)), "\\s+"), # string - paste0(x, "(?=(<-|=))") - ) # pattern - ) - }) - } else { - fa_list <- rep(FALSE, length(required_parameters)) - } - - if (!is.null(self$arg_ini)) { - ini_list <- map_lgl(required_parameters, \(x){ - any( - stringr::str_detect( - stringr::str_remove_all(tolower(func_to_char(self$arg_list$ini)), "\\s+"), # string - paste0(x, "(?=(<-|=))") - ) # pattern - ) - }) - } else { - ini_list <- rep(FALSE, length(required_parameters)) - } - - out_list <- map_lgl(required_parameters, \(x){ + } else { + lag_list <- rep(FALSE, length(required_parameters)) + } + + if (!is.null(self$arg_fa)) { + lag_list <- map_lgl(required_parameters, \(x){ any( stringr::str_detect( - stringr::str_remove_all(tolower(func_to_char(self$arg_list$out)), "\\s+"), # string + stringr::str_remove_all(tolower(func_to_char(self$arg_list$fa)), "\\s+"), # string paste0(x, "(?=(<-|=))") ) # pattern ) }) - - all_lists <- bind_rows( - tibble::tibble( - parameter = required_parameters, - pri = pri_list, - cov = cov_list, - sec = sec_list, - eqn = eqn_list, - lag = lag_list, - fa = fa_list, - ini = ini_list, - out = out_list - ) - ) %>% mutate(ok = purrr::pmap_lgl(across(pri:out), any)) - - - if (any(!all_lists$ok)) { - missing <- all_lists$parameter[!all_lists$ok] - msg <- c( - msg, - "The following parameters are required for the {.code {model_template$name}} model template but are missing: {missing}", - "They should be defined in one of the model blocks, likely {.code pri}, {.code sec}, {.code eqn}, or {.code out}.", - "Parameters defined in {.code pri} and {.code sec} are available to all blocks.", - "Parameters defined in other blocks are only available to that block." - ) - } - } # end parameter checks for Analytical model - - - # if Analytical, need to combine sec and eqn - if (type == "Analytical") { - # shell function - sec_eqn <- function() {} - # define the body of the shell function - body(sec_eqn) <- suppressWarnings(as.call(c( - quote(`{`), - as.list(body(self$arg_list$eqn))[-1], # remove outer `{` of f1 - as.list(body(self$arg_list$sec))[-1] # remove outer `{` of f2 - ))) - - # this will include template and equations in both sec and eqn - } - - # sec - # still needed for analytic, because these equations will be used - # in other blocks - - if (!is.null(self$arg_list$sec)) { - sec <- transpile_sec(self$arg_list$sec) - } else { - sec <- "" - } - - # eqn - if (type == "ODE") { - eqn <- transpile_ode_eqn(self$arg_list$eqn, parameters, covariates, sec) - } else if (type == "Analytical") { - eqn <- transpile_analytic_eqn(sec_eqn, parameters, covariates) - } - - # fa - if (!is.null(self$arg_list$fa)) { - fa <- transpile_fa(self$arg_list$fa, parameters, covariates, sec) } else { - fa <- empty_fa() + fa_list <- rep(FALSE, length(required_parameters)) } - - # lag - if (!is.null(self$arg_list$lag)) { - lag <- transpile_lag(self$arg_list$lag, parameters, covariates, sec) - } else { - lag <- empty_lag() - } - - # ini - if (!is.null(self$arg_list$ini)) { - ini <- transpile_ini(self$arg_list$ini, parameters, covariates, sec) - } else { - ini <- empty_ini() - } - - # out - if (!is.null(self$arg_list$out)) { - out <- transpile_out(self$arg_list$out, parameters, covariates, sec) + + if (!is.null(self$arg_ini)) { + ini_list <- map_lgl(required_parameters, \(x){ + any( + stringr::str_detect( + stringr::str_remove_all(tolower(func_to_char(self$arg_list$ini)), "\\s+"), # string + paste0(x, "(?=(<-|=))") + ) # pattern + ) + }) } else { - out <- empty_out() - } - - # err - if (is.null(self$arg_list$err)) { - msg <- c(msg, "Error model is missing and required.") + ini_list <- rep(FALSE, length(required_parameters)) } - - # ensure length err matches length outeqs - if (length(self$arg_list$err) != n_out) { - msg <- c(msg, "There must be one error model for each output equation.") + + out_list <- map_lgl(required_parameters, \(x){ + any( + stringr::str_detect( + stringr::str_remove_all(tolower(func_to_char(self$arg_list$out)), "\\s+"), # string + paste0(x, "(?=(<-|=))") + ) # pattern + ) + }) + + all_lists <- bind_rows( + tibble::tibble( + parameter = required_parameters, + pri = pri_list, + cov = cov_list, + sec = sec_list, + eqn = eqn_list, + lag = lag_list, + fa = fa_list, + ini = ini_list, + out = out_list + ) + ) %>% mutate(ok = purrr::pmap_lgl(across(pri:out), any)) + + + if (any(!all_lists$ok)) { + missing <- all_lists$parameter[!all_lists$ok] + msg <- c( + msg, + "The following parameters are required for the {.code {model_template$name}} model template but are missing: {missing}", + "They should be defined in one of the model blocks, likely {.code pri}, {.code sec}, {.code eqn}, or {.code out}.", + "Parameters defined in {.code pri} and {.code sec} are available to all blocks.", + "Parameters defined in other blocks are only available to that block." + ) } - err <- self$arg_list$err - - # name - name <- if (type == "Analytical") { - model_template$name + } # end parameter checks for Analytical model + + + # if Analytical, need to combine sec and eqn + if (type == "Analytical") { + # shell function + sec_eqn <- function() {} + # define the body of the shell function + body(sec_eqn) <- suppressWarnings(as.call(c( + quote(`{`), + as.list(body(self$arg_list$eqn))[-1], # remove outer `{` of f1 + as.list(body(self$arg_list$sec))[-1] # remove outer `{` of f2 + ))) + + # this will include template and equations in both sec and eqn + } + + # sec + # still needed for analytic, because these equations will be used + # in other blocks + + if (!is.null(self$arg_list$sec)) { + sec <- transpile_sec(self$arg_list$sec) + } else { + sec <- "" + } + + # eqn + if (type == "ODE") { + eqn <- transpile_ode_eqn(self$arg_list$eqn, parameters, covariates, sec) + } else if (type == "Analytical") { + eqn <- transpile_analytic_eqn(sec_eqn, parameters, covariates) + } + + # fa + if (!is.null(self$arg_list$fa)) { + fa <- transpile_fa(self$arg_list$fa, parameters, covariates, sec) + } else { + fa <- empty_fa() + } + + # lag + if (!is.null(self$arg_list$lag)) { + lag <- transpile_lag(self$arg_list$lag, parameters, covariates, sec) + } else { + lag <- empty_lag() + } + + # ini + if (!is.null(self$arg_list$ini)) { + ini <- transpile_ini(self$arg_list$ini, parameters, covariates, sec) + } else { + ini <- empty_ini() + } + + # out + if (!is.null(self$arg_list$out)) { + out <- transpile_out(self$arg_list$out, parameters, covariates, sec) + } else { + out <- empty_out() + } + + # err + if (is.null(self$arg_list$err)) { + msg <- c(msg, "Error model is missing and required.") + } + + # ensure length err matches length outeqs + if (length(self$arg_list$err) != n_out) { + msg <- c(msg, "There must be one error model for each output equation.") + } + err <- self$arg_list$err + + # name + name <- if (type == "Analytical") { + model_template$name + } else { + "user" + } + + # build the model list of rust components + model_list <- list( + pri = self$arg_list$pri, + eqn = eqn, + sec = sec, + lag = lag, + fa = fa, + ini = ini, + out = out, + n_eqn = n_eqn, + n_out = n_out, + parameters = parameters, + covariates = covariates, + err = err, + name = name + ) + # make everything lower case if a character vector + self$model_list <- purrr::map(model_list, \(x) { + if (is.character(x)) { + tolower(x) } else { - "user" - } - - # build the model list of rust components - model_list <- list( - pri = self$arg_list$pri, - eqn = eqn, - sec = sec, - lag = lag, - fa = fa, - ini = ini, - out = out, - n_eqn = n_eqn, - n_out = n_out, - parameters = parameters, - covariates = covariates, - err = err, - name = name - ) - # make everything lower case if a character vector - self$model_list <- purrr::map(model_list, \(x) { - if (is.character(x)) { - tolower(x) - } else { - x - } - }) - - # this one needs to be capital - self$model_list$type <- type - - - # Abort if errors - if (length(msg) > 0) { - cli::cli_alert_danger("{.strong PM_model$new() aborted due to {length(msg)} error{?s}:}") - purrr::walk(msg, \(m) cli::cli_bullets(c("*" = m))) - return(invisible(NULL)) + x } - - extra_args <- list(...) - if (!is.null(purrr::pluck(extra_args, "compile"))) { - if (extra_args$compile) { - self$compile() - } - } else { # default is to compile + }) + + # this one needs to be capital + self$model_list$type <- type + + + # Abort if errors + if (length(msg) > 0) { + cli::cli_alert_danger("{.strong PM_model$new() aborted due to {length(msg)} error{?s}:}") + purrr::walk(msg, \(m) cli::cli_bullets(c("*" = m))) + return(invisible(NULL)) + } + + extra_args <- list(...) + if (!is.null(purrr::pluck(extra_args, "compile"))) { + if (extra_args$compile) { self$compile() } - }, - - #' @description - #' Print the model summary. - #' @details - #' This method prints a summary of the model. - #' @param ... Not used. - print = function(...) { - cli::cli_div(theme = list( - span.eqs = list(color = navy()) - )) - - cli::cli_h1("Model summary") - - cli::cli_h3(text = "Primary Parameters") - # pars = self$model_list$parameters - # cli::cli_text("{.eqs {pars}}") - - self$arg_list$pri %>% + } else { # default is to compile + self$compile() + } + }, + + #' @description + #' Print the model summary. + #' @details + #' This method prints a summary of the model. + #' @param ... Not used. + print = function(...) { + cli::cli_div(theme = list( + span.eqs = list(color = navy()) + )) + + cli::cli_h1("Model summary") + + cli::cli_h3(text = "Primary Parameters") + # pars = self$model_list$parameters + # cli::cli_text("{.eqs {pars}}") + + self$arg_list$pri %>% purrr::imap(\(x, y) cli::cli_text("{.strong {y}}: [{.strong {x$min}}, {.strong {x$max}}], {.emph ~N({round(x$mean,2)}}, {.emph {round(x$sd,2)})}")) %>% invisible() # to suppress NULL - - - if (!is.null(self$model_list$covariates)) { - cli::cli_h3(text = "Covariates") - - cov_list <- paste0( - self$model_list$covariates, - ifelse(self$arg_list$cov == 1, "", " (no interpolation)") - ) - - cli::cli_text("{.eqs {cov_list}}") - } - - if (!is.null(self$arg_list$sec)) { - cli::cli_h3(text = "Secondary (Global) Equations") - eqs <- func_to_char(self$arg_list$sec) # function in PMutitlities - for (i in eqs) { - cli::cli_text("{.eqs {i}}") - } - } - - if (!is.null(self$arg_list$tem)) { - cli::cli_h3(text = "Analytical Model") - cli::cli_text("{.eqs {self$arg_list$tem$name}})") - } - - if (!is.null(self$arg_list$eqn)) { - cli::cli_h3(text = "Primary Equations") - eqs <- func_to_char(self$arg_list$eqn) # function in PMutitlities - for (i in eqs) { - cli::cli_text("{.eqs {i}}") - } + + + if (!is.null(self$model_list$covariates)) { + cli::cli_h3(text = "Covariates") + + cov_list <- paste0( + self$model_list$covariates, + ifelse(self$arg_list$cov == 1, "", " (no interpolation)") + ) + + cli::cli_text("{.eqs {cov_list}}") + } + + if (!is.null(self$arg_list$sec)) { + cli::cli_h3(text = "Secondary (Global) Equations") + eqs <- func_to_char(self$arg_list$sec) # function in PMutitlities + for (i in eqs) { + cli::cli_text("{.eqs {i}}") } - - if (!is.null(self$arg_list$lag)) { - cli::cli_h3(text = "Lag Time") - eqs <- func_to_char(self$arg_list$lag) # function in PMutitlities - for (i in eqs) { - cli::cli_text("{.eqs {i}}") - } + } + + if (!is.null(self$arg_list$tem)) { + cli::cli_h3(text = "Analytical Model") + cli::cli_text("{.eqs {self$arg_list$tem$name}})") + } + + if (!is.null(self$arg_list$eqn)) { + cli::cli_h3(text = "Primary Equations") + eqs <- func_to_char(self$arg_list$eqn) # function in PMutitlities + for (i in eqs) { + cli::cli_text("{.eqs {i}}") } - - if (!is.null(self$arg_list$fa)) { - cli::cli_h3(text = "Bioavailability (Fraction Absorbed)") - eqs <- func_to_char(self$arg_list$fa) # function in PMutitlities - for (i in eqs) { - cli::cli_text("{.eqs {i}}") - } + } + + if (!is.null(self$arg_list$lag)) { + cli::cli_h3(text = "Lag Time") + eqs <- func_to_char(self$arg_list$lag) # function in PMutitlities + for (i in eqs) { + cli::cli_text("{.eqs {i}}") } - - if (!is.null(self$arg_list$ini)) { - cli::cli_h3(text = "Initial Conditions") - eqs <- func_to_char(self$arg_list$ini) # function in PMutitlities - for (i in eqs) { - cli::cli_text("{.eqs {i}}") - } + } + + if (!is.null(self$arg_list$fa)) { + cli::cli_h3(text = "Bioavailability (Fraction Absorbed)") + eqs <- func_to_char(self$arg_list$fa) # function in PMutitlities + for (i in eqs) { + cli::cli_text("{.eqs {i}}") } - - cli::cli_h3(text = "Outputs") - outs <- func_to_char(self$arg_list$out) - for (i in outs) { + } + + if (!is.null(self$arg_list$ini)) { + cli::cli_h3(text = "Initial Conditions") + eqs <- func_to_char(self$arg_list$ini) # function in PMutitlities + for (i in eqs) { cli::cli_text("{.eqs {i}}") } - - cli::cli_h3(text = "Error Model") - for (i in self$model_list$err) { - if (i$fixed) { - cli::cli_text("{.strong {tools::toTitleCase(i$type)}}, with fixed value of {.val {i$initial}} and coefficients {.val {i$coeff}}.") - } else { - cli::cli_text("{.strong {tools::toTitleCase(i$type)}}, with initial value of {.val {i$initial}} and coefficients {.val {i$coeff}}.") - } + } + + cli::cli_h3(text = "Outputs") + outs <- func_to_char(self$arg_list$out) + for (i in outs) { + cli::cli_text("{.eqs {i}}") + } + + cli::cli_h3(text = "Error Model") + for (i in self$model_list$err) { + if (i$fixed) { + cli::cli_text("{.strong {tools::toTitleCase(i$type)}}, with fixed value of {.val {i$initial}} and coefficients {.val {i$coeff}}.") + } else { + cli::cli_text("{.strong {tools::toTitleCase(i$type)}}, with initial value of {.val {i$initial}} and coefficients {.val {i$coeff}}.") } - cli::cli_end() - - invisible(self) - }, - #' @description - #' Plot the model. - #' @details - #' This method plots the model using the - #' [plot.PM_model()] function. - #' @param ... Additional arguments passed to the plot function. - plot = function(...) { - tryCatch( - plot.PM_model(self, ...), + } + cli::cli_end() + + invisible(self) + }, + #' @description + #' Plot the model. + #' @details + #' This method plots the model using the + #' [plot.PM_model()] function. + #' @param ... Additional arguments passed to the plot function. + plot = function(...) { + tryCatch( + plot.PM_model(self, ...), + error = function(e) { + cat(crayon::red("Error:"), e$message, "\n") + } + ) + }, + #' @description + #' This is the main method to run a population analysis. + #' @details + #' As of Pmetrics 3.0.0, models contain compiled code to fit + #' the model equations to the data, optimizing the parameter + #' value probability distributions in the population to + #' maximize their likelihood, or more precisely, minimize + #' the objective function, which is -2*log-likelihood. + #' + #' The `$fit()` method is the means of running that compiled + #' code to conduct to fitting procedure. At a minimum, it requires + #' a [PM_data] object, which can be created with + #' `PM_data$new()`. There are a number of additional arguments + #' to control the fitting procedure, such as the number of cycles + #' to run, the initial number of support points, + #' and the algorithm to use, among others. + #' + #' The `$fit()` method is the descendant of the legacy + #' [NPrun] function, which is maintained as a wrapper to `$fit()` + #' for backwards compatibility. + #' + #' @param data Either the name of a [PM_data] + #' object in memory or the quoted filename (with or without a path) of a Pmetrics + #' data file. If the path is not specified, the file is assumed to be in the current working directory, + #' unless the `path` argument below is also specified as a global option for the fit. + #' The file will be used to create a [PM_data] + #' object on the fly. However, if created on the fly, this object + #' will not be available to other + #' methods or other instances of `$fit()`. + #' @param path Optional full path or relative path from current working directory + #' to the folder where `data` and `model` are located if specified as filenames without + #' their own paths, + #' and where the output will be saved. Default is the current working directory. + #' @param run Specify the run number of the output folder. Default if missing is the next available number. + #' @param include Vector of subject id values in the data file to include in the analysis. + #' The default (missing) is all. + #' @param exclude A vector of subject IDs to exclude in the analysis, e.g. `c(4,6:14,16:20)` + # #' @param ode Ordinary Differential Equation solver log tolerance or stiffness. + # Default is -4, i.e. 0.0001. Higher values will result in faster + # #' runs, but parameter estimates may not be as accurate. + # #' @param tol Tolerance for convergence of NPAG. Smaller numbers make it harder to converge. + # #' Default value is 0.01. + # #' @param salt Vector of salt fractions for each drug in the data file, default is 1 for each drug. This is not the same as bioavailability. + #' @param cycles Number of cycles to run. Default is 100. + #' @param prior The distribution for the initial support points, which can be + #' one of several options. + #' * The default is "sobol", which is a semi-random distribution. This is the distribution + #' typically used when fitting a new model to the data. An example of this is + #' on our [website](https://www.lapk.org/images/sobol_3d_plot.html). + #' + #' The following all specify non-random, informative prior distributions. They + #' are useful for either continuing a previous + #' run which did not converge or for fitting a model to new data, whether to simply + #' calculate Bayesian posteriors with `cycles = 0` or to revise the model to a new + #' covergence with the new data. + #' * The name of a suitable [PM_result] object from a prior run loaded with [PM_load]. + #' This starts from the non-uniform, informative distribution obtained at the end of a prior NPAG run. + #' Example: `run1 <- PM_load(1); fit1$run(prior = run1)`. + #' + #' * A character string with the filename of a csv file containing a prior distribution with + #' format as for 'theta.csv' in the output folder of a prior run: column headers are parameter + #' names, and rows are the support point values. A final column with probabilities + #' for each support point is not necessary, but if present will be ignored, as these + #' probabilities are calculated by the engine. Note that the parameter names must match the + #' names of the primary variables in the model. Example: `fit1$run(prior = "mytheta.csv")`. + #' * The number of a previous run with `theta.csv` in the output folder which will be read + #' as for the filename option above. Example: `fit1$run(prior = 2)`. + #' * A data frame obtained from reading an approriate file, such that the data frame + #' is in the required format described in the filename option above. Example: + #' `mytheta <- read_csv("mytheta.csv"); fit1$run(prior = mytheta)`. + #' + #' @param points The number of initial support points if one of + #' the semi-random, uniform distributions are selected in the `prior` argument + #' above. Default is 100. The initial points are + #' spread through the hyperspace defined by the random parameter ranges + #' and begin the search for the optimal + #' parameter value distribution (support points) in the population. + #' If there are fewer than 2 points per unit range for any parameter, + #' Pmetrics will suggest the minimum number of points that should be tried. + #' The greater the initial number of points, the less chance of + #' missing the globally maximally likely parameter value distribution, + #' but the slower the run. + #' + #' @param idelta How often to generate posterior predictions in units of time. + #' Default is 0.1, which means a prediction is generated every 0.1 hours (6 minutes) + #' if the unit of time is hours. Predictions are made at this interval until the time + #' of the last event (dose or observation) or until `tad` if that value is greater + #' than the time of the last dose or observation in the data. + #' + #' @param tad Length of time after the last dose event to add additional predictions + #' at frequency `idelta`. Default is 0, which means no additional predictions + #' beyond the last dose, assuming the dose is the last event. . If the + #' last observation in the data is after `tad`, then a prediction will be generated at + #' time = `tad` after the last dose + #' + #' @param seed Seed used if `prior = "sobol"`. Ignored otherwise. + #' @param intern Run NPAG in the R console without a batch script. Default is TRUE. + # #' @param quiet Boolean operator controlling whether a model summary report is given. Default is `TRUE`. + #' @param overwrite Boolean operator to overwrite existing run result folders. Default is `FALSE`. + # #' @param nocheck Suppress the automatic checking of the data file with [PM_data]. Default is `FALSE`. + # #' @param parallel Run NPAG in parallel. Default is `NA`, which will be set to `TRUE` for models that use + # #' differential equations, and `FALSE` for analytical/explicit models. The majority of the benefit for parallelization comes + # #' in the first cycle, with a speed-up of approximately 80\% of the number of available cores on your machine, e.g. an 8-core machine + # #' will speed up the first cycle by 0.8 * 8 = 6.4-fold. Subsequent cycles approach about 50\%, e.g. 4-fold increase on an 8-core + # #' machine. Overall speed up for a run will therefore depend on the number of cycles run and the number of cores. + #' @param algorithm The algorithm to use for the run. Default is "NPAG" for the **N**on-**P**arametric **A**daptive **G**rid. Alternatives: "NPOD". + #' @param remote Optional logical flag to override the backend defined via [setPMoptions]. + #' When `TRUE`, the fit runs via Hermes remote execution; when `FALSE`, the local Rust backend + #' is forced. If `NULL` (default) the backend follows the current option setting. + #' @param remote_config Optional list of Hermes profile overrides passed to [pm_remote_profile_config]. + #' Use this to provide run-specific queue or credential settings without changing global options. + #' Ignored unless `remote = TRUE` (either explicitly or via [setPMoptions]). + #' @param report If missing, the default Pmetrics report template as specified in [getPMoptions] + #' is used. Otherwise can be "plotly", "ggplot", or "none". + #' @return A successful run will result in creation of a new folder in the working + #' directory with the results inside the folder. + #' + #' @author Michael Neely + #' @export + fit = function(data = NULL, + path = ".", + run = NULL, + include = NULL, + exclude = NULL, + cycles = 100, + prior = "sobol", + points = 100, + idelta = 0.1, + tad = 0, + seed = 23, + overwrite = FALSE, + algorithm = "NPAG", # POSTPROB for posteriors, select when cycles = 0, allow for "NPOD" + remote = NULL, + remote_config = NULL, + report = getPMoptions("report_template")) { + msg <- character() # status message at end of run + run_error <- 0 + + path <- stringr::str_replace(path, "/$", "") # remove trailing / + + if (is.null(data)) { + msg <- c(msg, " {.arg data} must be specified.") + run_error <- run_error + 1 + } + + if (is.null(self$model_list)) { + msg <- c(msg, "Model is malformed.") + run_error <- run_error + 1 + } + + if (is.character(data)) { + # create PM_data object from file + data <- PM_data$new(normalizePath(file.path(path, data), mustWork = FALSE)) + } + + if (!inherits(data, "PM_data")) { + data <- tryCatch( + { + PM_data$new(data) + }, error = function(e) { - cat(crayon::red("Error:"), e$message, "\n") + -1 } ) - }, - #' @description - #' This is the main method to run a population analysis. - #' @details - #' As of Pmetrics 3.0.0, models contain compiled code to fit - #' the model equations to the data, optimizing the parameter - #' value probability distributions in the population to - #' maximize their likelihood, or more precisely, minimize - #' the objective function, which is -2*log-likelihood. - #' - #' The `$fit()` method is the means of running that compiled - #' code to conduct to fitting procedure. At a minimum, it requires - #' a [PM_data] object, which can be created with - #' `PM_data$new()`. There are a number of additional arguments - #' to control the fitting procedure, such as the number of cycles - #' to run, the initial number of support points, - #' and the algorithm to use, among others. - #' - #' The `$fit()` method is the descendant of the legacy - #' [NPrun] function, which is maintained as a wrapper to `$fit()` - #' for backwards compatibility. - #' - #' @param data Either the name of a [PM_data] - #' object in memory or the quoted filename (with or without a path) of a Pmetrics - #' data file. If the path is not specified, the file is assumed to be in the current working directory, - #' unless the `path` argument below is also specified as a global option for the fit. - #' The file will be used to create a [PM_data] - #' object on the fly. However, if created on the fly, this object - #' will not be available to other - #' methods or other instances of `$fit()`. - #' @param path Optional full path or relative path from current working directory - #' to the folder where `data` and `model` are located if specified as filenames without - #' their own paths, - #' and where the output will be saved. Default is the current working directory. - #' @param run Specify the run number of the output folder. Default if missing is the next available number. - #' @param include Vector of subject id values in the data file to include in the analysis. - #' The default (missing) is all. - #' @param exclude A vector of subject IDs to exclude in the analysis, e.g. `c(4,6:14,16:20)` - # #' @param ode Ordinary Differential Equation solver log tolerance or stiffness. - # Default is -4, i.e. 0.0001. Higher values will result in faster - # #' runs, but parameter estimates may not be as accurate. - # #' @param tol Tolerance for convergence of NPAG. Smaller numbers make it harder to converge. - # #' Default value is 0.01. - # #' @param salt Vector of salt fractions for each drug in the data file, default is 1 for each drug. This is not the same as bioavailability. - #' @param cycles Number of cycles to run. Default is 100. - #' @param prior The distribution for the initial support points, which can be - #' one of several options. - #' * The default is "sobol", which is a semi-random distribution. This is the distribution - #' typically used when fitting a new model to the data. An example of this is - #' on our [website](https://www.lapk.org/images/sobol_3d_plot.html). - #' - #' The following all specify non-random, informative prior distributions. They - #' are useful for either continuing a previous - #' run which did not converge or for fitting a model to new data, whether to simply - #' calculate Bayesian posteriors with `cycles = 0` or to revise the model to a new - #' covergence with the new data. - #' * The name of a suitable [PM_result] object from a prior run loaded with [PM_load]. - #' This starts from the non-uniform, informative distribution obtained at the end of a prior NPAG run. - #' Example: `run1 <- PM_load(1); fit1$run(prior = run1)`. - #' - #' * A character string with the filename of a csv file containing a prior distribution with - #' format as for 'theta.csv' in the output folder of a prior run: column headers are parameter - #' names, and rows are the support point values. A final column with probabilities - #' for each support point is not necessary, but if present will be ignored, as these - #' probabilities are calculated by the engine. Note that the parameter names must match the - #' names of the primary variables in the model. Example: `fit1$run(prior = "mytheta.csv")`. - #' * The number of a previous run with `theta.csv` in the output folder which will be read - #' as for the filename option above. Example: `fit1$run(prior = 2)`. - #' * A data frame obtained from reading an approriate file, such that the data frame - #' is in the required format described in the filename option above. Example: - #' `mytheta <- read_csv("mytheta.csv"); fit1$run(prior = mytheta)`. - #' - #' @param points The number of initial support points if one of - #' the semi-random, uniform distributions are selected in the `prior` argument - #' above. Default is 100. The initial points are - #' spread through the hyperspace defined by the random parameter ranges - #' and begin the search for the optimal - #' parameter value distribution (support points) in the population. - #' If there are fewer than 2 points per unit range for any parameter, - #' Pmetrics will suggest the minimum number of points that should be tried. - #' The greater the initial number of points, the less chance of - #' missing the globally maximally likely parameter value distribution, - #' but the slower the run. - #' - #' @param idelta How often to generate posterior predictions in units of time. - #' Default is 0.1, which means a prediction is generated every 0.1 hours (6 minutes) - #' if the unit of time is hours. Predictions are made at this interval until the time - #' of the last event (dose or observation) or until `tad` if that value is greater - #' than the time of the last dose or observation in the data. - #' - #' @param tad Length of time after the last dose event to add additional predictions - #' at frequency `idelta`. Default is 0, which means no additional predictions - #' beyond the last dose, assuming the dose is the last event. . If the - #' last observation in the data is after `tad`, then a prediction will be generated at - #' time = `tad` after the last dose - #' - #' @param seed Seed used if `prior = "sobol"`. Ignored otherwise. - #' @param intern Run NPAG in the R console without a batch script. Default is TRUE. - # #' @param quiet Boolean operator controlling whether a model summary report is given. Default is `TRUE`. - #' @param overwrite Boolean operator to overwrite existing run result folders. Default is `FALSE`. - # #' @param nocheck Suppress the automatic checking of the data file with [PM_data]. Default is `FALSE`. - # #' @param parallel Run NPAG in parallel. Default is `NA`, which will be set to `TRUE` for models that use - # #' differential equations, and `FALSE` for analytical/explicit models. The majority of the benefit for parallelization comes - # #' in the first cycle, with a speed-up of approximately 80\% of the number of available cores on your machine, e.g. an 8-core machine - # #' will speed up the first cycle by 0.8 * 8 = 6.4-fold. Subsequent cycles approach about 50\%, e.g. 4-fold increase on an 8-core - # #' machine. Overall speed up for a run will therefore depend on the number of cycles run and the number of cores. - #' @param algorithm The algorithm to use for the run. Default is "NPAG" for the **N**on-**P**arametric **A**daptive **G**rid. Alternatives: "NPOD". - #' @param report If missing, the default Pmetrics report template as specified in [getPMoptions] - #' is used. Otherwise can be "plotly", "ggplot", or "none". - #' @return A successful run will result in creation of a new folder in the working - #' directory with the results inside the folder. - #' - #' @author Michael Neely - #' @export - fit = function(data = NULL, - path = ".", - run = NULL, - include = NULL, - exclude = NULL, - cycles = 100, - prior = "sobol", - points = 100, - idelta = 0.1, - tad = 0, - seed = 23, - overwrite = FALSE, - algorithm = "NPAG", # POSTPROB for posteriors, select when cycles = 0, allow for "NPOD" - report = getPMoptions("report_template")) { - msg <- NULL # status message at end of run - run_error <- 0 - - path <- stringr::str_replace(path, "/$", "") # remove trailing / - - if (is.null(data)) { - msg <- c(msg, " {.arg data} must be specified.") - run_error <- run_error + 1 - } - - if (is.null(self$model_list)) { - msg <- c(msg, "Model is malformed.") + + if (!inherits(data, "PM_data")) { + msg <- c(msg, "{.arg data} must be a {.cls PM_data} object or an appropriate data frame.") + run_error <- run_error + 1 + } + } + + #### checks + + # bolus and infusions + if (self$model_list$type == "ODE") { # only need to check these for ODE models + bolus <- unique(data$standard_data$input[data$standard_data$dur == 0]) %>% purrr::discard(~ is.na(.x)) + infusion <- unique(data$standard_data$input[data$standard_data$dur > 0]) %>% purrr::discard(~ is.na(.x)) + if (length(bolus) > 0) { + missing_bolus <- bolus[!stringr::str_detect(self$model_list$eqn, paste0("b\\[", bolus - 1))] + if (length(missing_bolus) > 0) { + msg <- c(msg, "Bolus input(s) {paste(missing_bolus, collapse = ', ')} {?is/are} missing from the model equations. Use {.code b[{missing_bolus}]} or {.code bolus[{missing_bolus}]}, for example, to represent bolus inputs in the equations.") run_error <- run_error + 1 } - - if (is.character(data)) { - # create PM_data object from file - data <- PM_data$new(normalizePath(file.path(path, data), mustWork = FALSE)) - } - - if (!inherits(data, "PM_data")) { - data <- tryCatch( - { - PM_data$new(data) - }, - error = function(e) { - -1 - } - ) - - if (!inherits(data, "PM_data")) { - msg <- c(msg, "{.arg data} must be a {.cls PM_data} object or an appropriate data frame.") - run_error <- run_error + 1 - } - } - - #### checks - - # bolus and infusions - if (self$model_list$type == "ODE") { # only need to check these for ODE models - bolus <- unique(data$standard_data$input[data$standard_data$dur == 0]) %>% purrr::discard(~ is.na(.x)) - infusion <- unique(data$standard_data$input[data$standard_data$dur > 0]) %>% purrr::discard(~ is.na(.x)) - if (length(bolus) > 0) { - missing_bolus <- bolus[!stringr::str_detect(self$model_list$eqn, paste0("b\\[", bolus - 1))] - if (length(missing_bolus) > 0) { - msg <- c(msg, "Bolus input(s) {paste(missing_bolus, collapse = ', ')} {?is/are} missing from the model equations. Use {.code b[{missing_bolus}]} or {.code bolus[{missing_bolus}]}, for example, to represent bolus inputs in the equations.") - run_error <- run_error + 1 - } - } - if (length(infusion) > 0) { - missing_infusion <- infusion[!stringr::str_detect(self$model_list$eqn, paste0("rateiv\\[", infusion - 1))] - if (length(missing_infusion) > 0) { - msg <- c(msg, "Infusion input(s) {paste(missing_infusion, collapse = ', ')} {?is/are} missing from the model equations. Use {.code r[{missing_infusion}]} or {.code rateiv[{missing_infusion}]} , for example, to represent infusion inputs in the equations.") - run_error <- run_error + 1 - } - } - } - - # covariates - modelCov <- self$model_list$cov - if (length(modelCov) > 0) { - dataCov <- tolower(getCov(data)$covnames) - missingCov <- modelCov[!modelCov %in% dataCov] - if (length(missingCov) > 0) { # if not identical, abort - msg <- c(msg, "{.arg {modelCov}} {?is/are} missing from the data.") - run_error <- run_error + 1 - } - } - - # cycles - # if programmer is a crazy Norwegian.... - if (cycles < 0) { - msg <- c(msg, "Error: {.arg cycles} must be 0 or greater.") + } + if (length(infusion) > 0) { + missing_infusion <- infusion[!stringr::str_detect(self$model_list$eqn, paste0("rateiv\\[", infusion - 1))] + if (length(missing_infusion) > 0) { + msg <- c(msg, "Infusion input(s) {paste(missing_infusion, collapse = ', ')} {?is/are} missing from the model equations. Use {.code r[{missing_infusion}]} or {.code rateiv[{missing_infusion}]} , for example, to represent infusion inputs in the equations.") run_error <- run_error + 1 } - - # output equations - if (!is.null(data$standard_data$outeq)) { - dataOut <- max(data$standard_data$outeq, na.rm = TRUE) - } else { - dataOut <- 1 - } - modelOut <- self$model_list$n_out - - - #### Algorithm #### - algorithm <- toupper(algorithm) - if (cycles == 0) { - if (prior == "sobol") { - msg <- c(msg, "Cannot use {.code prior = 'sobol'} with {.code cycles = 0}.") - run_error <- run_error + 1 - } - algorithm <- "POSTPROB" - } else { - if (!(algorithm %in% c("NPAG", "NPOD"))) { - msg <- c(msg, "Unsupported algorithm. Supported algorithms are 'NPAG' and 'NPOD'.") - run_error <- run_error + 1 - } - } - if (algorithm == "POSTPROB" && cycles > 0) { - msg <- c(msg, "Warning: {.code algorithm = 'POSTPROB'} is used with {.code cycles = 0}. {.code cycles} set to 0.") - cycles <- 0 - } - - - - if (getPMoptions()$backend != "rust") { - cli::cli_abort(c("x" = "Error: unsupported backend.", "i" = "See help for {.fn setPMoptions}")) - } - - #### Include or exclude subjects #### - if (is.null(include)) { - include <- unique(data$standard_data$id) - } - if (is.null(exclude)) { - exclude <- NA - } - data_filtered <- data$standard_data %>% includeExclude(include, exclude) - - if (nrow(data_filtered) == 0) { - msg <- c(msg, "No subjects remained after filtering.") + } + } + + # covariates + modelCov <- self$model_list$cov + if (length(modelCov) > 0) { + dataCov <- tolower(getCov(data)$covnames) + missingCov <- modelCov[!modelCov %in% dataCov] + if (length(missingCov) > 0) { # if not identical, abort + msg <- c(msg, "{.arg {modelCov}} {?is/are} missing from the data.") + run_error <- run_error + 1 + } + } + + # cycles + # if programmer is a crazy Norwegian.... + if (cycles < 0) { + msg <- c(msg, "Error: {.arg cycles} must be 0 or greater.") + run_error <- run_error + 1 + } + + # output equations + if (!is.null(data$standard_data$outeq)) { + dataOut <- max(data$standard_data$outeq, na.rm = TRUE) + } else { + dataOut <- 1 + } + modelOut <- self$model_list$n_out + + + #### Algorithm #### + algorithm <- toupper(algorithm) + if (cycles == 0) { + if (prior == "sobol") { + msg <- c(msg, "Cannot use {.code prior = 'sobol'} with {.code cycles = 0}.") + run_error <- run_error + 1 + } + algorithm <- "POSTPROB" + } else { + if (!(algorithm %in% c("NPAG", "NPOD"))) { + msg <- c(msg, "Unsupported algorithm. Supported algorithms are 'NPAG' and 'NPOD'.") + run_error <- run_error + 1 + } + } + if (algorithm == "POSTPROB" && cycles > 0) { + msg <- c(msg, "Warning: {.code algorithm = 'POSTPROB'} is used with {.code cycles = 0}. {.code cycles} set to 0.") + cycles <- 0 + } + + if (!is.null(remote)) { + if (!is.logical(remote) || length(remote) != 1 || is.na(remote)) { + cli::cli_abort(c( + "x" = "{.arg remote} must be a single logical value.", + "i" = "Use {.code TRUE}, {.code FALSE}, or omit the argument." + )) + } + } + + backend_opts <- getPMoptions() + if (!is.list(backend_opts)) { + backend_opts <- list() + } + backend <- if (!is.null(remote)) { + if (isTRUE(remote)) "remote" else "rust" + } else if (!is.null(backend_opts$backend) && nzchar(backend_opts$backend)) { + tolower(backend_opts$backend) + } else { + "rust" + } + if (!backend %in% c("rust", "remote")) { + cli::cli_abort(c( + "x" = sprintf("Error: unsupported backend '%s'.", backend), + "i" = "See help for {.fn setPMoptions}" + )) + } + if (!is.null(remote_config) && backend != "remote") { + cli::cli_warn(c( + "!" = "Ignoring {.arg remote_config} because the remote backend is not active.", + "i" = "Set {.arg remote = TRUE} to use the provided configuration." + )) + } + + #### Include or exclude subjects #### + if (is.null(include)) { + include <- unique(data$standard_data$id) + } + if (is.null(exclude)) { + exclude <- NA + } + data_filtered <- data$standard_data %>% includeExclude(include, exclude) + + if (nrow(data_filtered) == 0) { + msg <- c(msg, "No subjects remained after filtering.") + run_error <- run_error + 1 + } + + # set prior + if (prior != "sobol") { + if (is.numeric(prior)) { + # prior specified as a run number + if (!file.exists(glue::glue("{path}/{prior}/outputs/theta.csv"))) { + msg <- c(msg, "{.arg prior} file does not exist.", "i" = "Check the file path.") run_error <- run_error + 1 } - - # set prior - if (prior != "sobol") { - if (is.numeric(prior)) { - # prior specified as a run number - if (!file.exists(glue::glue("{path}/{prior}/outputs/theta.csv"))) { - msg <- c(msg, "{.arg prior} file does not exist.", "i" = "Check the file path.") - run_error <- run_error + 1 - } - file.copy(glue::glue("{path}/{prior}/outputs/theta.csv"), "prior.csv", overwrite = TRUE) - prior <- "prior.csv" - } else if (is.character(prior)) { - # prior specified as a filename - if (!file.exists(prior)) { - msg <- c(msg, "{.arg prior} file does not exist.") - run_error <- run_error + 1 - } - file.copy(prior, "prior.csv", overwrite = TRUE) # ensure in current working directory - } else if (is.data.frame(prior)) { - # prior specified as a data frame - if (!all(c("prob", self$model_list$parameters) %in% names(prior))) { - msg <- c(msg, "{.arg prior} data frame must contain columns for parameters and probabilities.") - run_error <- run_error + 1 - } - prior <- prior %>% dplyr::select(all_of(self$model_list$parameters), prob) - write.csv(prior, "prior.csv", row.names = FALSE) - } else { - msg <- c(msg, "{.arg prior} must be a numeric run number or character filename.") - run_error <- run_error + 1 - } - } else { - prior <- "sobol" - } - - #### Abort if errors before creating new folder #### - if (run_error > 0) { - cli::cli_alert_danger("{.strong PM_model$fit() aborted due to {run_error} error{?s}:}") - purrr::walk(msg, \(m) cli::cli_bullets(c("*" = m))) - return(invisible(NULL)) - } - #### Continue with fit #### - - # check if model compiled and if not, do so - self$compile() - - intern <- TRUE # always true until (if) rust can run separately from R - - - # make new output directory - - if (is.null(run)) { - olddir <- list.dirs(path, recursive = FALSE) - olddir <- olddir[grep("^\\./[[:digit:]]+", olddir)] - olddir <- sub("^\\./", "", olddir) - if (length(olddir) > 0) { - run <- as.character(max(as.numeric(olddir)) + 1) - } else { - run <- "1" - } - } else { - if (!is.numeric(run)) { - msg <- c(msg, "{.arg run} must be numeric, so was ignored.") - } - } - - path_run <- normalizePath(file.path(path, run), mustWork = FALSE) - - if (file.exists(path_run)) { - if (overwrite) { - unlink(path_run, recursive = TRUE) - msg <- c(msg, "The previous run in folder '{path_run}' was overwritten.") - } else { - cli::cli_inform( - c("i" = "The previous run from '{path_run}' was read.", " " = "Set {.arg overwrite} to {.val TRUE} to overwrite prior run in '{path_run}'.") - ) - return(invisible(PM_load(file = normalizePath(file.path(path_run, "PMout.Rdata"), mustWork = FALSE)))) - } - } - - fs::dir_create(path_run) - - #### Save input objects #### - fs::dir_create(normalizePath(file.path(path_run, "inputs"), mustWork = FALSE)) - PM_data$new(data_filtered, quiet = TRUE)$save(normalizePath(file.path(path_run, "inputs", "gendata.csv"), mustWork = FALSE), header = FALSE) - saveRDS(list(data = data, model = self), file = normalizePath(file.path(path_run, "inputs", "fit.rds"), mustWork = FALSE)) - file.copy(self$binary_path, normalizePath(file.path(path_run, "inputs"), mustWork = FALSE)) - - # Get ranges and calculate points - ranges <- lapply(self$model_list$pri, function(x) { - c(x$min, x$max) - }) - - names(ranges) <- tolower(names(ranges)) - # Set initial grid points (only applies for sobol) - marginal_densities <- sapply(ranges, function(x) { - points / (x[2] - x[1]) - }) - if (any(marginal_densities < 2)) { - increase_to <- round(points * (max(2 / marginal_densities)), 0) - msg <- c(msg, "Recommend increasing {.arg points} to at least {increase_to} to ensure adequate coverage of parameter space.") - } - - - if (intern) { - ### CALL RUST - out_path <- normalizePath(file.path(path_run, "outputs"), mustWork = FALSE) - msg <- c(msg, "Run results were saved in folder '{.path {out_path}}'") - rlang::try_fetch( - fit( - # defined in extendr-wrappers.R - model_path = normalizePath(self$binary_path), - data = normalizePath(file.path(path_run, "inputs", "gendata.csv")), - params = list( - ranges = ranges, # not important but needed for POSTPROB - algorithm = algorithm, - error_models = lapply(self$model_list$err, function(x) x$flatten()), - idelta = idelta, - tad = tad, - max_cycles = cycles, # will be hardcoded in Rust to 0 for POSTPROB - prior = prior, # needs warning if missing and algorithm = POSTPROB - points = points, # only relevant for sobol prior - seed = seed - ), - output_path = out_path, - kind = tolower(self$model_list$type) - ), - error = function(e) { - cli::cli_warn("Unable to create {.cls PM_result} object", parent = e) - return(NULL) - } - ) - - PM_parse(path = out_path) - res <- PM_load(path = normalizePath(out_path), file = "PMout.Rdata") - if (report != "none") { - valid_report <- tryCatch( - PM_report(res, path = normalizePath(out_path), template = report, quiet = TRUE), - error = function(e) { - -1 - } - ) - if (valid_report == 1) { - msg <- c(msg, "Report generated with {report} template.") - # if(tolower(algorithm) == "postprob") {this_alg <- "map"} else {this_alg <- "fit"} - msg <- c(msg, "If assigned to a variable, e.g. {.code run{run} <-}, results are available in {.code run{run}}.") - } else { - msg <- c(msg, "Report could not be generated.") - } - } - - - if (length(msg) > 1) { - cli::cli_h1("Notes:") - cli::cli_ul() - purrr::walk(msg[-1], ~ cli::cli_li(.x)) - cli::cli_end() - } - return(invisible(res)) - } else { - cli::cli_abort( - c("x" = "Error: Currently, the rust engine only supports internal runs.", "i" = "This is a temporary limitation.") - ) - } - }, # end fit method - - #' @description - #' Calculate posteriors from a fitted model. - #' #' @details - #' This method calculates posteriors from a compiled model. It is not necessary to have - #' run the model first, but it is necessary to have an informative prior distribution. - #' This prior will typically be the result of a previous run, but may also be a file - #' containing support points, with each column named as a parameter in the model plus a final column - #' for probability. Each row contains values for the parameters and the associated probability for - #' those parameter values. The file can be saved as a csv file. - #' - #' To calculate the posteriors, `map()` calls the `fit()` method with the `cycles` argument set to 0 - #' and the `algorithm` argument set to "POSTPROB". If `data` are not provided as an argument to - #' `map()`, the model's `data` field is used instead. If `data` is provided, it must be a - #' [PM_data] object or the pathname of a file which can be loaded as a [PM_data] object. - #' @param ... Arguments passed to the `fit` method. Note that the `cycles` argument is set to 0, - #' and the `algorithm` argument is set to "POSTPROB" automatically. - map = function(...) { - # browser() - args <- list(...) - - if (!is.null(purrr::pluck(args, "cycles")) && purrr::pluck(args, "cycles") != 0) { - cli::cli_inform(c("i" = "{.arg cycles} set to 0 for posteriors")) - } - args$cycles <- 0 # ensure cycles is set to 0 - - - if (!is.null(purrr::pluck(args, "algorithm")) && purrr::pluck(args, "algorithm") != "POSTPROB") { - cli::cli_inform(c("i" = "{.arg algorithm} set to POSTPROB for posteriors")) - } - args$algorithm <- "POSTPROB" # ensure algorithm is set to POSTPROB - - - if (is.null(purrr::pluck(args, "data"))) { - cli::cli_abort(c("x" = "Data must be specified for posteriors.")) - } - - if (is.null(purrr::pluck(args, "prior")) || purrr::pluck(args, "prior") == "sobol") { - cli::cli_abort(c( - "x" = "Please specify a non-uniform prior for posteriors.", - " " = "This can be a prior run number or the name of a file with support points." - )) - } - - do.call(self$fit, args) - }, - #' @description - #' Simulate data from the model using a set of parameter values. - #' @details - #' This method simulates output from the model using a set of parameter values - #' provided in the `theta` matrix and the template for dosing/observations in - #' the `data` object. - #' @param data A [PM_data] object containing the dosing and observation information. - #' @param theta A matrix of parameter values to use for the simulation. - #' The `theta` matrix should have the same number of columns as the number of primary parameters in the model. - #' Each row of `theta` represents a different set of parameter values. - #' - sim = function(data, theta) { - if (!inherits(data, "PM_data")) { - cli::cli_abort(c("x" = "Data must be a PM_data object.")) - } - if (!is.matrix(theta)) { - cli::cli_abort(c("x" = "theta must be a matrix.")) - } - if (!is.numeric(theta)) { - cli::cli_abort(c("x" = "theta must be a matrix of numeric values.")) - } - if (ncol(theta) != length(private$get_primary())) { - cli::cli_abort(c("x" = "theta must have the same number of columns as the number of parameters.")) - } - - - temp_csv <- tempfile(fileext = ".csv") - data$save(temp_csv, header = FALSE) - if (getPMoptions()$backend == "rust") { - if (is.null(self$binary_path)) { - self$compile() - if (is.null(self$binary_path)) { - cli::cli_abort(c("x" = "Model must be compiled before simulating.")) - } - } - sim <- simulate_all(temp_csv, self$binary_path, theta, kind = tolower(self$model_list$type)) - } else { - cli::cli_abort(c("x" = "This function can only be used with the rust backend.")) + file.copy(glue::glue("{path}/{prior}/outputs/theta.csv"), "prior.csv", overwrite = TRUE) + prior <- "prior.csv" + } else if (is.character(prior)) { + # prior specified as a filename + if (!file.exists(prior)) { + msg <- c(msg, "{.arg prior} file does not exist.") + run_error <- run_error + 1 } - return(sim) - }, - #' @description - #' Compile the model to a binary file. - #' @details - #' This method write the model to a Rust file in a temporary path, - #' updates the `binary_path` field for the model, and compiles that - #' file to a binary file that can be used for fitting or simulation. - #' If the model is already compiled, the method does nothing. - #' - compile = function() { - if (!is.null(self$binary_path) && file.exists(self$binary_path)) { - # model is compiled - return(invisible(NULL)) + file.copy(prior, "prior.csv", overwrite = TRUE) # ensure in current working directory + } else if (is.data.frame(prior)) { + # prior specified as a data frame + if (!all(c("prob", self$model_list$parameters) %in% names(prior))) { + msg <- c(msg, "{.arg prior} data frame must contain columns for parameters and probabilities.") + run_error <- run_error + 1 } - - model_path <- file.path(tempdir(), "model.rs") - private$write_model_to_rust(model_path) - output_path <- tempfile(pattern = "model_", fileext = ".pmx") - cli::cli_inform(c("i" = "Compiling model...")) - # path inside Pmetrics package - template_path <- system.file(package = "Pmetrics") - cat("Using template path:", template_path, "\n") - tryCatch( - { - compile_model(model_path, output_path, private$get_primary(), template_path = template_path, kind = tolower(self$model_list$type)) - self$binary_path <- output_path - }, - error = function(e) { - cli::cli_abort( - c("x" = "Model compilation failed: {e$message}", "i" = "Please check the model file and try again.") - ) - } + prior <- prior %>% dplyr::select(all_of(self$model_list$parameters), prob) + write.csv(prior, "prior.csv", row.names = FALSE) + } else { + msg <- c(msg, "{.arg prior} must be a numeric run number or character filename.") + run_error <- run_error + 1 + } + } else { + prior <- "sobol" + } + if (backend == "remote" && prior != "sobol") { + cli::cli_abort(c( + "x" = "Hermes remote fits currently require {.code prior = 'sobol' }.", + "i" = "Use the rust backend to run with external priors." + )) + } + + #### Abort if errors before creating new folder #### + if (run_error > 0) { + cli::cli_alert_danger("{.strong PM_model$fit() aborted due to {run_error} error{?s}:}") + purrr::walk(msg, \(m) cli::cli_bullets(c("*" = m))) + return(invisible(NULL)) + } + #### Continue with fit #### + + # check if model compiled and if not, do so + if (backend == "rust") { + self$compile() + } + + # make new output directory + if (is.null(run)) { + olddir <- list.dirs(path, recursive = FALSE) + olddir <- olddir[grep("^\\./[[:digit:]]+", olddir)] + olddir <- sub("^\\./", "", olddir) + if (length(olddir) > 0) { + run <- as.character(max(as.numeric(olddir)) + 1) + } else { + run <- "1" + } + } else { + if (!is.numeric(run)) { + msg <- c(msg, "{.arg run} must be numeric, so was ignored.") + } + } + + path_run <- normalizePath(file.path(path, run), mustWork = FALSE) + + if (file.exists(path_run)) { + if (overwrite) { + unlink(path_run, recursive = TRUE) + msg <- c(msg, "The previous run in folder '{path_run}' was overwritten.") + } else { + cli::cli_inform( + c("i" = "The previous run from '{path_run}' was read.", " " = "Set {.arg overwrite} to {.val TRUE} to overwrite prior run in '{path_run}'.") ) - - file.remove(model_path) # remove temporary model file - return(invisible(self)) - }, - #' @description - #' Update the model using recursive lists of changes and recompile the updated model. - #' @param ... Named elements corresponding to the blocks in the model, - #' such as "pri", "cov", "sec", "eqn", "ini", "lag", "fa", "out", and "err". - #' For each block, create a list of changes, which may be additions, edits, or deletions. - #' For deletions, set the value to `NULL`. - #' - update = function(...) { - changes <- list(...) - keys <- names(changes) - if (!all(tolower(keys) %in% c("pri", "cov", "sec", "eqn", "ini", "lag", "fa", "out", "err"))) { - cli::cli_abort(c( - "x" = "Invalid block name: {keys}", - "i" = "See help for {.fn PM_model}." - )) - } - self$arg_list <- modifyList2(self$arg_list, changes) - self <- PM_model$new(self$arg_list) # recreate and recompile the model - return(invisible(self)) + return(invisible(PM_load(file = normalizePath(file.path(path_run, "PMout.Rdata"), mustWork = FALSE)))) } - ), # end public list - private = list( - R6fromFile = function(file) { - msg <- "" - blocks <- parseBlocks(file) # this function is in PMutilities - # check for reserved variable names - conflicts <- reserved_name_conflicts(blocks) - if (length(conflicts) > 0) { - msg <- glue::glue("The following are reserved names and cannot be used as variables in a model: {paste(conflicts, collapse = ', ')}") - return(list(status = -1, msg = msg)) - } - - if (length(grep(";", blocks$primVar)) > 0) { - # using ';' as separator - sep <- ";" - } else { - if (length(grep(",", blocks$primVar)) > 0) { - # using ',' as separator - sep <- "," - } else { - return(list(status = -1, msg = "\nPrimary variables should be defined as 'var,lower_val,upper_val' or 'var,fixed_val'.\n")) - } - } - - # build arg_list - arg_list <- list() - # this function makes pri for PM_model - arg_list$pri <- sapply(strsplit(blocks$primVar, sep), function(x) { - # find out if constrained to be positive - const_pos <- any(grepl("\\+", x)) - if (const_pos) { - x <- gsub("\\+", "", x) - cli::cli_inform(c( - "i" = "Truncating variables to positive ranges is not required for NPAG/NPOD", - " " = "This may be updated as parametric algorithms come online, but will be ignored for now." - )) - } - - # find out if constant - const_var <- any(grepl("!", x)) - if (const_var) { - x <- gsub("!", "", x) - cli::cli_abort(c("x" = "Constants should be defined in the appropriate block, not #PRI.")) - } - - values <- as.numeric(x[-1]) - - if (length(x[-1]) == 1) { # fixed - cli::cli_abort(c( - "x" = "Fixed but unknown are no longer supported.", - "i" = "If necessary, fit them as random and then use a fixed value in subsequent runs." - )) - } else { # range - thisItem <- list(ab(values[1], values[2])) - } - names(thisItem) <- x[1] - thisItem - }) # end sapply - - # covariates - covar <- blocks$covar - const_covar <- grepl("!", covar) # returns boolean vector, length = ncov - covar <- gsub("!", "", covar) # remove "!" - covar_list <- tolower(covar) - - # add to arg_list - arg_list$cov <- purrr::map_vec(const_covar, \(x){ - type <- ifelse(!x, "lm", "none") - interp(type) - }) %>% - purrr::set_names(covar_list) - - - # extra - # if (blocks$extra[1] != "") { - # arg_list$ext <- blocks$extra - # } else { - # arg_list$extra <- NULL - # } - - # secondary variables - if (blocks$secVar[1] != "") { - arg_list$sec <- eval(parse(text = glue::glue("function() {{\n {paste(blocks$secVar, collapse = '\n ')}\n}}"))) - } else { - arg_list$sec <- NULL - } - - # bioavailability - if (blocks$f[1] != "") { - arg_list$fa <- eval(parse(text = glue::glue("function() {{\n {paste(blocks$f, collapse = '\n ')}\n}}"))) - } else { - arg_list$fa <- NULL - } - - # bolus - if (blocks$bol[1] != "") { - cli::cli_inform(c( - "i" = "The bolus block is no longer used as of Pmetrics 3.0.0.", - " " = "Indicate bolus inputs as {.code B[x]} in equations, where {.code x} is the input number." - )) - } - - # initial conditions - if (blocks$ini[1] != "") { - arg_list$ini <- eval(parse(text = glue::glue("function() {{\n {paste(blocks$ini, collapse = '\n ')}\n}}"))) - } else { - arg_list$ini <- NULL - } - - # lag time - if (blocks$lag[1] != "") { - arg_list$lag <- eval(parse(text = glue::glue("function() {{\n {paste(blocks$lag, collapse = '\n ')}\n}}"))) - } else { - arg_list$lag <- NULL - } - - # differential equations - legacy - if (!is.null(blocks$diffeq) && blocks$diffeq[1] != "") { - cli::cli_inform(c( - "i" = "The #DIFFEQ block is no longer used as of Pmetrics 3.0.0.", - " " = "The block is now called #EQN for more general equations.", - " " = "Equations have been moved to the {.code eqn} element." - )) - arg_list$eqn <- eval(parse(text = glue::glue("function() {{\n {paste(blocks$diffeq, collapse = '\n ')}\n}}"))) - } else { - arg_list$eqn <- NULL - } - - # model equations - will eventually replace diffeq above - if (blocks$eqn[1] != "") { - arg_list$eqn <- eval(parse(text = glue::glue("function() {{\n {paste(blocks$eqn, collapse = '\n ')}\n}}"))) - } else { - arg_list$eqn <- NULL - } - - # out/err - n_outputLines <- length(blocks$output) - outputLines <- grep("y\\([[:digit:]]+\\)|y\\[[[:digit:]]+\\]", blocks$output) - if (length(outputLines) == 0) { - return(list(status = -1, msg = "\nYou must have at least one output equation of the form 'Y[1] = ...'\n")) + } + + fs::dir_create(path_run) + + #### Save input objects #### + inputs_dir <- normalizePath(file.path(path_run, "inputs"), mustWork = FALSE) + fs::dir_create(inputs_dir) + data_obj <- PM_data$new(data_filtered, quiet = TRUE) + gendata_path <- normalizePath(file.path(inputs_dir, "gendata.csv"), mustWork = FALSE) + data_obj$save(gendata_path, header = FALSE) + saveRDS(list(data = data, model = self), file = normalizePath(file.path(inputs_dir, "fit.rds"), mustWork = FALSE)) + model_rust <- private$render_model_to_rust() + writeLines(model_rust, file.path(inputs_dir, "model.rs")) + if (backend == "rust" && !is.null(self$binary_path) && file.exists(self$binary_path)) { + file.copy(self$binary_path, inputs_dir) + } + + # Get ranges and calculate points + ranges <- lapply(self$model_list$pri, function(x) { + c(x$min, x$max) + }) + + names(ranges) <- tolower(names(ranges)) + # Set initial grid points (only applies for sobol) + marginal_densities <- sapply(ranges, function(x) { + points / (x[2] - x[1]) + }) + if (any(marginal_densities < 2)) { + increase_to <- round(points * (max(2 / marginal_densities)), 0) + msg <- c(msg, "Recommend increasing {.arg points} to at least {increase_to} to ensure adequate coverage of parameter space.") + } + + + fit_params <- list( + ranges = ranges, + algorithm = algorithm, + error_models = lapply(self$model_list$err, function(x) x$flatten()), + idelta = idelta, + tad = tad, + max_cycles = cycles, + prior = prior, + points = points, + seed = seed + ) + + out_path <- normalizePath(file.path(path_run, "outputs"), mustWork = FALSE) + fs::dir_create(out_path) + + res <- NULL + if (backend == "rust") { + rlang::try_fetch( + fit( + model_path = normalizePath(self$binary_path), + data = gendata_path, + params = fit_params, + output_path = out_path, + kind = tolower(self$model_list$type) + ), + error = function(e) { + cli::cli_warn("Unable to create {.cls PM_result} object", parent = e) + return(invisible(NULL)) } - - - arg_list$out <- eval(parse(text = glue::glue("function() {{\n {paste(blocks$out, collapse = '\n ')}\n}}"))) - - err <- tolower(gsub("[[:space:]]", "", blocks$error)) - # process constant gamma/lambda - err_type <- c("additive", "proportional")[1 + grepl("^g", err[1])] - const_gamlam <- grepl("!", err[1]) - gamlam_value <- as.numeric(stringr::str_match(err[1], "\\d+\\.?\\d*")) - # process constant coefficients - const_coeff <- grepl("!", err[-1]) # returns boolean vector, length = nout - err <- gsub("!", "", err) # remove "!" - - coeff_fxns <- err[-1] %>% - purrr::imap(\(x, idx) { - glue::glue("{err_type}({gamlam_value}, c({x}), {const_coeff[{idx}]})") - }) %>% - unlist() - - arg_list$err <- eval(parse(text = glue::glue("c(\n{paste({coeff_fxns}, collapse = ',\n')}\n)"))) - - cat(msg) - flush.console() - return(arg_list) - }, # end R6fromFile - - write_model_to_rust = function(file_path = "main.rs") { - # Check if model_list is not NULL - if (is.null(self$model_list)) { - cli::cli_abort(c("x" = "Model list is empty.", "i" = "Please provide a valid model list.")) + ) + PM_parse(path = out_path) + res <- PM_load(path = normalizePath(out_path), file = "PMout.Rdata") + } else { + profile_cfg <- pm_remote_profile_config(config = remote_config) + pm_remote_validate_profile_config(profile_cfg) + data_csv <- readr::read_file(gendata_path) + payload <- pm_remote_build_payload( + model_txt = model_rust, + data_csv = data_csv, + settings = fit_params + ) + job_info <- pm_remote_enqueue(payload, config = profile_cfg) + status_result <- pm_remote_wait_for_job(job_info$job_id, config = profile_cfg) + envelope <- pm_remote_fetch_result(job_info$job_id, config = profile_cfg) + if (is.null(envelope$result)) { + cli::cli_abort(c("x" = "Hermes response did not include a fit result payload.")) + } + if (!isTRUE(envelope$result$success)) { + status_label <- status_result$status$status + if (is.null(status_label) || !nzchar(status_label)) { + status_label <- "unknown" } - - if (self$model_list$type %in% c("Analytical", "ODE")) { - placeholders <- c("eqn", "lag", "fa", "ini", "out", "n_eqn", "n_out") - base <- paste0( - "#[allow(unused_mut)]\nequation::", - self$model_list$type, - "::new(\n", - paste("<", placeholders[1:5], ">", sep = "", collapse = ",\n "), - ",\n (", - paste("<", placeholders[6:7], ">", sep = "", collapse = ", "), - "),\n)" - ) - } else { - cli::cli_abort(c("x" = "Invalid model type.", "i" = "Please provide a valid model type.")) + cli::cli_abort(c( + "x" = "Hermes job did not succeed.", + "i" = sprintf("Final status: %s", status_label) + )) + } + prepared <- pm_remote_prepare_result(envelope$result) + pm_remote_write_outputs(prepared, out_path) + jsonlite::write_json(envelope, file.path(out_path, "hermes_result.json"), pretty = TRUE, auto_unbox = TRUE) + job_meta <- list( + job = job_info, + profile = profile_cfg[c("profile_name", "base_url", "queue")], + status = status_result$status, + history = status_result$history + ) + jsonlite::write_json(job_meta, file.path(inputs_dir, "hermes_job.json"), pretty = TRUE, auto_unbox = TRUE) + PM_parse(path = out_path) + res <- PM_load(path = normalizePath(out_path), file = "PMout.Rdata") + status_label <- status_result$status$status + if (is.null(status_label) || !nzchar(status_label)) { + status_label <- "Job completed" + } + msg <- c(msg, cli::format_inline("Hermes job {.val {job_info$job_id}} finished on {.code {job_info$queue}} ({status_label}).")) + } + + if (is.null(res)) { + return(invisible(NULL)) + } + + msg <- c(msg, cli::format_inline("Run results were saved in folder '{.path {out_path}}'")) + + if (report != "none") { + valid_report <- tryCatch( + PM_report(res, path = normalizePath(out_path), template = report, quiet = TRUE), + error = function(e) { + -1 } - - - # Replace placeholders in the base string with actual values from model_list - base <- placeholders %>% - purrr::reduce(\(x, y) stringr::str_replace(x, stringr::str_c("<", y, ">"), as.character(self$model_list[[y]])), .init = base) - # Write the model to a file - writeLines(base, file_path) - }, - from_file = function(file_path) { - self$model_list <- private$makeR6model(model_filename) - # self$content <- readChar(model_filename, file.info(model_filename)$size) - }, - get_primary = function() { - return(tolower(self$model_list$parameters)) + ) + if (valid_report == 1) { + msg <- c(msg, "Report generated with {report} template.") + msg <- c(msg, "If assigned to a variable, e.g. {.code run{run} <-}, results are available in {.code run{run}}.") + } else { + msg <- c(msg, "Report could not be generated.") } - ) # end private - ) # end R6Class PM_model - - ##### These functions create various model components - - #' @title Additive error model + } + + if (length(msg) > 0) { + cli::cli_h1("Notes:") + cli::cli_ul() + purrr::walk(msg, ~ cli::cli_li(.x)) + cli::cli_end() + } + return(invisible(res)) + }, # end fit method + #' @description - #' `r lifecycle::badge("stable")` + #' Calculate posteriors from a fitted model. + #' #' @details + #' This method calculates posteriors from a compiled model. It is not necessary to have + #' run the model first, but it is necessary to have an informative prior distribution. + #' This prior will typically be the result of a previous run, but may also be a file + #' containing support points, with each column named as a parameter in the model plus a final column + #' for probability. Each row contains values for the parameters and the associated probability for + #' those parameter values. The file can be saved as a csv file. #' - #' Create an additive (lambda) error model - #' @param initial Initial value for lambda - #' @param coeff Vector of coefficients defining assay error polynomial - #' @param fixed Estimate if `FALSE` (default). - #' @export - additive <- function(initial, coeff, fixed = FALSE) { - PM_err$new(type = "additive", initial = initial, coeff = coeff, fixed = fixed) - } - - - - #' @title Proportional error model + #' To calculate the posteriors, `map()` calls the `fit()` method with the `cycles` argument set to 0 + #' and the `algorithm` argument set to "POSTPROB". If `data` are not provided as an argument to + #' `map()`, the model's `data` field is used instead. If `data` is provided, it must be a + #' [PM_data] object or the pathname of a file which can be loaded as a [PM_data] object. + #' @param ... Arguments passed to the `fit` method. Note that the `cycles` argument is set to 0, + #' and the `algorithm` argument is set to "POSTPROB" automatically. + map = function(...) { + # browser() + args <- list(...) + + if (!is.null(purrr::pluck(args, "cycles")) && purrr::pluck(args, "cycles") != 0) { + cli::cli_inform(c("i" = "{.arg cycles} set to 0 for posteriors")) + } + args$cycles <- 0 # ensure cycles is set to 0 + + + if (!is.null(purrr::pluck(args, "algorithm")) && purrr::pluck(args, "algorithm") != "POSTPROB") { + cli::cli_inform(c("i" = "{.arg algorithm} set to POSTPROB for posteriors")) + } + args$algorithm <- "POSTPROB" # ensure algorithm is set to POSTPROB + + + if (is.null(purrr::pluck(args, "data"))) { + cli::cli_abort(c("x" = "Data must be specified for posteriors.")) + } + + if (is.null(purrr::pluck(args, "prior")) || purrr::pluck(args, "prior") == "sobol") { + cli::cli_abort(c( + "x" = "Please specify a non-uniform prior for posteriors.", + " " = "This can be a prior run number or the name of a file with support points." + )) + } + + do.call(self$fit, args) + }, #' @description - #' `r lifecycle::badge("stable")` + #' Simulate data from the model using a set of parameter values. + #' @details + #' This method simulates output from the model using a set of parameter values + #' provided in the `theta` matrix and the template for dosing/observations in + #' the `data` object. + #' @param data A [PM_data] object containing the dosing and observation information. + #' @param theta A matrix of parameter values to use for the simulation. + #' The `theta` matrix should have the same number of columns as the number of primary parameters in the model. + #' Each row of `theta` represents a different set of parameter values. #' - #' Create an proportional (gamma) error model - #' @param initial Initial value for gamma - #' @param coeff Vector of coefficients defining assay error polynomial - #' @param fixed Estimate if `FALSE` (default). - #' @export - proportional <- function(initial, coeff, fixed = FALSE) { - PM_err$new(type = "proportional", initial = initial, coeff = coeff, fixed = fixed) - } - - PM_err <- R6::R6Class( - "PM_err", - public = list( - #' @field type Type of error model, either "additive" or "proportional". - type = NULL, - #' @field initial Initial value for the error model. - initial = NULL, - #' @field coeff Coefficients for the assay error polynomial. - coeff = NULL, - #' @field fixed If `TRUE`, the error model is fixed and not estimated. - fixed = NULL, - initialize = function(type, initial, coeff, fixed) { - self$type <- type - self$initial <- initial - self$coeff <- coeff - self$fixed <- fixed - }, - print = function() { - if (self$fixed) { - cli::cli_text("{.strong {tools::toTitleCase(self$type)}}, with fixed value of {.emph {self$initial}} and coefficients {.emph {paste(self$coeff, collapse = ', ')}}.") - } else { - cli::cli_text("{.strong {tools::toTitleCase(self$type)}}, with initial value of {.emph {self$initial}} and coefficients {.emph {paste(self$coeff, collapse = ', ')}}.") + sim = function(data, theta) { + if (!inherits(data, "PM_data")) { + cli::cli_abort(c("x" = "Data must be a PM_data object.")) + } + if (!is.matrix(theta)) { + cli::cli_abort(c("x" = "theta must be a matrix.")) + } + if (!is.numeric(theta)) { + cli::cli_abort(c("x" = "theta must be a matrix of numeric values.")) + } + if (ncol(theta) != length(private$get_primary())) { + cli::cli_abort(c("x" = "theta must have the same number of columns as the number of parameters.")) + } + + + temp_csv <- tempfile(fileext = ".csv") + data$save(temp_csv, header = FALSE) + if (getPMoptions()$backend == "rust") { + if (is.null(self$binary_path)) { + self$compile() + if (is.null(self$binary_path)) { + cli::cli_abort(c("x" = "Model must be compiled before simulating.")) } - }, - flatten = function() { - list(initial = self$initial, coeff = self$coeff, type = self$type, fixed = self$fixed) } - ) - ) - - #' @title Primary parameter values + sim <- simulate_all(temp_csv, self$binary_path, theta, kind = tolower(self$model_list$type)) + } else { + cli::cli_abort(c("x" = "This function can only be used with the rust backend.")) + } + return(sim) + }, #' @description - #' `r lifecycle::badge("experimental")` - #' Define primary model parameter object. - #' This is used internally by the `PM_model` class. - #' @keywords internal - PM_pri <- R6::R6Class( - "PM_pri", - public = list( - #' @field min Minimum value of the range. - min = NULL, - #' @field max Maximum value of the range. - max = NULL, - #' @field mean Mean value of the range, calculated as (min + max) / 2. - mean = NULL, - #' @field sd Standard deviation of the range, calculated as (max - min) / 6. - sd = NULL, - #' @description - #' Initialize a new range object. - #' @param min Minimum value of the range. - #' @param max Maximum value of the range. - initialize = function(min, max) { - self$min <- min - self$max <- max - self$mean <- (min + max) / 2 - self$sd <- (max - min) / 6 + #' Compile the model to a binary file. + #' @details + #' This method write the model to a Rust file in a temporary path, + #' updates the `binary_path` field for the model, and compiles that + #' file to a binary file that can be used for fitting or simulation. + #' If the model is already compiled, the method does nothing. + #' + compile = function() { + if (!is.null(self$binary_path) && file.exists(self$binary_path)) { + # model is compiled + return(invisible(NULL)) + } + + model_path <- file.path(tempdir(), "model.rs") + private$write_model_to_rust(model_path) + output_path <- tempfile(pattern = "model_", fileext = ".pmx") + cli::cli_inform(c("i" = "Compiling model...")) + # path inside Pmetrics package + template_path <- system.file(package = "Pmetrics") + cat("Using template path:", template_path, "\n") + tryCatch( + { + compile_model(model_path, output_path, private$get_primary(), template_path = template_path, kind = tolower(self$model_list$type)) + self$binary_path <- output_path }, - #' @description - #' Print the range. - print = function() { - cli::cli_text("[{.strong {self$min}}, {.strong {self$max}}], {.emph ~N({round(self$mean,2)}}, {.emph {round(self$sd,2)})}") + error = function(e) { + cli::cli_abort( + c("x" = "Model compilation failed: {e$message}", "i" = "Please check the model file and try again.") + ) } ) - ) - - - #' @title Initial range for primary parameter values - #' @description - #' `r lifecycle::badge("stable")` - #' - #' Define primary model parameter initial values as range. For nonparametric, - #' this range will be absolutely respected. For parametric, the range serves - #' to define the mean (midpoint) and standard deviation (1/6 of the range) of the - #' initial parameter value distribution. - #' @param min Minimum value. - #' @param max Maximum value. - #' @export - ab <- function(min, max) { - PM_pri$new(min, max) - } - - - - #' @title Initial mean/SD for primary parameter values + + file.remove(model_path) # remove temporary model file + return(invisible(self)) + }, #' @description - #' `r lifecycle::badge("stable")` + #' Update the model using recursive lists of changes and recompile the updated model. + #' @param ... Named elements corresponding to the blocks in the model, + #' such as "pri", "cov", "sec", "eqn", "ini", "lag", "fa", "out", and "err". + #' For each block, create a list of changes, which may be additions, edits, or deletions. + #' For deletions, set the value to `NULL`. #' - #' Define primary model parameter initial values as mean and standard - #' deviation, which translate to a range. The mean serves as the midpoint - #' of the range, with 3 standard deviations above and below the mean to define - #' the min and max of the range. For nonparametric, - #' this range will be absolutely respected. For parametric, - #' values can be estimated beyond the range. - #' @param mean Initial mean. - #' @param sd Initial standard deviation. - #' @export - msd <- function(mean, sd) { - min <- mean - 3 * sd - max <- mean + 3 * sd - if (min < 0) { - cli::cli_warn(c( - "i" = "Negative minimum value for primary parameter range.", - " " = "This may not be appropriate for your model." + update = function(...) { + changes <- list(...) + keys <- names(changes) + if (!all(tolower(keys) %in% c("pri", "cov", "sec", "eqn", "ini", "lag", "fa", "out", "err"))) { + cli::cli_abort(c( + "x" = "Invalid block name: {keys}", + "i" = "See help for {.fn PM_model}." )) } - PM_pri$new(min, max) + self$arg_list <- modifyList2(self$arg_list, changes) + self <- PM_model$new(self$arg_list) # recreate and recompile the model + return(invisible(self)) } - - - - #' @title Model covariate declaration - #' @description - #' `r lifecycle::badge("stable")` - #' - #' Declare whether covariates in the data are to have - #' interpolation between values or not. - #' @param type If `type = "lm"` (the default) or `type = "linear"`, - #' the covariate value will be - #' linearly interpolated between values when fitting the model to the data. - #' in a model list `cov` item. To fix covariate values to the value at the - #' last time point, set `type = "none"`. - #' @return A value of 1 for "lm" and 0 for "none", which will be passed to Rust. - #' @examples - #' \dontrun{ - #' cov <- c( - #' wt = interp(), # same as interp("lm") or interp("linear") - #' visit = interp("none") - #' ) - #' } - #' @export - interp <- function(type = "lm") { - if (!type %in% c("lm", "linear", "none")) { - cli::cli_abort(c( - "x" = "{type} is not a valid covariate interpolation type.", - "i" = "See help for {.help PM_model()}." - )) + ), # end public list + private = list( + R6fromFile = function(file) { + msg <- "" + blocks <- parseBlocks(file) # this function is in PMutilities + # check for reserved variable names + conflicts <- reserved_name_conflicts(blocks) + if (length(conflicts) > 0) { + msg <- glue::glue("The following are reserved names and cannot be used as variables in a model: {paste(conflicts, collapse = ', ')}") + return(list(status = -1, msg = msg)) } - if (type %in% c("lm", "linear")) { - return(1) + + if (length(grep(";", blocks$primVar)) > 0) { + # using ';' as separator + sep <- ";" } else { - return(0) - } - } - - - - - # PLOT -------------------------------------------------------------------- - - #' @title Plot PM_model objects - #' @description - #' `r lifecycle::badge("stable")` - #' - #' Plots a [PM_model] based on differential equations using network plots from tidygraph and ggraph packages. - #' - #' @details - #' This accepts a [PM_model] object and creates a network plot where nodes are compartments - #' and edges are arrows connecting compartments. - #' @method plot PM_model - #' @param x The name of an [PM_model] object. - #' @param marker Controls the characteristics of the compartments (nodes). - #' It can be boolean or a list. - #' `TRUE` will plot the compartments with default characteristics. - #' `FALSE` will suppress compartment plotting. - #' If a list, can control some marker characteristics, including overriding defaults. - #' These include: - #' \itemize{ - #' \item{`color`} Marker color (default: dodgerblue). - #' \item{`opacity`} Ranging between 0 (fully transparent) to 1 (fully opaque). Default is 0.5. - #' \item{`size`} Relative size of boxes, ranging from 0 to 1. Default is 0.25. - #' \item{`line`} A list of additional attributes governing the outline for filled shapes, most commonly - #' color (default: black) and width (default: 0.5). - #' } - #'
- #'
- #' Example: `marker = list(color = "red", opacity = 0.8, line = list(color = "black", width = 1))` - #' @param line Controls characteristics of arrows (edges). - #' `TRUE` will plot default lines. `FALSE` will suppress lines. - #' If a list, can control some line characteristics, including overriding defaults. - #' These include: - #' \itemize{ - #' \item{`color`} Line color (default: black) - #' \item{`width`} Thickness in points (default: 1). - #' } - #'
- #'
- #' Example: `line = list(color = "red", width = 2)` - #' @param explicit A data frame or tibble containing two columns named `from` and `to` - #' to add additional connecting arrows to the plot indicating transfer between - #' compartments. For each row, the `from` column contains the compartment number of the arrow origin, and the - #' `to` column contains the compartment number of the arrow destination. Use 0 to indicate - #' a destination to the external sink. e.g., `explicit = data.frame(from = 3, to = 0)` - #' @param implicit Similar to `explicit`, used to add dashed connecting arrows - #' to the plot indicating implicit transfer between - #' compartments. For each row, the `from` column contains the compartment number of the arrow origin, and the - #' `to` column contains the compartment number of the arrow destination. Use 0 to indicate - #' a destination to the external sink. e.g., `implicit = data.frame(from = 2, to = 4)` - #' @param print If `TRUE`, will print the object and return it. If `FALSE`, will only return the object. - #' @param ... Not used. - #' @return A plot object of the model. - #' @author Markus Hovd, Julian Otalvaro, Michael Neely - #' @seealso [PM_model], [ggraph::ggraph()], [ggplot2::ggplot()] - #' @export - #' @examples - #' \dontrun{ - #' NPex$model$plot() - #' } - #' @family PMplots - - plot.PM_model <- function(x, - marker = TRUE, - line = TRUE, - explicit, - implicit, - print = TRUE, - ...) { - model <- x - marker <- if (is.list(marker) || marker) { - amendMarker(marker, - default = list( - color = "dodgerblue", - size = 0.25, - line = list(width = 0.5) - ) - ) + if (length(grep(",", blocks$primVar)) > 0) { + # using ',' as separator + sep <- "," } else { - FALSE + return(list(status = -1, msg = "\nPrimary variables should be defined as 'var,lower_val,upper_val' or 'var,fixed_val'.\n")) } - line <- if (is.list(line) || line) { - amendLine(line, default = list(color = "black")) - } else { - FALSE + } + + # build arg_list + arg_list <- list() + # this function makes pri for PM_model + arg_list$pri <- sapply(strsplit(blocks$primVar, sep), function(x) { + # find out if constrained to be positive + const_pos <- any(grepl("\\+", x)) + if (const_pos) { + x <- gsub("\\+", "", x) + cli::cli_inform(c( + "i" = "Truncating variables to positive ranges is not required for NPAG/NPOD", + " " = "This may be updated as parametric algorithms come online, but will be ignored for now." + )) } - - if (inherits(model, "PM_lib")) { - eqns <- model$arg_list$eqn - outs <- model$arg_list$out - } else if (inherits(model, "PM_model")) { - if (model$model_list$name == "user") { - eqns <- model$arg_list$eqn - outs <- model$arg_list$out - } else { - eqns <- get(model$model_list$name)$arg_list$eqn - outs <- get(model$model_list$name)$arg_list$out - } - } else { + + # find out if constant + const_var <- any(grepl("!", x)) + if (const_var) { + x <- gsub("!", "", x) + cli::cli_abort(c("x" = "Constants should be defined in the appropriate block, not #PRI.")) + } + + values <- as.numeric(x[-1]) + + if (length(x[-1]) == 1) { # fixed cli::cli_abort(c( - "x" = "Unknown model type to plot." + "x" = "Fixed but unknown are no longer supported.", + "i" = "If necessary, fit them as random and then use a fixed value in subsequent runs." )) + } else { # range + thisItem <- list(ab(values[1], values[2])) } - - eqns <- func_to_char(eqns) - outs <- func_to_char(outs) - - - # filter any equations that are not diffeq or outputs - - eqns <- eqns %>% - map( - purrr::keep, - stringr::str_detect, - stringr::regex("dX\\[\\d+\\]|XP\\(\\d+\\)", ignore_case = TRUE) - ) %>% - unlist() - - outs <- outs %>% - map( - purrr::keep, - stringr::str_detect, - stringr::regex("Y\\[\\d+\\]", ignore_case = TRUE) - ) %>% - unlist() - - - - - - #### INTERNAL FUNCTIONS - # Parse the function body - parse_equations <- function(func) { - body_expr <- body(func) - equations <- list() - - # Handle single expression or block - if (is.call(body_expr) && body_expr[[1]] == "{") { - # Multiple statements in braces - for (i in 2:length(body_expr)) { - eq <- body_expr[[i]] - if (is.call(eq) && length(eq) == 3 && as.character(eq[[1]]) %in% c("=", "<-")) { - equations <- append(equations, list(eq)) - } - } - } else if (is.call(body_expr) && length(body_expr) == 3 && - as.character(body_expr[[1]]) %in% c("=", "<-")) { - # Single assignment - equations <- list(body_expr) - } - - return(equations) - } - - - ##### Handle distributions - # Recursively distribute products over sums in a single expression or equation. - # - Works symbolically (no evaluation). - # - Handles unary minus. - # - If given an assignment (= or <-), only the RHS is expanded. - # Fully distribute products over sums and flatten subtraction. - # If given an assignment (= or <-), only the RHS is expanded. - expand_distribute <- function(expr) { - op_of <- function(e) if (is.call(e)) as.character(e[[1]]) else "" - - # Build a product call (no eval) - make_prod <- function(a, b) as.call(list(as.name("*"), a, b)) - - # Fold a list of factors into a product - fold_prod <- function(factors) Reduce(make_prod, factors) - - # Rebuild a (flattened) sum from signed terms - build_sum <- function(terms) { - if (length(terms) == 0) { - return(0) - } - mk <- function(sign, e) if (sign == -1) as.call(list(as.name("-"), e)) else e - out <- mk(terms[[1]]$sign, terms[[1]]$expr) - if (length(terms) == 1) { - return(out) - } - for (k in 2:length(terms)) { - tk <- terms[[k]] - out <- if (tk$sign == 1) { - as.call(list(as.name("+"), out, tk$expr)) - } else { - as.call(list(as.name("-"), out, tk$expr)) - } - } - out - } - - # Core: return a flat list of signed terms {sign=±1, expr=LANG} - expand_terms <- function(e, sign = 1) { - # atoms - if (!is.call(e)) { - return(list(list(sign = sign, expr = e))) - } - - op <- op_of(e) - - # parentheses - if (op == "(") { - return(expand_terms(e[[2]], sign)) - } - - # assignment: expand RHS only, rebuild later - if (op %in% c("=", "<-")) { - rhs_terms <- expand_terms(e[[3]], +1) - rhs_exp <- build_sum(rhs_terms) - return(list(list(sign = +1, expr = as.call(list(as.name(op), e[[2]], rhs_exp))))) - } - - # addition - if (op == "+") { - return(c( - expand_terms(e[[2]], sign), - expand_terms(e[[3]], sign) - )) - } - - # subtraction (binary or unary) - if (op == "-") { - if (length(e) == 3) { - return(c( - expand_terms(e[[2]], sign), - expand_terms(e[[3]], -sign) - )) - } else { - return(expand_terms(e[[2]], -sign)) # unary minus - } - } - - # multiplication: distribute across additive factors - if (op == "*") { - # expand each factor into its additive term list - args <- as.list(e)[-1] - expanded_factors <- lapply(args, function(a) expand_terms(a, +1)) - - # start with neutral element (sign=+1, expr=1) - combos <- list(list(sign = +1, expr = 1)) - for (f_terms in expanded_factors) { - newc <- list() - for (c1 in combos) { - for (t2 in f_terms) { - s <- c1$sign * t2$sign - # build product (avoid multiplying by 1 syntactically where possible) - e1 <- c1$expr - e2 <- t2$expr - prod_expr <- - if (is.numeric(e1) && length(e1) == 1 && e1 == 1) { - e2 - } else if (is.numeric(e2) && length(e2) == 1 && e2 == 1) { - e1 - } else if (is.numeric(e1) && length(e1) == 1 && e1 == -1) { - as.call(list(as.name("-"), e2)) - } else if (is.numeric(e2) && length(e2) == 1 && e2 == -1) { - as.call(list(as.name("-"), e1)) - } else { - make_prod(e1, e2) - } - newc[[length(newc) + 1]] <- list(sign = s, expr = prod_expr) - } - } - combos <- newc - } - # apply the incoming sign to all combos - for (i in seq_along(combos)) combos[[i]]$sign <- sign * combos[[i]]$sign - return(combos) - } - - # other calls: expand children but treat as atomic w.r.t. addition - args <- as.list(e) - args[-1] <- lapply(args[-1], function(a) build_sum(expand_terms(a, +1))) - list(list(sign = sign, expr = as.call(args))) - } - - # If it's an assignment, expand_terms already rebuilt it as a single term. - # Otherwise, build the flattened sum. - terms <- expand_terms(expr, +1) - - # Special case: a single rebuilt assignment - if (length(terms) == 1 && is.call(terms[[1]]$expr) && - op_of(terms[[1]]$expr) %in% c("=", "<-")) { - return(terms[[1]]$expr) - } - - build_sum(terms) + names(thisItem) <- x[1] + thisItem + }) # end sapply + + # covariates + covar <- blocks$covar + const_covar <- grepl("!", covar) # returns boolean vector, length = ncov + covar <- gsub("!", "", covar) # remove "!" + covar_list <- tolower(covar) + + # add to arg_list + arg_list$cov <- purrr::map_vec(const_covar, \(x){ + type <- ifelse(!x, "lm", "none") + interp(type) + }) %>% + purrr::set_names(covar_list) + + + # extra + # if (blocks$extra[1] != "") { + # arg_list$ext <- blocks$extra + # } else { + # arg_list$extra <- NULL + # } + + # secondary variables + if (blocks$secVar[1] != "") { + arg_list$sec <- eval(parse(text = glue::glue("function() {{\n {paste(blocks$secVar, collapse = '\n ')}\n}}"))) + } else { + arg_list$sec <- NULL + } + + # bioavailability + if (blocks$f[1] != "") { + arg_list$fa <- eval(parse(text = glue::glue("function() {{\n {paste(blocks$f, collapse = '\n ')}\n}}"))) + } else { + arg_list$fa <- NULL + } + + # bolus + if (blocks$bol[1] != "") { + cli::cli_inform(c( + "i" = "The bolus block is no longer used as of Pmetrics 3.0.0.", + " " = "Indicate bolus inputs as {.code B[x]} in equations, where {.code x} is the input number." + )) + } + + # initial conditions + if (blocks$ini[1] != "") { + arg_list$ini <- eval(parse(text = glue::glue("function() {{\n {paste(blocks$ini, collapse = '\n ')}\n}}"))) + } else { + arg_list$ini <- NULL + } + + # lag time + if (blocks$lag[1] != "") { + arg_list$lag <- eval(parse(text = glue::glue("function() {{\n {paste(blocks$lag, collapse = '\n ')}\n}}"))) + } else { + arg_list$lag <- NULL + } + + # differential equations - legacy + if (!is.null(blocks$diffeq) && blocks$diffeq[1] != "") { + cli::cli_inform(c( + "i" = "The #DIFFEQ block is no longer used as of Pmetrics 3.0.0.", + " " = "The block is now called #EQN for more general equations.", + " " = "Equations have been moved to the {.code eqn} element." + )) + arg_list$eqn <- eval(parse(text = glue::glue("function() {{\n {paste(blocks$diffeq, collapse = '\n ')}\n}}"))) + } else { + arg_list$eqn <- NULL + } + + # model equations - will eventually replace diffeq above + if (blocks$eqn[1] != "") { + arg_list$eqn <- eval(parse(text = glue::glue("function() {{\n {paste(blocks$eqn, collapse = '\n ')}\n}}"))) + } else { + arg_list$eqn <- NULL + } + + # out/err + n_outputLines <- length(blocks$output) + outputLines <- grep("y\\([[:digit:]]+\\)|y\\[[[:digit:]]+\\]", blocks$output) + if (length(outputLines) == 0) { + return(list(status = -1, msg = "\nYou must have at least one output equation of the form 'Y[1] = ...'\n")) + } + + + arg_list$out <- eval(parse(text = glue::glue("function() {{\n {paste(blocks$out, collapse = '\n ')}\n}}"))) + + err <- tolower(gsub("[[:space:]]", "", blocks$error)) + # process constant gamma/lambda + err_type <- c("additive", "proportional")[1 + grepl("^g", err[1])] + const_gamlam <- grepl("!", err[1]) + gamlam_value <- as.numeric(stringr::str_match(err[1], "\\d+\\.?\\d*")) + # process constant coefficients + const_coeff <- grepl("!", err[-1]) # returns boolean vector, length = nout + err <- gsub("!", "", err) # remove "!" + + coeff_fxns <- err[-1] %>% + purrr::imap(\(x, idx) { + glue::glue("{err_type}({gamlam_value}, c({x}), {const_coeff[{idx}]})") + }) %>% + unlist() + + arg_list$err <- eval(parse(text = glue::glue("c(\n{paste({coeff_fxns}, collapse = ',\n')}\n)"))) + + cat(msg) + flush.console() + return(arg_list) + }, # end R6fromFile + + render_model_to_rust = function() { + if (is.null(self$model_list)) { + cli::cli_abort(c("x" = "Model list is empty.", "i" = "Please provide a valid model list.")) + } + if (self$model_list$type %in% c("Analytical", "ODE")) { + placeholders <- c("eqn", "lag", "fa", "ini", "out", "n_eqn", "n_out") + base <- paste0( + "#[allow(unused_mut)]\nequation::", + self$model_list$type, + "::new(\n", + paste("<", placeholders[1:5], ">", sep = "", collapse = ",\n "), + ",\n (", + paste("<", placeholders[6:7], ">", sep = "", collapse = ", "), + " ),\n)" + ) + } else { + cli::cli_abort(c("x" = "Invalid model type.", "i" = "Please provide a valid model type.")) + } + placeholders %>% + purrr::reduce(\(x, y) stringr::str_replace(x, stringr::str_c("<", y, ">"), as.character(self$model_list[[y]])), .init = base) + }, + write_model_to_rust = function(file_path = "main.rs") { + base <- private$render_model_to_rust() + writeLines(base, file_path) + }, + from_file = function(file_path) { + self$model_list <- private$makeR6model(model_filename) + # self$content <- readChar(model_filename, file.info(model_filename)$size) + }, + get_primary = function() { + return(tolower(self$model_list$parameters)) + } + ) # end private +) # end R6Class PM_model + +##### These functions create various model components + +#' @title Additive error model +#' @description +#' `r lifecycle::badge("stable")` +#' +#' Create an additive (lambda) error model +#' @param initial Initial value for lambda +#' @param coeff Vector of coefficients defining assay error polynomial +#' @param fixed Estimate if `FALSE` (default). +#' @export +additive <- function(initial, coeff, fixed = FALSE) { + PM_err$new(type = "additive", initial = initial, coeff = coeff, fixed = fixed) +} + + + +#' @title Proportional error model +#' @description +#' `r lifecycle::badge("stable")` +#' +#' Create an proportional (gamma) error model +#' @param initial Initial value for gamma +#' @param coeff Vector of coefficients defining assay error polynomial +#' @param fixed Estimate if `FALSE` (default). +#' @export +proportional <- function(initial, coeff, fixed = FALSE) { + PM_err$new(type = "proportional", initial = initial, coeff = coeff, fixed = fixed) +} + +PM_err <- R6::R6Class( + "PM_err", + public = list( + #' @field type Type of error model, either "additive" or "proportional". + type = NULL, + #' @field initial Initial value for the error model. + initial = NULL, + #' @field coeff Coefficients for the assay error polynomial. + coeff = NULL, + #' @field fixed If `TRUE`, the error model is fixed and not estimated. + fixed = NULL, + initialize = function(type, initial, coeff, fixed) { + self$type <- type + self$initial <- initial + self$coeff <- coeff + self$fixed <- fixed + }, + print = function() { + if (self$fixed) { + cli::cli_text("{.strong {tools::toTitleCase(self$type)}}, with fixed value of {.emph {self$initial}} and coefficients {.emph {paste(self$coeff, collapse = ', ')}}.") + } else { + cli::cli_text("{.strong {tools::toTitleCase(self$type)}}, with initial value of {.emph {self$initial}} and coefficients {.emph {paste(self$coeff, collapse = ', ')}}.") + } + }, + flatten = function() { + list(initial = self$initial, coeff = self$coeff, type = self$type, fixed = self$fixed) + } + ) +) + +#' @title Primary parameter values +#' @description +#' `r lifecycle::badge("experimental")` +#' Define primary model parameter object. +#' This is used internally by the `PM_model` class. +#' @keywords internal +PM_pri <- R6::R6Class( + "PM_pri", + public = list( + #' @field min Minimum value of the range. + min = NULL, + #' @field max Maximum value of the range. + max = NULL, + #' @field mean Mean value of the range, calculated as (min + max) / 2. + mean = NULL, + #' @field sd Standard deviation of the range, calculated as (max - min) / 6. + sd = NULL, + #' @description + #' Initialize a new range object. + #' @param min Minimum value of the range. + #' @param max Maximum value of the range. + initialize = function(min, max) { + self$min <- min + self$max <- max + self$mean <- (min + max) / 2 + self$sd <- (max - min) / 6 + }, + #' @description + #' Print the range. + print = function() { + cli::cli_text("[{.strong {self$min}}, {.strong {self$max}}], {.emph ~N({round(self$mean,2)}}, {.emph {round(self$sd,2)})}") + } + ) +) + + +#' @title Initial range for primary parameter values +#' @description +#' `r lifecycle::badge("stable")` +#' +#' Define primary model parameter initial values as range. For nonparametric, +#' this range will be absolutely respected. For parametric, the range serves +#' to define the mean (midpoint) and standard deviation (1/6 of the range) of the +#' initial parameter value distribution. +#' @param min Minimum value. +#' @param max Maximum value. +#' @export +ab <- function(min, max) { + PM_pri$new(min, max) +} + + + +#' @title Initial mean/SD for primary parameter values +#' @description +#' `r lifecycle::badge("stable")` +#' +#' Define primary model parameter initial values as mean and standard +#' deviation, which translate to a range. The mean serves as the midpoint +#' of the range, with 3 standard deviations above and below the mean to define +#' the min and max of the range. For nonparametric, +#' this range will be absolutely respected. For parametric, +#' values can be estimated beyond the range. +#' @param mean Initial mean. +#' @param sd Initial standard deviation. +#' @export +msd <- function(mean, sd) { + min <- mean - 3 * sd + max <- mean + 3 * sd + if (min < 0) { + cli::cli_warn(c( + "i" = "Negative minimum value for primary parameter range.", + " " = "This may not be appropriate for your model." + )) + } + PM_pri$new(min, max) +} + + + +#' @title Model covariate declaration +#' @description +#' `r lifecycle::badge("stable")` +#' +#' Declare whether covariates in the data are to have +#' interpolation between values or not. +#' @param type If `type = "lm"` (the default) or `type = "linear"`, +#' the covariate value will be +#' linearly interpolated between values when fitting the model to the data. +#' in a model list `cov` item. To fix covariate values to the value at the +#' last time point, set `type = "none"`. +#' @return A value of 1 for "lm" and 0 for "none", which will be passed to Rust. +#' @examples +#' \dontrun{ +#' cov <- c( +#' wt = interp(), # same as interp("lm") or interp("linear") +#' visit = interp("none") +#' ) +#' } +#' @export +interp <- function(type = "lm") { + if (!type %in% c("lm", "linear", "none")) { + cli::cli_abort(c( + "x" = "{type} is not a valid covariate interpolation type.", + "i" = "See help for {.help PM_model()}." + )) + } + if (type %in% c("lm", "linear")) { + return(1) + } else { + return(0) + } +} + + + + +# PLOT -------------------------------------------------------------------- + +#' @title Plot PM_model objects +#' @description +#' `r lifecycle::badge("stable")` +#' +#' Plots a [PM_model] based on differential equations using network plots from tidygraph and ggraph packages. +#' +#' @details +#' This accepts a [PM_model] object and creates a network plot where nodes are compartments +#' and edges are arrows connecting compartments. +#' @method plot PM_model +#' @param x The name of an [PM_model] object. +#' @param marker Controls the characteristics of the compartments (nodes). +#' It can be boolean or a list. +#' `TRUE` will plot the compartments with default characteristics. +#' `FALSE` will suppress compartment plotting. +#' If a list, can control some marker characteristics, including overriding defaults. +#' These include: +#' \itemize{ +#' \item{`color`} Marker color (default: dodgerblue). +#' \item{`opacity`} Ranging between 0 (fully transparent) to 1 (fully opaque). Default is 0.5. +#' \item{`size`} Relative size of boxes, ranging from 0 to 1. Default is 0.25. +#' \item{`line`} A list of additional attributes governing the outline for filled shapes, most commonly +#' color (default: black) and width (default: 0.5). +#' } +#'
+#'
+#' Example: `marker = list(color = "red", opacity = 0.8, line = list(color = "black", width = 1))` +#' @param line Controls characteristics of arrows (edges). +#' `TRUE` will plot default lines. `FALSE` will suppress lines. +#' If a list, can control some line characteristics, including overriding defaults. +#' These include: +#' \itemize{ +#' \item{`color`} Line color (default: black) +#' \item{`width`} Thickness in points (default: 1). +#' } +#'
+#'
+#' Example: `line = list(color = "red", width = 2)` +#' @param explicit A data frame or tibble containing two columns named `from` and `to` +#' to add additional connecting arrows to the plot indicating transfer between +#' compartments. For each row, the `from` column contains the compartment number of the arrow origin, and the +#' `to` column contains the compartment number of the arrow destination. Use 0 to indicate +#' a destination to the external sink. e.g., `explicit = data.frame(from = 3, to = 0)` +#' @param implicit Similar to `explicit`, used to add dashed connecting arrows +#' to the plot indicating implicit transfer between +#' compartments. For each row, the `from` column contains the compartment number of the arrow origin, and the +#' `to` column contains the compartment number of the arrow destination. Use 0 to indicate +#' a destination to the external sink. e.g., `implicit = data.frame(from = 2, to = 4)` +#' @param print If `TRUE`, will print the object and return it. If `FALSE`, will only return the object. +#' @param ... Not used. +#' @return A plot object of the model. +#' @author Markus Hovd, Julian Otalvaro, Michael Neely +#' @seealso [PM_model], [ggraph::ggraph()], [ggplot2::ggplot()] +#' @export +#' @examples +#' \dontrun{ +#' NPex$model$plot() +#' } +#' @family PMplots + +plot.PM_model <- function(x, + marker = TRUE, + line = TRUE, + explicit, + implicit, + print = TRUE, + ...) { + model <- x + marker <- if (is.list(marker) || marker) { + amendMarker(marker, + default = list( + color = "dodgerblue", + size = 0.25, + line = list(width = 0.5) + ) + ) + } else { + FALSE + } + line <- if (is.list(line) || line) { + amendLine(line, default = list(color = "black")) + } else { + FALSE + } + + if (inherits(model, "PM_lib")) { + eqns <- model$arg_list$eqn + outs <- model$arg_list$out + } else if (inherits(model, "PM_model")) { + if (model$model_list$name == "user") { + eqns <- model$arg_list$eqn + outs <- model$arg_list$out + } else { + eqns <- get(model$model_list$name)$arg_list$eqn + outs <- get(model$model_list$name)$arg_list$out + } + } else { + cli::cli_abort(c( + "x" = "Unknown model type to plot." + )) + } + + eqns <- func_to_char(eqns) + outs <- func_to_char(outs) + + + # filter any equations that are not diffeq or outputs + + eqns <- eqns %>% + map( + purrr::keep, + stringr::str_detect, + stringr::regex("dX\\[\\d+\\]|XP\\(\\d+\\)", ignore_case = TRUE) + ) %>% + unlist() + + outs <- outs %>% + map( + purrr::keep, + stringr::str_detect, + stringr::regex("Y\\[\\d+\\]", ignore_case = TRUE) + ) %>% + unlist() + + + + + + #### INTERNAL FUNCTIONS + # Parse the function body + parse_equations <- function(func) { + body_expr <- body(func) + equations <- list() + + # Handle single expression or block + if (is.call(body_expr) && body_expr[[1]] == "{") { + # Multiple statements in braces + for (i in 2:length(body_expr)) { + eq <- body_expr[[i]] + if (is.call(eq) && length(eq) == 3 && as.character(eq[[1]]) %in% c("=", "<-")) { + equations <- append(equations, list(eq)) } - - # Parse output equations - parse_output_equations <- function(equations) { - # if (is.null(func)) return(list()) - - # equations <- parse_equations(func) - outputs <- list() - - for (eq in equations) { - lhs <- eq[[2]] - rhs <- eq[[3]] - - # Extract output number from y[i] - if (is.call(lhs) && as.character(lhs[[1]]) == "[" && - length(lhs) >= 3 && as.character(lhs[[2]]) == "y") { - output_num <- as.numeric(as.character(lhs[[3]])) - - # Convert RHS to string representation - rhs_str <- deparse(rhs, width.cutoff = 500) - - # Find which compartment this output refers to - comp_ref <- extract_x_pattern(rhs) - if (is.null(comp_ref)) { - # Look deeper in the expression for x[i] patterns - comp_ref <- find_x_in_expression(rhs) - } - - outputs <- append(outputs, list(list( - output_num = output_num, - equation = rhs_str, - compartment = comp_ref - ))) - } - } - - return(outputs) + } + } else if (is.call(body_expr) && length(body_expr) == 3 && + as.character(body_expr[[1]]) %in% c("=", "<-")) { + # Single assignment + equations <- list(body_expr) + } + + return(equations) + } + + + ##### Handle distributions + # Recursively distribute products over sums in a single expression or equation. + # - Works symbolically (no evaluation). + # - Handles unary minus. + # - If given an assignment (= or <-), only the RHS is expanded. + # Fully distribute products over sums and flatten subtraction. + # If given an assignment (= or <-), only the RHS is expanded. + expand_distribute <- function(expr) { + op_of <- function(e) if (is.call(e)) as.character(e[[1]]) else "" + + # Build a product call (no eval) + make_prod <- function(a, b) as.call(list(as.name("*"), a, b)) + + # Fold a list of factors into a product + fold_prod <- function(factors) Reduce(make_prod, factors) + + # Rebuild a (flattened) sum from signed terms + build_sum <- function(terms) { + if (length(terms) == 0) { + return(0) + } + mk <- function(sign, e) if (sign == -1) as.call(list(as.name("-"), e)) else e + out <- mk(terms[[1]]$sign, terms[[1]]$expr) + if (length(terms) == 1) { + return(out) + } + for (k in 2:length(terms)) { + tk <- terms[[k]] + out <- if (tk$sign == 1) { + as.call(list(as.name("+"), out, tk$expr)) + } else { + as.call(list(as.name("-"), out, tk$expr)) } - - # Find x[i] pattern in any expression - find_x_in_expression <- function(expr) { - if (is.call(expr)) { - # Check current expression - x_idx <- extract_x_pattern(expr) - if (!is.null(x_idx)) { - return(x_idx) - } - - # Recursively check sub-expressions - for (i in 1:length(expr)) { - if (i > 1) { # Skip the function name - x_idx <- find_x_in_expression(expr[[i]]) - if (!is.null(x_idx)) { - return(x_idx) - } - } - } - } - return(NULL) + } + out + } + + # Core: return a flat list of signed terms {sign=±1, expr=LANG} + expand_terms <- function(e, sign = 1) { + # atoms + if (!is.call(e)) { + return(list(list(sign = sign, expr = e))) + } + + op <- op_of(e) + + # parentheses + if (op == "(") { + return(expand_terms(e[[2]], sign)) + } + + # assignment: expand RHS only, rebuild later + if (op %in% c("=", "<-")) { + rhs_terms <- expand_terms(e[[3]], +1) + rhs_exp <- build_sum(rhs_terms) + return(list(list(sign = +1, expr = as.call(list(as.name(op), e[[2]], rhs_exp))))) + } + + # addition + if (op == "+") { + return(c( + expand_terms(e[[2]], sign), + expand_terms(e[[3]], sign) + )) + } + + # subtraction (binary or unary) + if (op == "-") { + if (length(e) == 3) { + return(c( + expand_terms(e[[2]], sign), + expand_terms(e[[3]], -sign) + )) + } else { + return(expand_terms(e[[2]], -sign)) # unary minus } - - # Parse terms from right-hand side recursively - parse_rhs_terms <- function(rhs_expr) { - terms <- list() - - # Recursively extract terms and track sign - extract_terms <- function(expr, current_sign = "+") { - if (is.call(expr)) { - op <- as.character(expr[[1]]) - - if (op == "+") { - extract_terms(expr[[2]], current_sign) - extract_terms(expr[[3]], current_sign) - } else if (op == "-") { - if (length(expr) == 3) { - # Binary subtraction: a - b - extract_terms(expr[[2]], current_sign) - extract_terms(expr[[3]], ifelse(current_sign == "+", "-", "+")) - } else { - # Unary minus: -a - extract_terms(expr[[2]], ifelse(current_sign == "+", "-", "+")) - } - } else if (op == "*") { - # Look for x[i] and collect coefficient(s) - vars <- lapply(expr[-1], extract_x_pattern) - if (any(!sapply(vars, is.null))) { - xi_index <- which(!sapply(vars, is.null)) - x_part <- expr[[xi_index + 1]] - coeff_parts <- expr[-c(1, xi_index + 1)] - coeff_str <- paste(sapply(coeff_parts, deparse), collapse = "*") - terms <<- append(terms, list(list(expr = x_part, coeff = coeff_str, sign = current_sign))) + } + + # multiplication: distribute across additive factors + if (op == "*") { + # expand each factor into its additive term list + args <- as.list(e)[-1] + expanded_factors <- lapply(args, function(a) expand_terms(a, +1)) + + # start with neutral element (sign=+1, expr=1) + combos <- list(list(sign = +1, expr = 1)) + for (f_terms in expanded_factors) { + newc <- list() + for (c1 in combos) { + for (t2 in f_terms) { + s <- c1$sign * t2$sign + # build product (avoid multiplying by 1 syntactically where possible) + e1 <- c1$expr + e2 <- t2$expr + prod_expr <- + if (is.numeric(e1) && length(e1) == 1 && e1 == 1) { + e2 + } else if (is.numeric(e2) && length(e2) == 1 && e2 == 1) { + e1 + } else if (is.numeric(e1) && length(e1) == 1 && e1 == -1) { + as.call(list(as.name("-"), e2)) + } else if (is.numeric(e2) && length(e2) == 1 && e2 == -1) { + as.call(list(as.name("-"), e1)) } else { - # No x[i], maybe just a numeric or unrelated variable - terms <<- append(terms, list(list(expr = expr, coeff = NULL, sign = current_sign))) + make_prod(e1, e2) } - } else { - # Some other operation; treat as atomic for now - terms <<- append(terms, list(list(expr = expr, coeff = NULL, sign = current_sign))) - } - } else { - # Symbol or constant - terms <<- append(terms, list(list(expr = expr, coeff = NULL, sign = current_sign))) + newc[[length(newc) + 1]] <- list(sign = s, expr = prod_expr) } } - - extract_terms(rhs_expr) - - return(terms) + combos <- newc } - - # Extract x[i] pattern from expression - extract_x_pattern <- function(expr) { - if (is.call(expr) && as.character(expr[[1]]) == "[" && - length(expr) == 3 && as.character(expr[[2]]) == "x") { - return(as.numeric(as.character(expr[[3]]))) - } - return(NULL) + # apply the incoming sign to all combos + for (i in seq_along(combos)) combos[[i]]$sign <- sign * combos[[i]]$sign + return(combos) + } + + # other calls: expand children but treat as atomic w.r.t. addition + args <- as.list(e) + args[-1] <- lapply(args[-1], function(a) build_sum(expand_terms(a, +1))) + list(list(sign = sign, expr = as.call(args))) + } + + # If it's an assignment, expand_terms already rebuilt it as a single term. + # Otherwise, build the flattened sum. + terms <- expand_terms(expr, +1) + + # Special case: a single rebuilt assignment + if (length(terms) == 1 && is.call(terms[[1]]$expr) && + op_of(terms[[1]]$expr) %in% c("=", "<-")) { + return(terms[[1]]$expr) + } + + build_sum(terms) + } + + # Parse output equations + parse_output_equations <- function(equations) { + # if (is.null(func)) return(list()) + + # equations <- parse_equations(func) + outputs <- list() + + for (eq in equations) { + lhs <- eq[[2]] + rhs <- eq[[3]] + + # Extract output number from y[i] + if (is.call(lhs) && as.character(lhs[[1]]) == "[" && + length(lhs) >= 3 && as.character(lhs[[2]]) == "y") { + output_num <- as.numeric(as.character(lhs[[3]])) + + # Convert RHS to string representation + rhs_str <- deparse(rhs, width.cutoff = 500) + + # Find which compartment this output refers to + comp_ref <- extract_x_pattern(rhs) + if (is.null(comp_ref)) { + # Look deeper in the expression for x[i] patterns + comp_ref <- find_x_in_expression(rhs) } - - # Extract compartment connections - extract_connections <- function(equations) { - compartments <- c() - all_terms <- list() - - # First pass: collect signed terms per compartment - for (eq in equations) { - lhs <- eq[[2]] - rhs <- eq[[3]] - - if (is.call(lhs) && as.character(lhs[[1]]) == "[" && - length(lhs) >= 3 && as.character(lhs[[2]]) == "dx") { - comp_num <- as.numeric(as.character(lhs[[3]])) - compartments <- unique(c(compartments, comp_num)) - - # dist_terms <- distribute_product(rhs) - # terms <- parse_rhs_terms(dist_terms) - terms <- parse_rhs_terms(rhs) - - for (term in terms) { - expr <- term$expr - sign <- term$sign - coeff <- term$coeff - - x_index <- extract_x_pattern(expr) - if (!is.null(x_index)) { - all_terms <- append(all_terms, list(list( - comp = comp_num, - sign = sign, - coeff = coeff, - x_index = x_index - ))) - } - } - } - } - - # Second pass: match positive and negative terms - used <- logical(length(all_terms)) - connections <- list() - - for (i in seq_along(all_terms)) { - ti <- all_terms[[i]] - if (used[i] || ti$sign != "-") next - - match_found <- FALSE - for (j in seq_along(all_terms)) { - tj <- all_terms[[j]] - if (used[j] || tj$sign != "+") next - - # Match by coeff and x_index - if (identical(ti$coeff, tj$coeff) && ti$x_index == tj$x_index) { - connections <- append(connections, list(list( - from = ti$comp, - to = tj$comp, - coeff = ti$coeff - ))) - used[i] <- TRUE - used[j] <- TRUE - match_found <- TRUE - break - } - } - - # If no match, it's elimination - if (!match_found) { - connections <- append(connections, list(list( - from = ti$comp, - to = 0, - coeff = ti$coeff - ))) - used[i] <- TRUE - } + + outputs <- append(outputs, list(list( + output_num = output_num, + equation = rhs_str, + compartment = comp_ref + ))) + } + } + + return(outputs) + } + + # Find x[i] pattern in any expression + find_x_in_expression <- function(expr) { + if (is.call(expr)) { + # Check current expression + x_idx <- extract_x_pattern(expr) + if (!is.null(x_idx)) { + return(x_idx) + } + + # Recursively check sub-expressions + for (i in 1:length(expr)) { + if (i > 1) { # Skip the function name + x_idx <- find_x_in_expression(expr[[i]]) + if (!is.null(x_idx)) { + return(x_idx) } - - return(list(connections = connections, compartments = sort(compartments))) } - - - - # Modify layout logic to use circular positioning - create_plot <- function(connections, compartments, outputs) { - library(ggplot2) - library(dplyr) - - box_width <- 1.2 - box_height <- 0.8 - - n_comp <- length(compartments) - if (n_comp == 0) { - plot.new() - title(main = "No compartments detected") - return() - } - - # Circular layout - radius <- 4 - angles <- seq(0, 2 * pi, length.out = n_comp + 1)[-(n_comp + 1)] - angles <- angles - angles[which(compartments == 1)] + pi / 2 - x_pos <- radius * cos(angles) - y_pos <- radius * sin(angles) - layout_df <- data.frame(compartment = compartments, x = x_pos, y = y_pos) - - # Elimination - elim_comps <- unique(sapply(connections, function(c) if (c$to == 0) c$from else NULL)) - elim_comps <- elim_comps[!sapply(elim_comps, is.null)] - - arrow_segments <- list() - arrow_heads <- list() - labels <- list() - label_tracker <- list() - - # Bidirectional detection - pair_keys <- data.frame( - original = sapply(connections, function(c) paste(c(c$from, c$to), collapse = "-")), - sorted = sapply(connections, function(c) paste(sort(c(c$from, c$to)), collapse = "-")) - ) - dup_table <- table(pair_keys$sorted) - duplicates <- pair_keys$original[which(pair_keys$sorted %in% names(dup_table[dup_table > 1]))] - - for (conn in connections) { - from <- as.numeric(conn$from) - to <- as.numeric(conn$to) - if (to == 0) next - - from_pos <- layout_df %>% filter(compartment == from) - to_pos <- layout_df %>% filter(compartment == to) - - key <- paste(sort(c(from, to)), collapse = "-") - offset <- if (key %in% duplicates) 0.25 else 0 - - dx <- to_pos$x - from_pos$x - dy <- to_pos$y - from_pos$y - len <- sqrt(dx^2 + dy^2) - norm_dx <- dx / len - norm_dy <- dy / len - perp_x <- -norm_dy - perp_y <- norm_dx - - # Adjust start/end for box edges - edge_dx <- box_width / 2 * norm_dx - edge_dy <- box_height / 2 * norm_dy - - x1 <- from_pos$x + offset * perp_x + edge_dx - y1 <- from_pos$y + offset * perp_y + edge_dy - x2 <- to_pos$x + offset * perp_x - edge_dx - y2 <- to_pos$y + offset * perp_y - edge_dy - - arrow_segments[[length(arrow_segments) + 1]] <- data.frame( - x = x1, y = y1, xend = x2, yend = y2, color = "black" - ) - - # Arrowhead at 2/3 - frac <- 2 / 3 - xm <- x1 + frac * (x2 - x1) - ym <- y1 + frac * (y2 - y1) - perp_x_head <- -norm_dy * 0.10 - perp_y_head <- norm_dx * 0.10 - - arrow_heads[[length(arrow_heads) + 1]] <- data.frame( - x = c(xm - perp_x_head, xm + perp_x_head, xm + norm_dx * 0.3), - y = c(ym - perp_y_head, ym + perp_y_head, ym + norm_dy * 0.3), - group = paste0("arrow", length(arrow_heads) + 1), - fill = "black" - ) - - if (!is.null(conn$coeff)) { - key_xy <- paste(round((x1 + x2) / 2, 2), round((y1 + y2) / 2, 2)) - if (is.null(label_tracker[[key_xy]])) label_tracker[[key_xy]] <- 0 - vertical_offset <- 0.25 * label_tracker[[key_xy]] - label_tracker[[key_xy]] <- label_tracker[[key_xy]] + 1 - - mx <- (x1 + x2) / 2 - my <- (y1 + y2) / 2 - vertical_offset - - labels[[length(labels) + 1]] <- data.frame( - x = mx, y = my, label = conn$coeff, - color = "white", text_color = "black" - ) - } - } - - seg_df <- bind_rows(arrow_segments) - head_df <- bind_rows(arrow_heads) - label_df <- bind_rows(labels) - - elim_triangles <- layout_df %>% - filter(compartment %in% elim_comps) %>% - mutate(x = x - 0.4, y = y + 0.2) - - p <- ggplot() - - if (nrow(seg_df) > 0) { # we have connections - p <- p + geom_segment( - data = seg_df, - aes(x = x, y = y, xend = xend, yend = yend, color = color), - linewidth = 0.7, show.legend = FALSE - ) + - geom_polygon( - data = head_df, - aes(x = x, y = y, group = group, fill = fill), - color = NA, show.legend = FALSE - ) - } - - p <- p + geom_rect( - data = layout_df, - aes( - xmin = x - box_width / 2, xmax = x + box_width / 2, - ymin = y - box_height / 2, ymax = y + box_height / 2 - ), - fill = "grey80", color = "black" - ) + - - geom_label( - data = layout_df, - aes(x = x, y = y + 0.15, label = compartment), fill = NA, - color = "black", fontface = "bold", size = 7, label.size = NA - ) + - - geom_point( - data = elim_triangles, - aes(x = x, y = y), - color = "black", shape = 2, size = 4 - ) - - if (nrow(label_df) > 0) { - p <- p + geom_label( - data = label_df, - aes(x = x, y = y, label = label), - fill = label_df$color, - color = label_df$text_color, - fontface = "bold", - size = 4, - show.legend = FALSE, - label.size = NA - ) + } + } + return(NULL) + } + + # Parse terms from right-hand side recursively + parse_rhs_terms <- function(rhs_expr) { + terms <- list() + + # Recursively extract terms and track sign + extract_terms <- function(expr, current_sign = "+") { + if (is.call(expr)) { + op <- as.character(expr[[1]]) + + if (op == "+") { + extract_terms(expr[[2]], current_sign) + extract_terms(expr[[3]], current_sign) + } else if (op == "-") { + if (length(expr) == 3) { + # Binary subtraction: a - b + extract_terms(expr[[2]], current_sign) + extract_terms(expr[[3]], ifelse(current_sign == "+", "-", "+")) + } else { + # Unary minus: -a + extract_terms(expr[[2]], ifelse(current_sign == "+", "-", "+")) + } + } else if (op == "*") { + # Look for x[i] and collect coefficient(s) + vars <- lapply(expr[-1], extract_x_pattern) + if (any(!sapply(vars, is.null))) { + xi_index <- which(!sapply(vars, is.null)) + x_part <- expr[[xi_index + 1]] + coeff_parts <- expr[-c(1, xi_index + 1)] + coeff_str <- paste(sapply(coeff_parts, deparse), collapse = "*") + terms <<- append(terms, list(list(expr = x_part, coeff = coeff_str, sign = current_sign))) + } else { + # No x[i], maybe just a numeric or unrelated variable + terms <<- append(terms, list(list(expr = expr, coeff = NULL, sign = current_sign))) } - - if (length(outputs) > 0) { - out_df <- bind_rows(lapply(outputs, function(out) { - comp <- out$compartment - txt <- paste0("y[", out$output_num, "]") - pos <- layout_df %>% filter(compartment == comp) - data.frame(x = pos$x, y = pos$y - 0.2, label = txt) - })) - - p <- p + geom_label( - data = out_df, - aes(x = x, y = y, label = label), - color = "black", - fill = NA, - fontface = "bold", - size = 3, - label.size = 0 - ) + } else { + # Some other operation; treat as atomic for now + terms <<- append(terms, list(list(expr = expr, coeff = NULL, sign = current_sign))) + } + } else { + # Symbol or constant + terms <<- append(terms, list(list(expr = expr, coeff = NULL, sign = current_sign))) + } + } + + extract_terms(rhs_expr) + + return(terms) + } + + # Extract x[i] pattern from expression + extract_x_pattern <- function(expr) { + if (is.call(expr) && as.character(expr[[1]]) == "[" && + length(expr) == 3 && as.character(expr[[2]]) == "x") { + return(as.numeric(as.character(expr[[3]]))) + } + return(NULL) + } + + # Extract compartment connections + extract_connections <- function(equations) { + compartments <- c() + all_terms <- list() + + # First pass: collect signed terms per compartment + for (eq in equations) { + lhs <- eq[[2]] + rhs <- eq[[3]] + + if (is.call(lhs) && as.character(lhs[[1]]) == "[" && + length(lhs) >= 3 && as.character(lhs[[2]]) == "dx") { + comp_num <- as.numeric(as.character(lhs[[3]])) + compartments <- unique(c(compartments, comp_num)) + + # dist_terms <- distribute_product(rhs) + # terms <- parse_rhs_terms(dist_terms) + terms <- parse_rhs_terms(rhs) + + for (term in terms) { + expr <- term$expr + sign <- term$sign + coeff <- term$coeff + + x_index <- extract_x_pattern(expr) + if (!is.null(x_index)) { + all_terms <- append(all_terms, list(list( + comp = comp_num, + sign = sign, + coeff = coeff, + x_index = x_index + ))) } - - p <- p + - coord_fixed() + - xlim(range(layout_df$x) + c(-1.5, 1.5)) + - ylim(range(layout_df$y) + c(-1.5, 1.5)) + - theme_void() + - ggtitle("Structural model") + - scale_color_identity() + - scale_fill_identity() - - return(p) } - - ##### FUNCTION CALLS - - # equations <- parse_equations(this_model) - # Expand and distribute equations - - expanded_equations <- purrr::map(parse(text = tolower(eqns)), expand_distribute) - outputs <- parse_output_equations(as.list(parse(text = tolower(outs)))) - out_comp <- map_chr(outputs, function(o) as.character(o$compartment)) - result <- extract_connections(expanded_equations) - elim_count <- sum(sapply(result$connections, function(c) c$to == 0)) - elim_coeff <- map_chr(result$connections, function(c) if (c$to == 0) c$coeff else NA) %>% keep(~ !is.na(.)) - - cli::cli_h1("Model elements") - cli::cli_text("{length(result$compartments)} compartments") - cli::cli_text("{length(result$connections)} connections, of which {elim_count} {?is an elimination/are eliminations}: {elim_coeff}") - cli::cli_text("{length(outputs)} output{?s} in compartment{?s} {out_comp}") - - - p <- create_plot(result$connections, result$compartments, outputs) - if (print) print(p) - - return( - invisible(list( - p = p, - connections = result$connections, - compartments = result$compartments, - outputs = outputs - )) + } + } + + # Second pass: match positive and negative terms + used <- logical(length(all_terms)) + connections <- list() + + for (i in seq_along(all_terms)) { + ti <- all_terms[[i]] + if (used[i] || ti$sign != "-") next + + match_found <- FALSE + for (j in seq_along(all_terms)) { + tj <- all_terms[[j]] + if (used[j] || tj$sign != "+") next + + # Match by coeff and x_index + if (identical(ti$coeff, tj$coeff) && ti$x_index == tj$x_index) { + connections <- append(connections, list(list( + from = ti$comp, + to = tj$comp, + coeff = ti$coeff + ))) + used[i] <- TRUE + used[j] <- TRUE + match_found <- TRUE + break + } + } + + # If no match, it's elimination + if (!match_found) { + connections <- append(connections, list(list( + from = ti$comp, + to = 0, + coeff = ti$coeff + ))) + used[i] <- TRUE + } + } + + return(list(connections = connections, compartments = sort(compartments))) + } + + + + # Modify layout logic to use circular positioning + create_plot <- function(connections, compartments, outputs) { + library(ggplot2) + library(dplyr) + + box_width <- 1.2 + box_height <- 0.8 + + n_comp <- length(compartments) + if (n_comp == 0) { + plot.new() + title(main = "No compartments detected") + return() + } + + # Circular layout + radius <- 4 + angles <- seq(0, 2 * pi, length.out = n_comp + 1)[-(n_comp + 1)] + angles <- angles - angles[which(compartments == 1)] + pi / 2 + x_pos <- radius * cos(angles) + y_pos <- radius * sin(angles) + layout_df <- data.frame(compartment = compartments, x = x_pos, y = y_pos) + + # Elimination + elim_comps <- unique(sapply(connections, function(c) if (c$to == 0) c$from else NULL)) + elim_comps <- elim_comps[!sapply(elim_comps, is.null)] + + arrow_segments <- list() + arrow_heads <- list() + labels <- list() + label_tracker <- list() + + # Bidirectional detection + pair_keys <- data.frame( + original = sapply(connections, function(c) paste(c(c$from, c$to), collapse = "-")), + sorted = sapply(connections, function(c) paste(sort(c(c$from, c$to)), collapse = "-")) + ) + dup_table <- table(pair_keys$sorted) + duplicates <- pair_keys$original[which(pair_keys$sorted %in% names(dup_table[dup_table > 1]))] + + for (conn in connections) { + from <- as.numeric(conn$from) + to <- as.numeric(conn$to) + if (to == 0) next + + from_pos <- layout_df %>% filter(compartment == from) + to_pos <- layout_df %>% filter(compartment == to) + + key <- paste(sort(c(from, to)), collapse = "-") + offset <- if (key %in% duplicates) 0.25 else 0 + + dx <- to_pos$x - from_pos$x + dy <- to_pos$y - from_pos$y + len <- sqrt(dx^2 + dy^2) + norm_dx <- dx / len + norm_dy <- dy / len + perp_x <- -norm_dy + perp_y <- norm_dx + + # Adjust start/end for box edges + edge_dx <- box_width / 2 * norm_dx + edge_dy <- box_height / 2 * norm_dy + + x1 <- from_pos$x + offset * perp_x + edge_dx + y1 <- from_pos$y + offset * perp_y + edge_dy + x2 <- to_pos$x + offset * perp_x - edge_dx + y2 <- to_pos$y + offset * perp_y - edge_dy + + arrow_segments[[length(arrow_segments) + 1]] <- data.frame( + x = x1, y = y1, xend = x2, yend = y2, color = "black" + ) + + # Arrowhead at 2/3 + frac <- 2 / 3 + xm <- x1 + frac * (x2 - x1) + ym <- y1 + frac * (y2 - y1) + perp_x_head <- -norm_dy * 0.10 + perp_y_head <- norm_dx * 0.10 + + arrow_heads[[length(arrow_heads) + 1]] <- data.frame( + x = c(xm - perp_x_head, xm + perp_x_head, xm + norm_dx * 0.3), + y = c(ym - perp_y_head, ym + perp_y_head, ym + norm_dy * 0.3), + group = paste0("arrow", length(arrow_heads) + 1), + fill = "black" + ) + + if (!is.null(conn$coeff)) { + key_xy <- paste(round((x1 + x2) / 2, 2), round((y1 + y2) / 2, 2)) + if (is.null(label_tracker[[key_xy]])) label_tracker[[key_xy]] <- 0 + vertical_offset <- 0.25 * label_tracker[[key_xy]] + label_tracker[[key_xy]] <- label_tracker[[key_xy]] + 1 + + mx <- (x1 + x2) / 2 + my <- (y1 + y2) / 2 - vertical_offset + + labels[[length(labels) + 1]] <- data.frame( + x = mx, y = my, label = conn$coeff, + color = "white", text_color = "black" ) } - \ No newline at end of file + } + + seg_df <- bind_rows(arrow_segments) + head_df <- bind_rows(arrow_heads) + label_df <- bind_rows(labels) + + elim_triangles <- layout_df %>% + filter(compartment %in% elim_comps) %>% + mutate(x = x - 0.4, y = y + 0.2) + + p <- ggplot() + + if (nrow(seg_df) > 0) { # we have connections + p <- p + geom_segment( + data = seg_df, + aes(x = x, y = y, xend = xend, yend = yend, color = color), + linewidth = 0.7, show.legend = FALSE + ) + + geom_polygon( + data = head_df, + aes(x = x, y = y, group = group, fill = fill), + color = NA, show.legend = FALSE + ) + } + + p <- p + geom_rect( + data = layout_df, + aes( + xmin = x - box_width / 2, xmax = x + box_width / 2, + ymin = y - box_height / 2, ymax = y + box_height / 2 + ), + fill = "grey80", color = "black" + ) + + + geom_label( + data = layout_df, + aes(x = x, y = y + 0.15, label = compartment), fill = NA, + color = "black", fontface = "bold", size = 7, label.size = NA + ) + + + geom_point( + data = elim_triangles, + aes(x = x, y = y), + color = "black", shape = 2, size = 4 + ) + + if (nrow(label_df) > 0) { + p <- p + geom_label( + data = label_df, + aes(x = x, y = y, label = label), + fill = label_df$color, + color = label_df$text_color, + fontface = "bold", + size = 4, + show.legend = FALSE, + label.size = NA + ) + } + + if (length(outputs) > 0) { + out_df <- bind_rows(lapply(outputs, function(out) { + comp <- out$compartment + txt <- paste0("y[", out$output_num, "]") + pos <- layout_df %>% filter(compartment == comp) + data.frame(x = pos$x, y = pos$y - 0.2, label = txt) + })) + + p <- p + geom_label( + data = out_df, + aes(x = x, y = y, label = label), + color = "black", + fill = NA, + fontface = "bold", + size = 3, + label.size = 0 + ) + } + + p <- p + + coord_fixed() + + xlim(range(layout_df$x) + c(-1.5, 1.5)) + + ylim(range(layout_df$y) + c(-1.5, 1.5)) + + theme_void() + + ggtitle("Structural model") + + scale_color_identity() + + scale_fill_identity() + + return(p) + } + + ##### FUNCTION CALLS + + # equations <- parse_equations(this_model) + # Expand and distribute equations + + expanded_equations <- purrr::map(parse(text = tolower(eqns)), expand_distribute) + outputs <- parse_output_equations(as.list(parse(text = tolower(outs)))) + out_comp <- map_chr(outputs, function(o) as.character(o$compartment)) + result <- extract_connections(expanded_equations) + elim_count <- sum(sapply(result$connections, function(c) c$to == 0)) + elim_coeff <- map_chr(result$connections, function(c) if (c$to == 0) c$coeff else NA) %>% keep(~ !is.na(.)) + + cli::cli_h1("Model elements") + cli::cli_text("{length(result$compartments)} compartments") + cli::cli_text("{length(result$connections)} connections, of which {elim_count} {?is an elimination/are eliminations}: {elim_coeff}") + cli::cli_text("{length(outputs)} output{?s} in compartment{?s} {out_comp}") + + + p <- create_plot(result$connections, result$compartments, outputs) + if (print) print(p) + + return( + invisible(list( + p = p, + connections = result$connections, + compartments = result$compartments, + outputs = outputs + )) + ) +} diff --git a/R/PMoptions.R b/R/PMoptions.R index 4cad43bbb..2a9cfd93f 100755 --- a/R/PMoptions.R +++ b/R/PMoptions.R @@ -6,7 +6,7 @@ #' @details #' This function will get user options for Pmetrics. It will look for a *PMoptions.json* file #' in a hidden folder outside of the Pmetrics package. If that does not exist, -#' it will look for a default options file in the package options folder. See [setPMoptions] for +#' it will look for a default options file in the package options folder. See [setPMoptions] for #' details on where the options file is stored and how to set options. #' #' @param opt The option to retrieve. If omitted, all option values will be returned. @@ -16,26 +16,55 @@ #' @author Michael Neely #' @export +pm_options_user_dir <- function() { + dplyr::case_when( + getOS() %in% c(1, 3) ~ fs::path_expand("~/.PMopts"), + getOS() == 2 ~ file.path(Sys.getenv("APPDATA"), "PMopts"), + TRUE ~ fs::path_expand("~/.PMopts") + ) +} + +pm_options_user_file <- function() { + file.path(pm_options_user_dir(), "PMoptions.json") +} + +pm_remote_default_settings <- function() { + list( + profile_name = "default", + base_url = "", + queue = "heavy-jobs", + poll_interval_sec = 5, + timeout_sec = 3600, + verify_tls = TRUE, + api_key_alias = "hermes-default" + ) +} + +pm_options_store_remote_key <- function(alias, api_key) { + handler <- get0("pm_remote_store_api_key", mode = "function") + if (is.null(handler)) { + stop("Remote key storage helper is unavailable", call. = FALSE) + } + handler(alias, api_key) +} + getPMoptions <- function(opt, warn = TRUE, quiet = FALSE) { # check for existing options - opt_dir <- dplyr::case_when( - getOS() == 1 | getOS() == 3 ~ "~/.PMopts", # Mac, Linux - getOS() == 2 ~ file.path(Sys.getenv("APPDATA"), "PMopts") - ) - + opt_dir <- pm_options_user_dir() + if (dir.exists(opt_dir)) { # external options file exists PMoptionsFile <- file.path(opt_dir, "PMoptions.json") } else { # external options file does not exist PMoptionsFile <- paste(system.file("options", package = "Pmetrics"), "PMoptions.json", sep = "/") } - - + + # if it doesn't exist, warn and exit if (!file.exists(PMoptionsFile)) { - if (warn & !quiet) cli::cli_inform("Run {.help setPMoptions} to create a Pmetrics options file.") + if (warn && !quiet) cli::cli_inform("Run {.help setPMoptions} to create a Pmetrics options file.") return(invisible(-1)) } - + # read the options file PMopts <- jsonlite::read_json(path = PMoptionsFile, simplifyVector = TRUE) if (missing(opt)) { @@ -61,7 +90,7 @@ getPMoptions <- function(opt, warn = TRUE, quiet = FALSE) { #' Also, when the Pmetrics package is first loaded with `library(Pmetrics)`, #' this function will be called with `launch.app = TRUE` to read saved options from #' a *PMoptions.json* file stored in a folder outside -#' of the Pmetrics package, so that your options will persist when Pmetrics is updated. +#' of the Pmetrics package, so that your options will persist when Pmetrics is updated. #' #' @param launch.app Launch the app to set options. Default `TRUE`. #' @return The user preferences file will be updated. This will persist from session to session @@ -70,216 +99,276 @@ getPMoptions <- function(opt, warn = TRUE, quiet = FALSE) { #' @export setPMoptions <- function(launch.app = TRUE) { - - - # --- Helper: OS Detection Function --- - getOS <- function() { - sysname <- Sys.info()[["sysname"]] - if (sysname == "Darwin") return(1) # Mac - if (sysname == "Windows") return(2) # Windows - if (sysname == "Linux") return(3) # Linux - return(0) # unknown - } - - opt_dir <- dplyr::case_when( - getOS() %in% c(1, 3) ~ fs::path_expand("~/.PMopts"), - getOS() == 2 ~ file.path(Sys.getenv("APPDATA"), "PMopts"), - TRUE ~ tempdir() # fallback - ) - - fs::dir_create(opt_dir) # ensure directory exists - PMoptionsUserFile <- file.path(opt_dir, "PMoptions.json") - + opt_dir <- pm_options_user_dir() + + fs::dir_create(opt_dir) # ensure directory exists + PMoptionsUserFile <- pm_options_user_file() + # If file doesn't exist in user space, copy default if (!fs::file_exists(PMoptionsUserFile)) { PMoptionsFile <- glue::glue(system.file("options", package = "Pmetrics"), "/PMoptions.json") fs::file_copy(PMoptionsFile, PMoptionsUserFile, overwrite = TRUE) } - + + settings <- tryCatch( + jsonlite::read_json(PMoptionsUserFile, simplifyVector = TRUE), + error = function(e) list() + ) + + remote_defaults <- pm_remote_default_settings() + remote_settings <- remote_defaults + if (!is.null(settings$remote)) { + remote_settings <- utils::modifyList(remote_defaults, settings$remote) + } + + settings$remote_base_url <- remote_settings$base_url + settings$remote_queue <- remote_settings$queue + settings$remote_poll_interval <- remote_settings$poll_interval_sec + settings$remote_timeout <- remote_settings$timeout_sec + settings$remote_allow_insecure <- !isTRUE(remote_settings$verify_tls) + app <- shiny::shinyApp( - + # --- UI --- ui = bslib::page_fluid( theme = bslib::bs_theme(bootswatch = "flatly"), title = "Pmetrics Options", - - tags$details( - tags$summary("📁 Data File Reading"), - selectInput("sep", "Field separator", - choices = c(Comma = ",", Semicolon = ";", Tab = "\t"), - selected = ","), - - selectInput("dec", "Decimal mark", - choices = c(Period = ".", Comma = ","), - selected = ".") + shiny::tags$details( + shiny::tags$summary("📁 Data File Reading"), + shiny::selectInput("sep", "Field separator", + choices = c(Comma = ",", Semicolon = ";", Tab = "\t"), + selected = "," + ), + shiny::selectInput("dec", "Decimal mark", + choices = c(Period = ".", Comma = ","), + selected = "." + ) ), # Formatting options - tags$details( - tags$summary("📏 Formatting Options"), - numericInput("digits", "Number of digits to display", - value = 3, min = 0, max = 10, step = 1) + shiny::tags$details( + shiny::tags$summary("📏 Formatting Options"), + shiny::numericInput("digits", "Number of digits to display", + value = 3, min = 0, max = 10, step = 1 + ) ), - - conditionalPanel( + shiny::conditionalPanel( condition = "input.show == false", - #Fit options - tags$details( - tags$summary("🔍 Fit Options"), - selectInput("backend", "Default backend", - choices = c("Rust" = "rust"), - selected = "rust"), - markdown("*Rust is the only backend currently supported by Pmetrics.*") - ) - ), - - tags$details( - tags$summary("📊 Prediction Error Metrics"), - br(), - checkboxInput("show_metrics", "Display error metrics on obs-pred plots with linear regression", TRUE), - selectInput("bias_method", "Bias Method", - choices = c( - "Mean absolute error (MAE)" = "mae", - "Mean weighted error (MWE)" = "mwe" - ), - selected = "mwe"), - - selectInput("imp_method", "Imprecision Method", - choices = c( - - "Mean squared error (MSE)" = "mse", - "Mean weighted squared error (MWSE)" = "mwse", - "Root mean squared error (RMSE)" = "rmse", - "Mean, bias-adjusted, squared error (MBASE)" = "mbase", - "Mean, bias-adjusted, weighted, squared error (MBAWSE)" = "mbawse", - "Root mean, bias-adjusted, weighted, squared error (RMBAWSE)" = "rmbawse" + # Fit options + shiny::tags$details( + shiny::tags$summary("🔍 Fit Options"), + shiny::selectInput("backend", "Default backend", + choices = c("Rust" = "rust", "Hermes Remote" = "remote"), + selected = settings$backend %||% "rust" + ), + shiny::markdown("Select Hermes Remote to run fits via the Hermes service."), + shiny::conditionalPanel( + condition = "input.backend == 'remote'", + shiny::div( + class = "mt-3", + shiny::textInput("remote_base_url", "Hermes base URL", + placeholder = "https://hermes.example.com", + value = remote_settings$base_url + ), + shiny::textInput("remote_queue", "Queue name", value = remote_settings$queue), + shiny::numericInput("remote_poll_interval", "Poll interval (seconds)", + value = remote_settings$poll_interval_sec, min = 1, step = 1 + ), + shiny::numericInput("remote_timeout", "Request timeout (seconds)", + value = remote_settings$timeout_sec, min = 30, step = 30 + ), + shiny::checkboxInput("remote_allow_insecure", "Disable TLS verification (local testing only)", + value = !remote_settings$verify_tls + ), + shiny::passwordInput("remote_api_key", "Hermes API key", value = ""), + shiny::helpText("API keys are saved to the system keychain. Leave blank to keep the stored key.") + ) + ) + ) + ), + shiny::tags$details( + shiny::tags$summary("📊 Prediction Error Metrics"), + shiny::br(), + shiny::checkboxInput("show_metrics", "Display error metrics on obs-pred plots with linear regression", TRUE), + shiny::selectInput("bias_method", "Bias Method", + choices = c( + "Mean absolute error (MAE)" = "mae", + "Mean weighted error (MWE)" = "mwe" + ), + selected = "mwe" ), - selected = "rmbawse"), - - checkboxInput("use_percent", "Use percent for error metrics", value = TRUE), - - selectInput("ic_method", "Information Criterion Method", + shiny::selectInput("imp_method", "Imprecision Method", choices = c( - "Akaike Information Criterion (AIC)" = "aic", - "Bayesian Information Criterion (BIC)" = "bic" + "Mean squared error (MSE)" = "mse", + "Mean weighted squared error (MWSE)" = "mwse", + "Root mean squared error (RMSE)" = "rmse", + "Mean, bias-adjusted, squared error (MBASE)" = "mbase", + "Mean, bias-adjusted, weighted, squared error (MBAWSE)" = "mbawse", + "Root mean, bias-adjusted, weighted, squared error (RMBAWSE)" = "rmbawse" + ), + selected = "rmbawse" ), - selected = "aic") - + shiny::checkboxInput("use_percent", "Use percent for error metrics", value = TRUE), + shiny::selectInput("ic_method", "Information Criterion Method", + choices = c( + "Akaike Information Criterion (AIC)" = "aic", + "Bayesian Information Criterion (BIC)" = "bic" + ), + selected = "aic" + ) ), - - tags$details( - tags$summary("📝 Report Generation"), - selectInput("report_template", "Default report template", - choices = c("plotly", "ggplot2"), - selected = "plotly") + shiny::tags$details( + shiny::tags$summary("📝 Report Generation"), + shiny::selectInput("report_template", "Default report template", + choices = c("plotly", "ggplot2"), + selected = "plotly" + ) ), - br(), - div( + shiny::br(), + shiny::div( class = "d-flex gap-2", - actionButton("save", "Save"), - actionButton("exit", "Exit"), + shiny::actionButton("save", "Save"), + shiny::actionButton("exit", "Exit"), ), - - br(), - br(), + shiny::br(), + shiny::br(), shiny::verbatimTextOutput("settings_location"), - br(), - - actionButton("open_file", "Open Options File", - icon = icon("folder-open"), class = "btn-primary") + shiny::br(), + shiny::actionButton("open_file", "Open Options File", + icon = shiny::icon("folder-open"), class = "btn-primary" + ) ), - + # --- Server --- server = function(input, output, session) { - # Load settings from external file - settings <- tryCatch({ - jsonlite::fromJSON(PMoptionsUserFile) - }, error = function(e) NULL) - + settings <- tryCatch( + { + jsonlite::fromJSON(PMoptionsUserFile) + }, + error = function(e) NULL + ) + # update this list every time a new option is added input_types <- list( - sep = updateSelectInput, - dec = updateSelectInput, - show_metrics = updateCheckboxInput, - digits = updateNumericInput, - bias_method = updateSelectInput, - imp_method = updateSelectInput, - use_percent = updateCheckboxInput, - ic_method = updateSelectInput, - report_template = updateSelectInput, - backend = updateSelectInput + sep = shiny::updateSelectInput, + dec = shiny::updateSelectInput, + show_metrics = shiny::updateCheckboxInput, + digits = shiny::updateNumericInput, + bias_method = shiny::updateSelectInput, + imp_method = shiny::updateSelectInput, + use_percent = shiny::updateCheckboxInput, + ic_method = shiny::updateSelectInput, + report_template = shiny::updateSelectInput, + backend = shiny::updateSelectInput, + remote_base_url = shiny::updateTextInput, + remote_queue = shiny::updateTextInput, + remote_poll_interval = shiny::updateNumericInput, + remote_timeout = shiny::updateNumericInput, + remote_allow_insecure = shiny::updateCheckboxInput ) - + # Apply updates purrr::imap(settings, function(val, name) { updater <- input_types[[name]] - arg_name <- input_types[[name]] %>% formals() %>% names() %>% keep(~ .x %in% c("value", "selected")) - - if (!is.null(updater) && !is.null(arg_name)) { + formals_names <- names(formals(updater)) + arg_name <- intersect(formals_names, c("value", "selected")) + arg_name <- arg_name[1] + + if (!is.null(updater) && length(arg_name) == 1 && nzchar(arg_name)) { args <- list(session = session, inputId = name) - args[[arg_name]] <- val %>% stringr::str_remove("^percent_") # remove 'percent_' prefix if present + args[[arg_name]] <- stringr::str_remove(val, "^percent_") # remove 'percent_' prefix if present do.call(updater, args) - } + } }) - - - - - + + + + + # Display path to user settings file - output$settings_location <- renderText({ + output$settings_location <- shiny::renderText({ glue::glue("Options file path:\n{PMoptionsUserFile}") }) - - + + ### Action button handlers - + # Save updated settings - observeEvent(input$save, { - settings <- list(sep = input$sep, dec = input$dec, digits = input$digits, show_metrics = input$show_metrics, - bias_method = glue::glue(c("","percent_")[1+as.numeric(input$use_percent)], input$bias_method), - imp_method = glue::glue(c("","percent_")[1+as.numeric(input$use_percent)], input$imp_method), + shiny::observeEvent(input$save, { + percent_prefix <- c("", "percent_")[1 + as.numeric(input$use_percent)] + remote_payload <- list( + profile_name = remote_settings$profile_name %||% "default", + base_url = input$remote_base_url %||% "", + queue = input$remote_queue %||% "heavy-jobs", + poll_interval_sec = as.numeric(input$remote_poll_interval %||% remote_defaults$poll_interval_sec), + timeout_sec = as.numeric(input$remote_timeout %||% remote_defaults$timeout_sec), + verify_tls = !isTRUE(input$remote_allow_insecure), + api_key_alias = remote_settings$api_key_alias %||% remote_defaults$api_key_alias + ) + settings <- list( + sep = input$sep, + dec = input$dec, + digits = input$digits, + show_metrics = input$show_metrics, + bias_method = glue::glue(percent_prefix, input$bias_method), + imp_method = glue::glue(percent_prefix, input$imp_method), ic_method = input$ic_method, - report_template = input$report_template, backend = input$backend) - - save_status <- tryCatch(jsonlite::write_json(settings, PMoptionsUserFile, pretty = TRUE, auto_unbox = TRUE), + report_template = input$report_template, + backend = input$backend, + remote = remote_payload + ) + + save_status <- tryCatch(jsonlite::write_json(settings, PMoptionsUserFile, pretty = TRUE, auto_unbox = TRUE), error = function(e) { shiny::showNotification( paste("Error saving settings:", e$message), type = "error", duration = 5 ) return(FALSE) - }) - shiny::showNotification( - "Settings saved", type = "message", duration = 3 + } + ) + if (identical(save_status, FALSE)) { + return(invisible(NULL)) + } + shiny::showNotification( + "Settings saved", + type = "message", duration = 3 + ) + + if (!is.null(input$remote_api_key) && nzchar(input$remote_api_key)) { + tryCatch( + { + pm_options_store_remote_key(remote_payload$api_key_alias, input$remote_api_key) + shiny::showNotification("API key stored in keychain", type = "message", duration = 3) + }, + error = function(e) { + shiny::showNotification( + paste("Failed to store API key:", e$message), + type = "error", duration = 5 + ) + } ) - }) - - # Exit the app - observeEvent(input$exit, { - shiny::stopApp() - }) - - # Open the options file in the default application - observeEvent(input$open_file, { - system(glue::glue("open {PMoptionsUserFile}")) - }) - } #end server - ) #end shinyApp - - - # Launch the app without trying to launch another browser - if(launch.app){ - shiny::runApp(app, launch.browser = TRUE) - } - - return(invisible(NULL)) - + } + }) + # Exit the app + shiny::observeEvent(input$exit, { + shiny::stopApp() + }) + + # Open the options file in the default application + shiny::observeEvent(input$open_file, { + system(glue::glue("open {PMoptionsUserFile}")) + }) + } # end server + ) # end shinyApp + + + # Launch the app without trying to launch another browser + if (launch.app) { + shiny::runApp(app, launch.browser = TRUE) + } + + return(invisible(NULL)) } # end of PM_options function - - - - - \ No newline at end of file diff --git a/R/PMutilities.R b/R/PMutilities.R index 7a01a7b04..33b076257 100755 --- a/R/PMutilities.R +++ b/R/PMutilities.R @@ -102,7 +102,7 @@ logAxis <- function(side, grid = F, ...) { } axis(side, ticksat1, labels = labels, tcl = -0.5, lwd = 0, lwd.ticks = 1, ...) axis(side, ticksat2, labels = NA, tcl = -0.25, lwd = 0, lwd.ticks = 1, ...) - + if (grid & (side == 1 | side == 3)) abline(v = ticksat2, col = "lightgray", lty = 1) if (grid & (side == 2 | side == 4)) abline(h = ticksat2, col = "lightgray", lty = 1) } @@ -114,7 +114,7 @@ rmnorm <- function(n, mean, sigma) { sigma1 <- sigma ev <- eigen(sigma, symmetric = TRUE) retval <- ev$vectors %*% diag(sqrt(ev$values), length(ev$values)) %*% - t(ev$vectors) + t(ev$vectors) retval <- matrix(rnorm(n * ncol(sigma)), nrow = n) %*% retval retval <- sweep(retval, 2, mean, "+") colnames(retval) <- names(mean) @@ -122,8 +122,9 @@ rmnorm <- function(n, mean, sigma) { } # density function for the multivariate normal distribution, code from mvtnorm package -dmv_norm <- function(x, mean = rep(0, p), sigma = diag(p), log = FALSE, -checkSymmetry = TRUE) { +dmv_norm <- function( + x, mean = rep(0, p), sigma = diag(p), log = FALSE, + checkSymmetry = TRUE) { if (is.vector(x)) { x <- matrix(x, ncol = length(x)) } @@ -157,443 +158,443 @@ checkSymmetry = TRUE) { rss <- colSums(tmp^2) logretval <- -sum(log(diag(dec))) - 0.5 * p * log(2 * pi) - 0.5 * rss - } - names(logretval) <- rownames(x) - if (log) { - logretval - } else { - exp(logretval) - } } - - openHTML <- function(x) pander::openFileInOS(x) - - # parse NP_RF file only for final cycle information; used for bootstrapping - # indpts,ab,corden,nvar,nactve,iaddl,icyctot,par - - - - random_name <- function() { - n <- 1 - a <- do.call(paste0, replicate(5, sample(LETTERS, n, TRUE), FALSE)) - paste0(a, sprintf("%04d", sample(9999, n, TRUE)), sample(LETTERS, n, TRUE)) - } - - - - - # check for numeric id and convert to number if necessary - checkID <- function(id) { - id <- gsub("^[[:blank:]]+", "", id) - id <- gsub("[[:blank:]]+$", "", id) - idNonNum <- suppressWarnings(any(is.na(as.numeric(id)))) - if (!idNonNum) id <- as.numeric(id) - return(id) - } - - # extract pattern from strings - strparse <- function(pattern, x) { - match <- regexpr(pattern, x, ignore.case = T) - start <- match[1] - stop <- match[1] + attr(match, "match.length") - 1 - return(substr(x, start, stop)) - } - - - # parse blocks in new model template - parseBlocks <- function(model) { - modelFile <- scan(model, what = "character", sep = "\n", blank.lines.skip = T, quiet = T) - # remove comment lines - commLn <- grep("^C ", modelFile) - if (length(commLn) > 0) modelFile <- modelFile[-commLn] - if (length(grep("TSTMULT", modelFile)) > 0) { - return(list(status = 0, model = model)) - } - # stop, we already have a fortran model file - blockStart <- grep("#", modelFile) - blockStop <- c(blockStart[-1] - 1, length(modelFile)) - headers <- tolower(modelFile[blockStart]) - primVar <- blockStart[grep("#pri", headers)] - covar <- blockStart[grep("#cov", headers)] - secVar <- blockStart[grep("#sec", headers)] - bolus <- blockStart[grep("#bol", headers)] - ini <- blockStart[grep("#ini", headers)] - f <- blockStart[grep("#f", headers)] - lag <- blockStart[grep("#lag", headers)] - diffeq <- blockStart[grep("#dif", headers)] - eqn <- blockStart[grep("#eqn", headers)] - output <- blockStart[grep("#out", headers)] - error <- blockStart[grep("#err", headers)] - extra <- blockStart[grep("#ext", headers)] - - if (length(diffeq) > 0) { - eqn <- diffeq - } # change diffeq block to eqn for more general - - headerPresent <- which(c( - length(primVar) > 0, length(covar) > 0, length(secVar) > 0, length(bolus) > 0, length(ini) > 0, - length(f) > 0, length(lag) > 0, length(eqn) > 0, length(output) > 0, length(error) > 0, length(extra) > 0 - )) - missing_mandatory <- which(!c(1, 8:10) %in% headerPresent) - if(length(missing_mandatory)){ - # missing mandatory headers - missing_headers <- c("#PRI", "#EQN", "#OUT", "#ERR")[missing_mandatory] - cli::cli_abort(c("x" = "Model file is missing mandatory header{?s}: {missing_headers} ")) - } - - headerOrder <- c(primVar, covar, secVar, bolus, ini, f, lag, eqn, output, error, extra) - blockStart <- blockStart[rank(headerOrder)] - blockStop <- blockStop[rank(headerOrder)] - - # remove headers that have no information - ok <- mapply(function(x, y) x != y, blockStart, blockStop) - blockStart <- blockStart[ok] - blockStop <- blockStop[ok] - headerPresent <- headerPresent[ok] - - # get blocks - blocks <- list(primVar = NA, covar = NA, secVar = NA, bolus = NA, ini = NA, f = NA, lag = NA, eqn = NA, output = NA, error = NA, extra = NA) - for (i in 1:length(headerPresent)) { - temp <- modelFile[(blockStart[i] + 1):blockStop[i]] - allblank <- grep("^[[:blank:]]+$", temp) - if (length(allblank) > 0) temp <- temp[-allblank] - blocks[[headerPresent[i]]] <- tolower(temp) - } - emptyHeaders <- which(is.na(blocks)) - if (length(emptyHeaders) > 0) blocks[emptyHeaders] <- "" - return(blocks) - } # end parseBlocks - - # check all blocks statements for more than maxwidth characters and insert line break if necessary - chunks <- function(x, maxwidth = 60) { - for (i in 1:length(x)) { - for (j in 1:length(x[[i]])) { - temp <- x[[i]][j] - if (nchar(temp) > maxwidth) { - numchunks <- floor(nchar(temp) / maxwidth) - if (nchar(temp) %% maxwidth > 0) numchunks <- numchunks + 1 - splitchunks <- vector("character", numchunks) - chunkindex <- c(seq(0, numchunks * maxwidth, maxwidth), nchar(temp)) - for (k in 1:numchunks) { - splitchunks[k] <- substr(temp, chunkindex[k] + 1, chunkindex[k + 1]) - } - x[[i]][j] <- paste(splitchunks, collapse = "\n & ") + names(logretval) <- rownames(x) + if (log) { + logretval + } else { + exp(logretval) + } +} + +openHTML <- function(x) pander::openFileInOS(x) + +# parse NP_RF file only for final cycle information; used for bootstrapping +# indpts,ab,corden,nvar,nactve,iaddl,icyctot,par + + + +random_name <- function() { + n <- 1 + a <- do.call(paste0, replicate(5, sample(LETTERS, n, TRUE), FALSE)) + paste0(a, sprintf("%04d", sample(9999, n, TRUE)), sample(LETTERS, n, TRUE)) +} + + + + +# check for numeric id and convert to number if necessary +checkID <- function(id) { + id <- gsub("^[[:blank:]]+", "", id) + id <- gsub("[[:blank:]]+$", "", id) + idNonNum <- suppressWarnings(any(is.na(as.numeric(id)))) + if (!idNonNum) id <- as.numeric(id) + return(id) +} + +# extract pattern from strings +strparse <- function(pattern, x) { + match <- regexpr(pattern, x, ignore.case = T) + start <- match[1] + stop <- match[1] + attr(match, "match.length") - 1 + return(substr(x, start, stop)) +} + + +# parse blocks in new model template +parseBlocks <- function(model) { + modelFile <- scan(model, what = "character", sep = "\n", blank.lines.skip = T, quiet = T) + # remove comment lines + commLn <- grep("^C ", modelFile) + if (length(commLn) > 0) modelFile <- modelFile[-commLn] + if (length(grep("TSTMULT", modelFile)) > 0) { + return(list(status = 0, model = model)) + } + # stop, we already have a fortran model file + blockStart <- grep("#", modelFile) + blockStop <- c(blockStart[-1] - 1, length(modelFile)) + headers <- tolower(modelFile[blockStart]) + primVar <- blockStart[grep("#pri", headers)] + covar <- blockStart[grep("#cov", headers)] + secVar <- blockStart[grep("#sec", headers)] + bolus <- blockStart[grep("#bol", headers)] + ini <- blockStart[grep("#ini", headers)] + f <- blockStart[grep("#f", headers)] + lag <- blockStart[grep("#lag", headers)] + diffeq <- blockStart[grep("#dif", headers)] + eqn <- blockStart[grep("#eqn", headers)] + output <- blockStart[grep("#out", headers)] + error <- blockStart[grep("#err", headers)] + extra <- blockStart[grep("#ext", headers)] + + if (length(diffeq) > 0) { + eqn <- diffeq + } # change diffeq block to eqn for more general + + headerPresent <- which(c( + length(primVar) > 0, length(covar) > 0, length(secVar) > 0, length(bolus) > 0, length(ini) > 0, + length(f) > 0, length(lag) > 0, length(eqn) > 0, length(output) > 0, length(error) > 0, length(extra) > 0 + )) + missing_mandatory <- which(!c(1, 8:10) %in% headerPresent) + if (length(missing_mandatory)) { + # missing mandatory headers + missing_headers <- c("#PRI", "#EQN", "#OUT", "#ERR")[missing_mandatory] + cli::cli_abort(c("x" = "Model file is missing mandatory header{?s}: {missing_headers} ")) + } + + headerOrder <- c(primVar, covar, secVar, bolus, ini, f, lag, eqn, output, error, extra) + blockStart <- blockStart[rank(headerOrder)] + blockStop <- blockStop[rank(headerOrder)] + + # remove headers that have no information + ok <- mapply(function(x, y) x != y, blockStart, blockStop) + blockStart <- blockStart[ok] + blockStop <- blockStop[ok] + headerPresent <- headerPresent[ok] + + # get blocks + blocks <- list(primVar = NA, covar = NA, secVar = NA, bolus = NA, ini = NA, f = NA, lag = NA, eqn = NA, output = NA, error = NA, extra = NA) + for (i in 1:length(headerPresent)) { + temp <- modelFile[(blockStart[i] + 1):blockStop[i]] + allblank <- grep("^[[:blank:]]+$", temp) + if (length(allblank) > 0) temp <- temp[-allblank] + blocks[[headerPresent[i]]] <- tolower(temp) + } + emptyHeaders <- which(is.na(blocks)) + if (length(emptyHeaders) > 0) blocks[emptyHeaders] <- "" + return(blocks) +} # end parseBlocks + +# check all blocks statements for more than maxwidth characters and insert line break if necessary +chunks <- function(x, maxwidth = 60) { + for (i in 1:length(x)) { + for (j in 1:length(x[[i]])) { + temp <- x[[i]][j] + if (nchar(temp) > maxwidth) { + numchunks <- floor(nchar(temp) / maxwidth) + if (nchar(temp) %% maxwidth > 0) numchunks <- numchunks + 1 + splitchunks <- vector("character", numchunks) + chunkindex <- c(seq(0, numchunks * maxwidth, maxwidth), nchar(temp)) + for (k in 1:numchunks) { + splitchunks[k] <- substr(temp, chunkindex[k] + 1, chunkindex[k + 1]) } + x[[i]][j] <- paste(splitchunks, collapse = "\n & ") } } - return(x) - } # end chunks - - # change dX[digit] to XP(digit) and X[digit] to X(digit) - fortranize <- function(block) { - block <- purrr::map_chr(block, ~ gsub("dX\\[(\\d+)\\]", "XP\\(\\1\\)", .x, ignore.case = T, perl = T)) - block <- purrr::map_chr(block, ~ gsub("BOLUS\\[\\d+\\]", "", .x, ignore.case = T, perl = T)) - block <- purrr::map_chr(block, ~ gsub("\\[(\\d+)\\]", "\\(\\1\\)", .x, ignore.case = T, perl = T)) - return(block) - } - - - # convert new model template to model fortran file - makeModel <- function(model = "model.txt", data = "data.csv", engine, backend = getPMoptions("backend"), write = T, quiet = F) { - blocks <- parseBlocks(model) - - # check for reserved variable names - reserved <- c( - "ndim", "t", "x", "xp", "rpar", "ipar", "p", "r", "b", "npl", "numeqt", "ndrug", "nadd", "rateiv", "cv", - "n", "nd", "ni", "nup", "nuic", "np", "nbcomp", "psym", "fa", "lag", "tin", "tout" - ) - conflict <- c(match(tolower(blocks$primVar), reserved, nomatch = -99), match(tolower(blocks$secVar), reserved, nomatch = -99), match(tolower(blocks$covar), reserved, nomatch = -99)) - nconflict <- sum(conflict != -99) - if (nconflict > 0) { - msg <- paste("\n", paste(paste("'", reserved[conflict[conflict != -99]], "'", sep = ""), collapse = ", "), " ", c("is a", "are")[1 + as.numeric(nconflict > 1)], " reserved ", c("name", "names")[1 + as.numeric(nconflict > 1)], ", regardless of case.\nPlease choose non-reserved parameter/covariate names.\n", sep = "") - return(list(status = -1, msg = msg)) - } - - # check all blocks statements for more than maxwidth characters and insert line break if necessary - maxwidth <- 60 - blocks <- chunks(x = blocks, maxwidth = maxwidth) - - # ensure in fortran format: dX -> XP and [] -> () - blocks <- purrr::map(blocks, fortranize) - - # primary variable definitions - npvar <- length(blocks$primVar) - psym <- vector("character", npvar) - pvardef <- psym - if (length(grep(";", blocks$primVar)) > 0) { - # using ';' as separator - sep <- ";" - } else { - if (length(grep(",", blocks$primVar)) > 0) { - # using ',' as separator - sep <- "," - } else { - return(list(status = -1, msg = "\nPrimary variables should be defined as 'var,lower_val,upper_val' or 'var,fixed_val'.\n")) - } - } - - # find out if any are fixed to be positive only for IT2B - fixedpos <- grep("\\+", blocks$primVar) - if (length(fixedpos) > 0) blocks$primVar <- gsub("\\+", "", blocks$primVar) - - # find out if any are to be fixed (constant) - fixcon <- grep("!", blocks$primVar) - nofix <- length(fixcon) - if (nofix > 0) blocks$primVar <- gsub("!", "", blocks$primVar) - - - # get limits [a,b] on primary variables - splitprimVar <- strsplit(blocks$primVar, sep) - a <- as.numeric(unlist(lapply(splitprimVar, function(x) x[2]))) - b <- as.numeric(unlist(lapply(splitprimVar, function(x) x[3]))) - - # set parameter type: 1 for random, 0 for constant, -1 for random but pos (IT2B only) and 2 for fixed random - ptype <- c(1, 2)[1 + as.numeric(is.na(b))] - # if any fixed constant variables are present, set ptype to 0 - if (nofix > 0) ptype[fixcon] <- 0 - - # npvar is total number of parameters - # nvar is number of random (estimated) parameters - # nranfix is number of fixed (but unknown) parameters - # nofix is number of constant parameters - nranfix <- sum(as.numeric(is.na(b))) - nofix - nvar <- npvar - nofix - nranfix - - if ((engine$alg == "IT" | engine$alg == "ERR") & length(fixedpos) > 0) ptype[fixedpos] <- -1 - - if (nofix > 0) { - valfix <- a[which(ptype == 0)] + } + return(x) +} # end chunks + +# change dX[digit] to XP(digit) and X[digit] to X(digit) +fortranize <- function(block) { + block <- purrr::map_chr(block, ~ gsub("dX\\[(\\d+)\\]", "XP\\(\\1\\)", .x, ignore.case = T, perl = T)) + block <- purrr::map_chr(block, ~ gsub("BOLUS\\[\\d+\\]", "", .x, ignore.case = T, perl = T)) + block <- purrr::map_chr(block, ~ gsub("\\[(\\d+)\\]", "\\(\\1\\)", .x, ignore.case = T, perl = T)) + return(block) +} + + +# convert new model template to model fortran file +makeModel <- function(model = "model.txt", data = "data.csv", engine, backend = getPMoptions("backend"), write = T, quiet = F) { + blocks <- parseBlocks(model) + + # check for reserved variable names + reserved <- c( + "ndim", "t", "x", "xp", "rpar", "ipar", "p", "r", "b", "npl", "numeqt", "ndrug", "nadd", "rateiv", "cv", + "n", "nd", "ni", "nup", "nuic", "np", "nbcomp", "psym", "fa", "lag", "tin", "tout" + ) + conflict <- c(match(tolower(blocks$primVar), reserved, nomatch = -99), match(tolower(blocks$secVar), reserved, nomatch = -99), match(tolower(blocks$covar), reserved, nomatch = -99)) + nconflict <- sum(conflict != -99) + if (nconflict > 0) { + msg <- paste("\n", paste(paste("'", reserved[conflict[conflict != -99]], "'", sep = ""), collapse = ", "), " ", c("is a", "are")[1 + as.numeric(nconflict > 1)], " reserved ", c("name", "names")[1 + as.numeric(nconflict > 1)], ", regardless of case.\nPlease choose non-reserved parameter/covariate names.\n", sep = "") + return(list(status = -1, msg = msg)) + } + + # check all blocks statements for more than maxwidth characters and insert line break if necessary + maxwidth <- 60 + blocks <- chunks(x = blocks, maxwidth = maxwidth) + + # ensure in fortran format: dX -> XP and [] -> () + blocks <- purrr::map(blocks, fortranize) + + # primary variable definitions + npvar <- length(blocks$primVar) + psym <- vector("character", npvar) + pvardef <- psym + if (length(grep(";", blocks$primVar)) > 0) { + # using ';' as separator + sep <- ";" + } else { + if (length(grep(",", blocks$primVar)) > 0) { + # using ',' as separator + sep <- "," } else { - valfix <- NA + return(list(status = -1, msg = "\nPrimary variables should be defined as 'var,lower_val,upper_val' or 'var,fixed_val'.\n")) } - - if (nranfix > 0) { - valranfix <- a[which(ptype == 2)] + } + + # find out if any are fixed to be positive only for IT2B + fixedpos <- grep("\\+", blocks$primVar) + if (length(fixedpos) > 0) blocks$primVar <- gsub("\\+", "", blocks$primVar) + + # find out if any are to be fixed (constant) + fixcon <- grep("!", blocks$primVar) + nofix <- length(fixcon) + if (nofix > 0) blocks$primVar <- gsub("!", "", blocks$primVar) + + + # get limits [a,b] on primary variables + splitprimVar <- strsplit(blocks$primVar, sep) + a <- as.numeric(unlist(lapply(splitprimVar, function(x) x[2]))) + b <- as.numeric(unlist(lapply(splitprimVar, function(x) x[3]))) + + # set parameter type: 1 for random, 0 for constant, -1 for random but pos (IT2B only) and 2 for fixed random + ptype <- c(1, 2)[1 + as.numeric(is.na(b))] + # if any fixed constant variables are present, set ptype to 0 + if (nofix > 0) ptype[fixcon] <- 0 + + # npvar is total number of parameters + # nvar is number of random (estimated) parameters + # nranfix is number of fixed (but unknown) parameters + # nofix is number of constant parameters + nranfix <- sum(as.numeric(is.na(b))) - nofix + nvar <- npvar - nofix - nranfix + + if ((engine$alg == "IT" | engine$alg == "ERR") & length(fixedpos) > 0) ptype[fixedpos] <- -1 + + if (nofix > 0) { + valfix <- a[which(ptype == 0)] + } else { + valfix <- NA + } + + if (nranfix > 0) { + valranfix <- a[which(ptype == 2)] + } else { + valranfix <- NA + } + + ab.df <- data.frame(a = a[which(ptype == 1)], b = b[which(ptype == 1)]) + + + # replace a,b with SIM limits argument if it is present + if (engine$alg == "SIM" & !all(is.na(engine$limits))) { + if (nrow(engine$limits) == nvar) { + # make sure same row number + replA <- engine$limits[, 1] + replB <- engine$limits[, 2] + ab.df$a[!is.na(replA)] <- replA[!is.na(replA)] + ab.df$b[!is.na(replB)] <- replB[!is.na(replB)] } else { - valranfix <- NA + return(list(status = -1, msg = "Your limit block does not have the same number of parameters as the model file.\n")) } - - ab.df <- data.frame(a = a[which(ptype == 1)], b = b[which(ptype == 1)]) - - - # replace a,b with SIM limits argument if it is present - if (engine$alg == "SIM" & !all(is.na(engine$limits))) { - if (nrow(engine$limits) == nvar) { - # make sure same row number - replA <- engine$limits[, 1] - replB <- engine$limits[, 2] - ab.df$a[!is.na(replA)] <- replA[!is.na(replA)] - ab.df$b[!is.na(replB)] <- replB[!is.na(replB)] - } else { - return(list(status = -1, msg = "Your limit block does not have the same number of parameters as the model file.\n")) - } - } - - if (nofix > 0 & any(is.na(valfix))) { - return(list(status = -1, msg = "One or more variables did not have any boundaries.\n")) + } + + if (nofix > 0 & any(is.na(valfix))) { + return(list(status = -1, msg = "One or more variables did not have any boundaries.\n")) + } + if (nranfix > 0 & any(is.na(valranfix))) { + return(list(status = -1, msg = "One or more variables did not have any boundaries.\n")) + } + + # set grid point index for NPAG if not supplied + if (engine$indpts == -99) { + indpts <- switch(nvar, + 1, + 1, + 3, + 4, + 6 + ) + if (is.null(indpts)) indpts <- 100 + nvar - 5 + if (indpts > 108) indpts <- 108 + } else { + indpts <- engine$indpts + } + + + # transform ab + if (nrow(ab.df) > 0) { + ab <- paste(t(as.matrix(ab.df))) + ab <- c(paste(ab[1:(length(ab) - 1)], "t", sep = ""), ab[length(ab)]) + ab[seq(1, 2 * nvar, 2)] <- sub("t", " ", ab[seq(1, 2 * nvar, 2)]) + ab[seq(2, 2 * nvar, 2)] <- sub("t", "\n", ab[seq(2, 2 * nvar, 2)]) + ab <- paste(ab, collapse = "") + } + + blocks$primVar <- unlist(lapply(splitprimVar, function(x) x[1])) + + for (i in 1:npvar) { + psym[i] <- paste("PSYM(", i, ")='", blocks$primVar[i], "'", sep = "") + pvardef[i] <- paste(blocks$primVar[i], "=P(", i, ")", sep = "") + } + + + # covariate definitions + if (blocks$covar[1] != "") { + ncov <- length(blocks$covar) + interpol <- grep("!", blocks$covar) + blocks$covar <- gsub("!", "", blocks$covar) + covardef <- vector("character", ncov) + for (i in 1:ncov) { + covardef[i] <- paste(blocks$covar[i], "=CV(", i, ")", sep = "") } - if (nranfix > 0 & any(is.na(valranfix))) { - return(list(status = -1, msg = "One or more variables did not have any boundaries.\n")) + if (!identical(1:ncov, which(tolower(engine$covnames) %in% tolower(blocks$covar)))) { + return(list(status = -1, msg = "The covariate set in your model file was not in the same order as in your data file.\n")) } - - # set grid point index for NPAG if not supplied - if (engine$indpts == -99) { - indpts <- switch(nvar, - 1, - 1, - 3, - 4, - 6 - ) - if (is.null(indpts)) indpts <- 100 + nvar - 5 - if (indpts > 108) indpts <- 108 + } else { + covardef <- "" + interpol <- grep("!", blocks$covar) + } + if (engine$ncov > 0) { + ctype <- rep(2, engine$ncov) + } else { + ctype <- -99 + } + # set covariate type based on number of covariates in data file, default is 2, interpolated + if (length(interpol) > 0) ctype[interpol] <- 1 # change those in model file with "!" to constant + + # secondary variable definitions + svardef <- blocks$secVar + + # get secondary variables and remove continuation lines beginning with "&" + secVarNames <- gsub("[[:blank:]]", "", unlist(lapply(strsplit(svardef, "="), function(x) x[1]))) + secVarNames[is.na(secVarNames)] <- "" + oldContLines <- grep("^\\+", secVarNames) + if (length(oldContLines > 0)) { + return(list(status = -1, msg = "\nThe model file format has changed. Please replace '+' with '&' in all continuation lines.\n")) + } + contLines <- grep("^&", secVarNames) + + if (length(contLines) > 0) { + secVarNames <- secVarNames[-contLines] + svardef <- gsub("^&", "", svardef) + } + + # take out any extra declarations in eqn to add to declarations in subroutine + diffdec <- grep("COMMON|EXTERNAL|DIMENSION", blocks$eqn, ignore.case = T) + if (length(diffdec) > 0) { + diffstate <- blocks$eqn[diffdec] + blocks$eqn <- blocks$eqn[-diffdec] + } else { + diffstate <- "" + } + + # detect N + if (blocks$eqn[1] == "" | grepl("^\\{algebraic:", blocks$eqn[1])) { + if ("KE" %in% toupper(secVarNames) | "KE" %in% toupper(blocks$primVar)) { + N <- -1 } else { - indpts <- engine$indpts - } - - - # transform ab - if (nrow(ab.df) > 0) { - ab <- paste(t(as.matrix(ab.df))) - ab <- c(paste(ab[1:(length(ab) - 1)], "t", sep = ""), ab[length(ab)]) - ab[seq(1, 2 * nvar, 2)] <- sub("t", " ", ab[seq(1, 2 * nvar, 2)]) - ab[seq(2, 2 * nvar, 2)] <- sub("t", "\n", ab[seq(2, 2 * nvar, 2)]) - ab <- paste(ab, collapse = "") + N <- 0 } - - blocks$primVar <- unlist(lapply(splitprimVar, function(x) x[1])) - - for (i in 1:npvar) { - psym[i] <- paste("PSYM(", i, ")='", blocks$primVar[i], "'", sep = "") - pvardef[i] <- paste(blocks$primVar[i], "=P(", i, ")", sep = "") + } else { + # get number of equations and verify with data file + # find statements with XP(digit) or dX[digit] + compLines <- grep("XP\\([[:digit:]]+\\)|dX\\[[[:digit:]]+\\]", blocks$eqn, ignore.case = T) + if (length(compLines) == 0) { + N <- 0 + } else { + compStatements <- sapply(blocks$eqn[compLines], function(x) strparse("XP\\([[:digit:]]+\\)|dX\\[[[:digit:]]+\\]", x)) + compNumbers <- sapply(compStatements, function(x) strparse("[[:digit:]]+", x)) + # get max number + N <- max(as.numeric(compNumbers)) } - - - # covariate definitions - if (blocks$covar[1] != "") { - ncov <- length(blocks$covar) - interpol <- grep("!", blocks$covar) - blocks$covar <- gsub("!", "", blocks$covar) - covardef <- vector("character", ncov) - for (i in 1:ncov) { - covardef[i] <- paste(blocks$covar[i], "=CV(", i, ")", sep = "") + } + + # figure out model if N = -1 and if so, assign values to required KA,KE,V,KCP,KPC + # in future, use {algebraic: xx} which is in model files now to select correct algebraic model + # for now, comment the eqn lines in fortran if present + if (length(grep("^\\{algebraic:", blocks$eqn[1])) > 0) { + blocks$eqn[1] <- "This model uses algebraic solutions. Differential equations provided here for reference only." + blocks$eqn <- purrr::map_chr(blocks$eqn, \(x) paste0("! ", x)) + } + + + reqVars <- c("KA", "KE", "KCP", "KPC", "V") + matchVars <- match(reqVars, toupper(c(blocks$primVar, secVarNames))) + if (N == -1) { + if (any(is.na(matchVars))) { + missVars <- reqVars[is.na(matchVars)] + if ("KE" %in% toupper(missVars)) { + return(list(status = -1, msg = "\nYou have specified an algebraic model, which requires a variable named 'KE'\n")) } - if (!identical(1:ncov, which(tolower(engine$covnames) %in% tolower(blocks$covar)))) { - return(list(status = -1, msg = "The covariate set in your model file was not in the same order as in your data file.\n")) + if ("V" %in% toupper(missVars)) { + return(list(status = -1, msg = "\nYou have specified an algebraic model, which requires a variable named 'V'\n")) } + missVarValues <- paste(missVars, "=0", sep = "") + if (length(missVarValues) > 0) svardef <- c(svardef, missVarValues) + svardef <- svardef[svardef != ""] + # add new secondary variables that won't be estimated + secVarNames <- c(secVarNames, missVars) + secVarNames <- secVarNames[secVarNames != ""] } else { - covardef <- "" - interpol <- grep("!", blocks$covar) - } - if (engine$ncov > 0) { - ctype <- rep(2, engine$ncov) - } else { - ctype <- -99 - } - # set covariate type based on number of covariates in data file, default is 2, interpolated - if (length(interpol) > 0) ctype[interpol] <- 1 # change those in model file with "!" to constant - - # secondary variable definitions - svardef <- blocks$secVar - - # get secondary variables and remove continuation lines beginning with "&" - secVarNames <- gsub("[[:blank:]]", "", unlist(lapply(strsplit(svardef, "="), function(x) x[1]))) - secVarNames[is.na(secVarNames)] <- "" - oldContLines <- grep("^\\+", secVarNames) - if (length(oldContLines > 0)) { - return(list(status = -1, msg = "\nThe model file format has changed. Please replace '+' with '&' in all continuation lines.\n")) + missVars <- NA } - contLines <- grep("^&", secVarNames) - - if (length(contLines) > 0) { - secVarNames <- secVarNames[-contLines] - svardef <- gsub("^&", "", svardef) - } - - # take out any extra declarations in eqn to add to declarations in subroutine - diffdec <- grep("COMMON|EXTERNAL|DIMENSION", blocks$eqn, ignore.case = T) - if (length(diffdec) > 0) { - diffstate <- blocks$eqn[diffdec] - blocks$eqn <- blocks$eqn[-diffdec] - } else { - diffstate <- "" - } - - # detect N - if (blocks$eqn[1] == "" | grepl("^\\{algebraic:", blocks$eqn[1])) { - if ("KE" %in% toupper(secVarNames) | "KE" %in% toupper(blocks$primVar)) { - N <- -1 - } else { - N <- 0 - } + } else { + if (any(is.na(matchVars))) { + missVars <- reqVars[is.na(matchVars)] } else { - # get number of equations and verify with data file - # find statements with XP(digit) or dX[digit] - compLines <- grep("XP\\([[:digit:]]+\\)|dX\\[[[:digit:]]+\\]", blocks$eqn, ignore.case = T) - if (length(compLines) == 0) { - N <- 0 - } else { - compStatements <- sapply(blocks$eqn[compLines], function(x) strparse("XP\\([[:digit:]]+\\)|dX\\[[[:digit:]]+\\]", x)) - compNumbers <- sapply(compStatements, function(x) strparse("[[:digit:]]+", x)) - # get max number - N <- max(as.numeric(compNumbers)) - } + missVars <- NA } - - # figure out model if N = -1 and if so, assign values to required KA,KE,V,KCP,KPC - # in future, use {algebraic: xx} which is in model files now to select correct algebraic model - # for now, comment the eqn lines in fortran if present - if (length(grep("^\\{algebraic:", blocks$eqn[1])) > 0) { - blocks$eqn[1] <- "This model uses algebraic solutions. Differential equations provided here for reference only." - blocks$eqn <- purrr::map_chr(blocks$eqn, \(x) paste0("! ", x)) - } - - - reqVars <- c("KA", "KE", "KCP", "KPC", "V") - matchVars <- match(reqVars, toupper(c(blocks$primVar, secVarNames))) - if (N == -1) { - if (any(is.na(matchVars))) { - missVars <- reqVars[is.na(matchVars)] - if ("KE" %in% toupper(missVars)) { - return(list(status = -1, msg = "\nYou have specified an algebraic model, which requires a variable named 'KE'\n")) - } - if ("V" %in% toupper(missVars)) { - return(list(status = -1, msg = "\nYou have specified an algebraic model, which requires a variable named 'V'\n")) - } - missVarValues <- paste(missVars, "=0", sep = "") - if (length(missVarValues) > 0) svardef <- c(svardef, missVarValues) - svardef <- svardef[svardef != ""] - # add new secondary variables that won't be estimated - secVarNames <- c(secVarNames, missVars) - secVarNames <- secVarNames[secVarNames != ""] - } else { - missVars <- NA - } - } else { - if (any(is.na(matchVars))) { - missVars <- reqVars[is.na(matchVars)] - } else { - missVars <- NA - } + } + + # extract bolus inputs and create bolus block, then remove bolus[x] from equations + bolus <- purrr::map(blocks$eqn, ~ stringr::str_extract_all(.x, regex("B[\\[\\(]\\d+|BOL[\\[\\(]\\d+|BOLUS[\\[\\(]\\d+", ignore_case = TRUE), simplify = FALSE)) + blocks$bolus <- purrr::imap(bolus, \(x, idx){ + if (length(x[[1]]) > 0) { + paste0("NBCOMP(", stringr::str_extract(x[[1]], "\\d+$"), ") = ", idx) } - - # extract bolus inputs and create bolus block, then remove bolus[x] from equations - bolus <- purrr::map(blocks$eqn, ~ stringr::str_extract_all(.x, regex("B[\\[\\(]\\d+|BOL[\\[\\(]\\d+|BOLUS[\\[\\(]\\d+", ignore_case = TRUE), simplify = FALSE)) - blocks$bolus <- purrr::imap(bolus, \(x, idx){ - if (length(x[[1]]) > 0) { - paste0("NBCOMP(", stringr::str_extract(x[[1]], "\\d+$"), ") = ", idx) - } - }) %>% unlist() - blocks$eqn <- purrr::map(blocks$eqn, \(x) stringr::str_replace_all(x, regex("(\\+*|-*|\\**)\\s*B[\\[\\(]\\d+[\\]\\)]|(\\+*|-*|\\**)\\s*BOL[\\[\\(]\\d+[\\]\\)]|(\\+*|-*|\\**)\\s*BOLUS[\\[\\(]\\d+[\\]\\)]", ignore_case = TRUE), "")) %>% + }) %>% unlist() + blocks$eqn <- purrr::map(blocks$eqn, \(x) stringr::str_replace_all(x, regex("(\\+*|-*|\\**)\\s*B[\\[\\(]\\d+[\\]\\)]|(\\+*|-*|\\**)\\s*BOL[\\[\\(]\\d+[\\]\\)]|(\\+*|-*|\\**)\\s*BOLUS[\\[\\(]\\d+[\\]\\)]", ignore_case = TRUE), "")) %>% unlist() - - # replace R[x] or R(x) with RATEIV(x) - blocks$eqn <- purrr::map(blocks$eqn, \(x) stringr::str_replace_all(x, regex("R[\\[\\(](\\d+)[\\]\\)]", ignore_case = TRUE), "RATEIV\\(\\1\\)")) %>% + + # replace R[x] or R(x) with RATEIV(x) + blocks$eqn <- purrr::map(blocks$eqn, \(x) stringr::str_replace_all(x, regex("R[\\[\\(](\\d+)[\\]\\)]", ignore_case = TRUE), "RATEIV\\(\\1\\)")) %>% unlist() - - # get number of equations and verify with data file - # find statements with Y(digit) or Y[digit] - outputLines <- grep("Y\\([[:digit:]]+\\)|Y\\[[[:digit:]]+\\]", blocks$output, ignore.case = T) - if (length(outputLines) == 0) { - return(list(status = -1, msg = "\nYou must have at least one output equation of the form 'Y[1] = ...'\n")) - } - # extract numbers - outputStatements <- sapply(blocks$output[outputLines], function(x) strparse("Y\\([[:digit:]]+\\)|Y\\[[[:digit:]]+\\]", x)) - outputNumbers <- sapply(outputStatements, function(x) strparse("[[:digit:]]", x)) - # get max number - modelnumeqt <- max(as.numeric(outputNumbers)) - if (modelnumeqt != engine$numeqt) { - return(list(status = -1, msg = "\nThe number of output equations in the model file\ndoes not match the maximum value of outeq in your datafile.\n")) - } - - # remove leading ampersands from getfa, getix, gettlag if present - oldContLines <- grep("^\\+", c(blocks$f, blocks$ini, blocks$lag)) - if (length(oldContLines > 0)) { - return(list(status = -1, msg = "\nThe model file format has changed. Please replace '+' with '&' in all continuation lines.\n")) - } - if (length(grep("^&", blocks$f) > 0)) blocks$f <- gsub("^&", "", blocks$f) - if (length(grep("^&", blocks$ini) > 0)) blocks$ini <- gsub("^&", "", blocks$ini) - if (length(grep("^&", blocks$lag) > 0)) blocks$lag <- gsub("^&", "", blocks$lag) - - # variable declarations for fortran and make sure not >maxwidth characters - if (secVarNames[1] != "") { - vardec <- paste("REAL*8 ", paste(blocks$primVar, collapse = ","), ",", paste(secVarNames, collapse = ","), sep = "") - } else { - vardec <- paste("REAL*8 ", paste(blocks$primVar, collapse = ","), sep = "") - } - if (blocks$covar[1] != "") { - vardec <- paste(vardec, ",", paste(blocks$covar, collapse = ","), sep = "") - } - if (nchar(vardec) > maxwidth) { - vardec <- paste(unlist(strsplit(vardec, ",")), collapse = ",\n & ") - } - - # error - blocks$error <- tolower(gsub("[[:space:]]", "", blocks$error)) - # check to make sure coefficient lines are the same number as outputs - nErrCoeff <- length(blocks$error) - 1 - if (nErrCoeff != modelnumeqt) { - return(list(status = -1, msg = paste("\nThere ", c("is", "are")[1 + as.numeric(nErrCoeff > 1)], " ", + + # get number of equations and verify with data file + # find statements with Y(digit) or Y[digit] + outputLines <- grep("Y\\([[:digit:]]+\\)|Y\\[[[:digit:]]+\\]", blocks$output, ignore.case = T) + if (length(outputLines) == 0) { + return(list(status = -1, msg = "\nYou must have at least one output equation of the form 'Y[1] = ...'\n")) + } + # extract numbers + outputStatements <- sapply(blocks$output[outputLines], function(x) strparse("Y\\([[:digit:]]+\\)|Y\\[[[:digit:]]+\\]", x)) + outputNumbers <- sapply(outputStatements, function(x) strparse("[[:digit:]]", x)) + # get max number + modelnumeqt <- max(as.numeric(outputNumbers)) + if (modelnumeqt != engine$numeqt) { + return(list(status = -1, msg = "\nThe number of output equations in the model file\ndoes not match the maximum value of outeq in your datafile.\n")) + } + + # remove leading ampersands from getfa, getix, gettlag if present + oldContLines <- grep("^\\+", c(blocks$f, blocks$ini, blocks$lag)) + if (length(oldContLines > 0)) { + return(list(status = -1, msg = "\nThe model file format has changed. Please replace '+' with '&' in all continuation lines.\n")) + } + if (length(grep("^&", blocks$f) > 0)) blocks$f <- gsub("^&", "", blocks$f) + if (length(grep("^&", blocks$ini) > 0)) blocks$ini <- gsub("^&", "", blocks$ini) + if (length(grep("^&", blocks$lag) > 0)) blocks$lag <- gsub("^&", "", blocks$lag) + + # variable declarations for fortran and make sure not >maxwidth characters + if (secVarNames[1] != "") { + vardec <- paste("REAL*8 ", paste(blocks$primVar, collapse = ","), ",", paste(secVarNames, collapse = ","), sep = "") + } else { + vardec <- paste("REAL*8 ", paste(blocks$primVar, collapse = ","), sep = "") + } + if (blocks$covar[1] != "") { + vardec <- paste(vardec, ",", paste(blocks$covar, collapse = ","), sep = "") + } + if (nchar(vardec) > maxwidth) { + vardec <- paste(unlist(strsplit(vardec, ",")), collapse = ",\n & ") + } + + # error + blocks$error <- tolower(gsub("[[:space:]]", "", blocks$error)) + # check to make sure coefficient lines are the same number as outputs + nErrCoeff <- length(blocks$error) - 1 + if (nErrCoeff != modelnumeqt) { + return(list(status = -1, msg = paste("\nThere ", c("is", "are")[1 + as.numeric(nErrCoeff > 1)], " ", nErrCoeff, c(" line", " lines")[1 + as.numeric(nErrCoeff > 1)], " of error coefficients in the model file, but ", modelnumeqt, " output ", c("equation", "equations")[1 + as.numeric(modelnumeqt > 1)], @@ -619,7 +620,7 @@ checkSymmetry = TRUE) { fixed <- grep("!", blocks$error[gamlam[1]]) ierr <- unlist(strsplit(blocks$error[gamlam[1]], "=")) ierrtype <- gsub("[[:space:]]", "", tolower(substr(ierr[1], 1, 1))) - + # NPAG error parameters # IERRMOD # 1 SD WITH GAMMA(IEQ) FIXED @@ -632,7 +633,7 @@ checkSymmetry = TRUE) { # 2 IF ONE SET OF ABOVE Cs USED FOR ALL PATIENTS; # 1 IF Cs ALREADY IN PATIENT FILES WILL BE USED; IF A # PATIENT HAS NO C'S, THEN POPULATION C'S WILL BE USED. - + if (engine$alg == "NP") { if (length(fixed) > 0) { # gamma is fixed (error for lambda) @@ -667,7 +668,7 @@ checkSymmetry = TRUE) { asserr <- paste(gsub("!", "", asserr), collapse = "\n") # clean up asserr iass <- paste(iass, collapse = " ") # clean up iass } - + # IT2B error parameters # IERRMOD # 1 IF GAMMA(IEQ) IS TO REMAIN 1.0 THROUGHOUT THE ANALYSIS; @@ -680,7 +681,7 @@ checkSymmetry = TRUE) { # 2 IF ONE SET OF ABOVE Cs USED FOR ALL PATIENTS; # 1 IF Cs ALREADY IN PATIENT FILES WILL BE USED; IF A # PATIENT HAS NO C'S, THEN POPULATION C'S WILL BE USED. - + # IQVAL # 0 IF OUTPUT EQ. HAS ITS Cs ENTERED BY USER (NOT # ESTIMATED BY assbigxx.exe) AND IERRTYPE(IEQ) = 1 @@ -688,7 +689,7 @@ checkSymmetry = TRUE) { # ESTIMATED BY assbigxx.exe) AND IERRTYPE(IEQ) = 0 # 4 IF OUTPUT EQ. HAD ITS Cs ESTIMATED PREVIOUSLY # BY assbigxx.exe. - + if (engine$alg == "IT") { if (ierrtype == "l") { return(list(status = -1, msg = "\nLambda is not currently implemented in IT2B\nPlease correct the error block in your model file.\n")) @@ -730,11 +731,11 @@ checkSymmetry = TRUE) { return(list(status = -1, msg = "Please specify a gamma or lambda error model in your\nmodel file error block.")) } } - - - - - + + + + + # write report if (!quiet) { cat(paste("\nModel solver mode: ", switch(letters[N + 2], @@ -777,27 +778,27 @@ checkSymmetry = TRUE) { cat(paste("\nCovariates used in model file: ", c(paste(blocks$covar, collapse = ", "), "None")[1 + as.numeric(blocks$covar[1] == "")])) cat(paste("\nSecondary Variables: ", paste(secVarNames, collapse = ", "), sep = "")) cat(paste("\nModel conditions: ", c("bioavailability term defined, ", "no bioavailability term defined, ")[1 + as.numeric(blocks$f[1] == "")], - c("initial conditions are not zero, ", "initial conditions are zero, ")[1 + as.numeric(blocks$ini[1] == "")], - c("lag term defined", "no lag term defined")[1 + as.numeric(blocks$lag[1] == "")], - sep = "" - )) - if (engine$alg != "SIM") cat(paste("\nNumber of cycles to run:", engine$cycles)) - cat("\n\n") -} -# end if quiet -if (getPMoptions("backend") == "rust") { - model_file <- "main.rs" -} else { - model_file <- modelFor -} + c("initial conditions are not zero, ", "initial conditions are zero, ")[1 + as.numeric(blocks$ini[1] == "")], + c("lag term defined", "no lag term defined")[1 + as.numeric(blocks$lag[1] == "")], + sep = "" + )) + if (engine$alg != "SIM") cat(paste("\nNumber of cycles to run:", engine$cycles)) + cat("\n\n") + } + # end if quiet + if (getPMoptions("backend") == "rust") { + model_file <- "main.rs" + } else { + model_file <- modelFor + } -ret_list <- list( - status = 1, N = N, ptype = ptype, model = model_file, - ctype = ctype, nvar = nvar, nofix = nofix, nranfix = nranfix, - valfix = valfix, ab = ab.df, indpts = indpts, - asserr = asserr, blocks = blocks -) -return(ret_list) + ret_list <- list( + status = 1, N = N, ptype = ptype, model = model_file, + ctype = ctype, nvar = nvar, nofix = nofix, nranfix = nranfix, + valfix = valfix, ab = ab.df, indpts = indpts, + asserr = asserr, blocks = blocks + ) + return(ret_list) } # end makeModel function @@ -816,7 +817,7 @@ endNicely <- function(message, model = -99, data = -99) { "it2b*.*", "itas*.*", "it_prep*", "it_run*", "itlog.txt", "ITcontrol", "itscript*", "instr.inx", "assdriv.f", "err_prep*", "err_run*", "ERRcontrol", "errscript*", "errlog.txt" )) - + if (length(cleanUp) > 0) file.remove(cleanUp) stop(message, call. = F) } @@ -836,8 +837,8 @@ var.wt <- function(x, w, na.rm = FALSE) { # weighted t test weighted.t.test <- function(x, w, mu, conf.level = 0.95, alternative = "two.sided", na.rm = TRUE) { if (!missing(conf.level) & - (length(conf.level) != 1 || !is.finite(conf.level) || - conf.level < 0 || conf.level > 1)) { + (length(conf.level) != 1 || !is.finite(conf.level) || + conf.level < 0 || conf.level > 1)) { stop("'conf.level' must be a single number between 0 and 1") } # see if x came from PM_op object @@ -846,29 +847,29 @@ weighted.t.test <- function(x, w, mu, conf.level = 0.95, alternative = "two.side x <- x$d mu <- 0 } - + if (na.rm) { w <- w[i <- !is.na(x)] x <- x[i] } - + # to achieve consistent behavior in loops, return NA-structure in case of complete missings if (sum(is.na(x)) == length(x)) { return(list(estimate = NA, se = NA, conf.int = NA, statistic = NA, df = NA, p.value = NA)) } - + # if only one value is present: this is the best estimate, no significance test provided if (sum(!is.na(x)) == 1) { warning("Warning weighted.t.test: only one value provided; this value is returned without test of significance!", call. = FALSE) return(list(estimate = x[which(!is.na(x))], se = NA, conf.int = NA, statistic = NA, df = NA, p.value = NA)) } - + x.w <- weighted.mean(x, w, na.rm = na.rm) var.w <- var.wt(x, w, na.rm = na.rm) df <- length(x) - 1 t.value <- sqrt(length(x)) * ((x.w - mu) / sqrt(var.w)) se <- sqrt(var.w) / sqrt(length(x)) - + if (alternative == "less") { pval <- pt(t.value, df) cint <- c(-Inf, x.w + se * qt(conf.level, df)) @@ -880,7 +881,7 @@ weighted.t.test <- function(x, w, mu, conf.level = 0.95, alternative = "two.side alpha <- 1 - conf.level cint <- x.w + se * qt(1 - alpha / 2, df) * c(-1, 1) } - + names(t.value) <- "t" return(list(estimate = x.w, se = se, conf.int = cint, statistic = t.value, df = df, p.value = pval)) } @@ -907,13 +908,13 @@ FileExists <- function(filename) { while (!file.exists(filename)) { # oops, filename doesn't exist cat(paste0(filename, " does not exist in ", getwd(), ".\n")) filename <- tryCatch(readline("Enter another filename or 'ESC' to quit: \n"), - interrupt = function(e) { - stop("No filename. Function aborted.\n", call. = F) - } - ) + interrupt = function(e) { + stop("No filename. Function aborted.\n", call. = F) + } + ) + } } -} -return(filename) + return(filename) } @@ -921,11 +922,11 @@ return(filename) getOS <- function() { OS <- switch(Sys.info()[1], - Darwin = 1, - Windows = 2, - Linux = 3 -) -return(OS) + Darwin = 1, + Windows = 2, + Linux = 3 + ) + return(OS) } # This might be a solution: https://community.rstudio.com/t/how-to-get-rstudio-ide-to-use-the-correct-terminal-path-in-mac-os-x/131528/3 @@ -997,7 +998,7 @@ getCov <- function(mdata) { covstart <- NA covend <- NA } - + return(list(ncov = ncov, covnames = covnames, covstart = covstart, covend = covend)) } @@ -1046,11 +1047,11 @@ checkRequiredPackages <- function(pkg, repos = "CRAN", quietly = TRUE) { } # nope, still didn't install } } - + msg <- pkg %>% - map_chr(managePkgs) %>% - keep(~ . != "ok") - + map_chr(managePkgs) %>% + keep(~ . != "ok") + if (length(msg) > 0) { if (!quietly) { cat( @@ -1106,8 +1107,8 @@ obsStatus <- function(data) { # import recycled text into documentation template <- function(name) { insert <- readLines(paste0("man-roxygen/", name, ".R")) %>% - stringr::str_replace("#' ", "") %>% - stringr::str_replace("
", " \n") + stringr::str_replace("#' ", "") %>% + stringr::str_replace("
", " \n") insert <- c(insert, " \n") insert <- paste(insert, collapse = " ") return(insert) @@ -1120,122 +1121,124 @@ template <- function(name) { # modified from Hmisc functions -wtd.table <- function(x, weights = NULL, - type = c("list", "table"), - normwt = TRUE, - na.rm = TRUE) { - type <- match.arg(type) - if (!length(weights)) { - weights <- rep(1, length(x)) - } - isdate <- lubridate::is.Date(x) - ax <- attributes(x) - ax$names <- NULL - if (is.character(x)) { - x <- as.factor(x) - } - lev <- levels(x) - x <- unclass(x) - if (na.rm) { - s <- !is.na(x + weights) - x <- x[s, drop = FALSE] - weights <- weights[s] - } - n <- length(x) - if (normwt) { - weights <- weights * length(x) / sum(weights) - } - i <- order(x) - x <- x[i] - weights <- weights[i] - if (anyDuplicated(x)) { - weights <- tapply(weights, x, sum) - if (length(lev)) { - levused <- lev[sort(unique(x))] - if ((length(weights) > length(levused)) && any(is.na(weights))) { - weights <- weights[!is.na(weights)] - } - if (length(weights) != length(levused)) { - stop("program logic error") - } - names(weights) <- levused +wtd.table <- function( + x, weights = NULL, + type = c("list", "table"), + normwt = TRUE, + na.rm = TRUE) { + type <- match.arg(type) + if (!length(weights)) { + weights <- rep(1, length(x)) + } + isdate <- lubridate::is.Date(x) + ax <- attributes(x) + ax$names <- NULL + if (is.character(x)) { + x <- as.factor(x) + } + lev <- levels(x) + x <- unclass(x) + if (na.rm) { + s <- !is.na(x + weights) + x <- x[s, drop = FALSE] + weights <- weights[s] + } + n <- length(x) + if (normwt) { + weights <- weights * length(x) / sum(weights) + } + i <- order(x) + x <- x[i] + weights <- weights[i] + if (anyDuplicated(x)) { + weights <- tapply(weights, x, sum) + if (length(lev)) { + levused <- lev[sort(unique(x))] + if ((length(weights) > length(levused)) && any(is.na(weights))) { + weights <- weights[!is.na(weights)] } - if (!length(names(weights))) { + if (length(weights) != length(levused)) { stop("program logic error") } - if (type == "table") { - return(weights) - } - x <- all.is.numeric(names(weights), "vector") - if (isdate) { - attributes(x) <- c(attributes(x), ax) - } - names(weights) <- NULL - return(list(x = x, sum.of.weights = weights)) + names(weights) <- levused + } + if (!length(names(weights))) { + stop("program logic error") } - xx <- x + if (type == "table") { + return(weights) + } + x <- all.is.numeric(names(weights), "vector") if (isdate) { - attributes(xx) <- c(attributes(xx), ax) + attributes(x) <- c(attributes(x), ax) } - if (type == "list") { - list(x = if (length(lev)) lev[x] else xx, sum.of.weights = weights) + names(weights) <- NULL + return(list(x = x, sum.of.weights = weights)) + } + xx <- x + if (isdate) { + attributes(xx) <- c(attributes(xx), ax) + } + if (type == "list") { + list(x = if (length(lev)) lev[x] else xx, sum.of.weights = weights) + } else { + names(weights) <- if (length(lev)) { + lev[x] } else { - names(weights) <- if (length(lev)) { - lev[x] - } else { - xx - } - weights + xx } + weights } - - wtd.mean <- function(x, weights = NULL, normwt = "ignored", na.rm = TRUE) { - if (!length(weights)) { - return(mean(x, na.rm = na.rm)) - } - if (na.rm) { - s <- !is.na(x + weights) - x <- x[s] - weights <- weights[s] - } - sum(weights * x) / sum(weights) - } - - - wtd.quantile <- function(x, weights = NULL, probs = c(0, 0.25, 0.5, 0.75, 1), - normwt = TRUE, - na.rm = TRUE) { - if (!length(weights)) { - return(quantile(x, probs = probs, na.rm = na.rm)) - } - - if (any(probs < 0 | probs > 1)) { - cli::cli_abort("Probabilities must be between 0 and 1 inclusive") - } - nams <- paste(format(round(probs * 100, if (length(probs) > +} + +wtd.mean <- function(x, weights = NULL, normwt = "ignored", na.rm = TRUE) { + if (!length(weights)) { + return(mean(x, na.rm = na.rm)) + } + if (na.rm) { + s <- !is.na(x + weights) + x <- x[s] + weights <- weights[s] + } + sum(weights * x) / sum(weights) +} + + +wtd.quantile <- function( + x, weights = NULL, probs = c(0, 0.25, 0.5, 0.75, 1), + normwt = TRUE, + na.rm = TRUE) { + if (!length(weights)) { + return(quantile(x, probs = probs, na.rm = na.rm)) + } + + if (any(probs < 0 | probs > 1)) { + cli::cli_abort("Probabilities must be between 0 and 1 inclusive") + } + nams <- paste(format(round(probs * 100, if (length(probs) > 1) { - 2 - log10(diff(range(probs))) - } else { - 2 - })), "%", sep = "") - i <- is.na(weights) | weights == 0 - if (any(i)) { - x <- x[!i] - weights <- weights[!i] - } - - w <- wtd.table(x, weights, - na.rm = na.rm, normwt = normwt, - type = "list" - ) - x <- w$x - wts <- w$sum.of.weights - n <- sum(wts) - order <- 1 + (n - 1) * probs - low <- pmax(floor(order), 1) - high <- pmin(low + 1, n) - order <- order %% 1 - allq <- approx(cumsum(wts), x, + 2 - log10(diff(range(probs))) + } else { + 2 + })), "%", sep = "") + i <- is.na(weights) | weights == 0 + if (any(i)) { + x <- x[!i] + weights <- weights[!i] + } + + w <- wtd.table(x, weights, + na.rm = na.rm, normwt = normwt, + type = "list" + ) + x <- w$x + wts <- w$sum.of.weights + n <- sum(wts) + order <- 1 + (n - 1) * probs + low <- pmax(floor(order), 1) + high <- pmin(low + 1, n) + order <- order %% 1 + allq <- approx(cumsum(wts), x, xout = c(low, high), method = "constant", f = 1, rule = 2 )$y @@ -1245,310 +1248,315 @@ wtd.table <- function(x, weights = NULL, return(quantiles) } -wtd.var <- function(x, weights = NULL, - normwt = TRUE, - na.rm = TRUE, - method = c("unbiased", "ML")) { - if (any(weights == 1)) { - return(0) - } - - method <- match.arg(method) - if (!length(weights)) { - if (na.rm) { - x <- x[!is.na(x)] - } - return(var(x)) - } +wtd.var <- function( + x, weights = NULL, + normwt = TRUE, + na.rm = TRUE, + method = c("unbiased", "ML")) { + if (any(weights == 1)) { + return(0) + } + + method <- match.arg(method) + if (!length(weights)) { if (na.rm) { - s <- !is.na(x + weights) - x <- x[s] - weights <- weights[s] - } - if (normwt) { - weights <- weights * length(x) / sum(weights) - } - if (normwt || method == "ML") { - return(as.numeric(stats::cov.wt(cbind(x), weights, method = method)$cov)) + x <- x[!is.na(x)] } - sw <- sum(weights) - if (sw <= 1) { - cli::cli_warn("only one effective observation; variance estimate undefined") - } - xbar <- sum(weights * x) / sw - sum(weights * ((x - xbar)^2)) / (sw - 1) - } - - - - # Check if all values numeric --------------------------------------------- - - #' @title Check if all values are numeric - #' @description - #' `r lifecycle::badge("stable")` - #' Checks if all values in a vector are numeric. - #' @details - #' The function checks if all values in a vector are numeric. - #' It can be used to check if a vector contains only numeric values. - #' It can also be used to check if a vector contains any non-numeric values. - #' @param x A vector to check. - #' @param what A character string indicating what to return. - #' Can be "test", "vector", or "nonnum". - #' The default is "test". - #' @param extras A character vector of extra values to exclude from the check. - #' The default is c(".", "NA"). - #' @return A logical value indicating if all values are numeric. - #' If `what` is "vector", a numeric vector is returned. - #' If `what` is "nonnum", a character vector of non-numeric values is returned. - #' If `what` is "test", a logical value is returned. - #' @export - #' @examples - #' \dontrun{ - #' all.is.numeric(c("1", "2", "3")) - #' all.is.numeric(c("1", "2", "a")) - #' all.is.numeric(c("1", "2", "3"), what = "vector") - #' all.is.numeric(c("1", "2", "a"), what = "nonnum") - #' } - all.is.numeric <- function(x, what = c("test", "vector", "nonnum"), extras = c( - ".", - "NA" - )) { - what <- match.arg(what) - x <- sub("[[:space:]]+$", "", x) - x <- sub("^[[:space:]]+", "", x) - xs <- x[!x %in% c("", extras)] - if (!length(xs) || all(is.na(x))) { - return(switch(what, - test = FALSE, - vector = x, - nonnum = x[0] - )) - } - isnon <- suppressWarnings(!is.na(xs) & is.na(as.numeric(xs))) - isnum <- !any(isnon) - switch(what, - test = isnum, - vector = if (isnum) suppressWarnings(as.numeric(x)) else x, - nonnum = xs[isnon] - ) + return(var(x)) } - - - - - # Save Flextable --------------------------------------------------------- - - #' @title Save a flextable object to a file - #' @description - #' `r lifecycle::badge("stable")` - #' Saves flextable objects to a file based on the `file` attribute - #' in the object, set when the flextable generator function is called. - #' Allowable file types are 'docx', 'pptx', 'html', 'png', and 'svg'. - #' @param x A [flextable::flextable] object. - #' @return A message indicating the file was saved. - #' @export - #' @keywords internal - - save_flextable <- function(x) { - # check if x is a flextable - if (!inherits(x, "flextable")) { - cli::cli_abort("{.arg x} must be a flextable object.") - } - - file <- attr(x, "file") - if (!is.null(file)) { - # get file extension - ext <- stringr::str_match(file, "\\.(.*)$")[2] - - # save flextable based on file extension - if (ext %in% c("docx", "doc")) { - flextable::save_as_docx(x, path = file) - } else if (ext %in% c("pptx", "ppt")) { - flextable::save_as_pptx(x, path = file) - } else if (ext %in% c("html", "htm")) { - flextable::save_as_html(x, path = file) - } else if (ext %in% c("png", "svg")) { - flextable::save_as_image(x, path = file) - } else { - cli::cli_abort("File type not recognized. Choose from 'docx', 'pptx', 'html', 'png', or 'svg'.") - } - - cli::cli_inform(paste("The file", file, "was saved to", getwd(), ".")) + if (na.rm) { + s <- !is.na(x + weights) + x <- x[s] + weights <- weights[s] + } + if (normwt) { + weights <- weights * length(x) / sum(weights) + } + if (normwt || method == "ML") { + return(as.numeric(stats::cov.wt(cbind(x), weights, method = method)$cov)) + } + sw <- sum(weights) + if (sw <= 1) { + cli::cli_warn("only one effective observation; variance estimate undefined") + } + xbar <- sum(weights * x) / sw + sum(weights * ((x - xbar)^2)) / (sw - 1) +} + + + +# Check if all values numeric --------------------------------------------- + +#' @title Check if all values are numeric +#' @description +#' `r lifecycle::badge("stable")` +#' Checks if all values in a vector are numeric. +#' @details +#' The function checks if all values in a vector are numeric. +#' It can be used to check if a vector contains only numeric values. +#' It can also be used to check if a vector contains any non-numeric values. +#' @param x A vector to check. +#' @param what A character string indicating what to return. +#' Can be "test", "vector", or "nonnum". +#' The default is "test". +#' @param extras A character vector of extra values to exclude from the check. +#' The default is c(".", "NA"). +#' @return A logical value indicating if all values are numeric. +#' If `what` is "vector", a numeric vector is returned. +#' If `what` is "nonnum", a character vector of non-numeric values is returned. +#' If `what` is "test", a logical value is returned. +#' @export +#' @examples +#' \dontrun{ +#' all.is.numeric(c("1", "2", "3")) +#' all.is.numeric(c("1", "2", "a")) +#' all.is.numeric(c("1", "2", "3"), what = "vector") +#' all.is.numeric(c("1", "2", "a"), what = "nonnum") +#' } +all.is.numeric <- function(x, what = c("test", "vector", "nonnum"), extras = c( + ".", + "NA" + )) { + what <- match.arg(what) + x <- sub("[[:space:]]+$", "", x) + x <- sub("^[[:space:]]+", "", x) + xs <- x[!x %in% c("", extras)] + if (!length(xs) || all(is.na(x))) { + return(switch(what, + test = FALSE, + vector = x, + nonnum = x[0] + )) + } + isnon <- suppressWarnings(!is.na(xs) & is.na(as.numeric(xs))) + isnum <- !any(isnon) + switch(what, + test = isnum, + vector = if (isnum) suppressWarnings(as.numeric(x)) else x, + nonnum = xs[isnon] + ) +} + + + + +# Save Flextable --------------------------------------------------------- + +#' @title Save a flextable object to a file +#' @description +#' `r lifecycle::badge("stable")` +#' Saves flextable objects to a file based on the `file` attribute +#' in the object, set when the flextable generator function is called. +#' Allowable file types are 'docx', 'pptx', 'html', 'png', and 'svg'. +#' @param x A [flextable::flextable] object. +#' @return A message indicating the file was saved. +#' @export +#' @keywords internal + +save_flextable <- function(x) { + # check if x is a flextable + if (!inherits(x, "flextable")) { + cli::cli_abort("{.arg x} must be a flextable object.") + } + + file <- attr(x, "file") + if (!is.null(file)) { + # get file extension + ext <- stringr::str_match(file, "\\.(.*)$")[2] + + # save flextable based on file extension + if (ext %in% c("docx", "doc")) { + flextable::save_as_docx(x, path = file) + } else if (ext %in% c("pptx", "ppt")) { + flextable::save_as_pptx(x, path = file) + } else if (ext %in% c("html", "htm")) { + flextable::save_as_html(x, path = file) + } else if (ext %in% c("png", "svg")) { + flextable::save_as_image(x, path = file) + } else { + cli::cli_abort("File type not recognized. Choose from 'docx', 'pptx', 'html', 'png', or 'svg'.") } - - return(invisible(x)) - } - - - - # Ask with warning -------------------------------------------------------- - - #' @title Ask with warning - #' @description Get user input in warning situation - #' @details Combines the [cli::cli_text] function with [readline]. - #' @param text The warning text. - #' @param prompt The prompt preceding user input. Default is ">>". - #' @param ... Additional parameters which could be passed to [cli::cli_text]. - #' @return The value of the user response - #' @export - #' @keywords internal - #' - cli_ask <- function(text, prompt = ">> ", ...) { - cli::cli_text(text, ...) - ans <- readline(prompt = prompt) - return(ans) - } - - - # Function to Character --------------------------------------------------- - - #' @title Convert a function to a character string - #' @keywords internal - func_to_char <- function(fun){ - deparse(fun, width.cutoff = 500L) %>% + + cli::cli_inform(paste("The file", file, "was saved to", getwd(), ".")) + } + + return(invisible(x)) +} + + + +# Ask with warning -------------------------------------------------------- + +#' @title Ask with warning +#' @description Get user input in warning situation +#' @details Combines the [cli::cli_text] function with [readline]. +#' @param text The warning text. +#' @param prompt The prompt preceding user input. Default is ">>". +#' @param ... Additional parameters which could be passed to [cli::cli_text]. +#' @return The value of the user response +#' @export +#' @keywords internal +#' +cli_ask <- function(text, prompt = ">> ", ...) { + cli::cli_text(text, ...) + ans <- readline(prompt = prompt) + return(ans) +} + + +# Function to Character --------------------------------------------------- + +#' @title Convert a function to a character string +#' @keywords internal +func_to_char <- function(fun) { + deparse(fun, width.cutoff = 500L) %>% stringr::str_trim("left") %>% purrr::discard(\(x) stringr::str_detect(x, "function|\\{|\\}")) - } - - - # Round to x digits --------------------------------------------------- - - #' @title Round to x digits - #' @description - #' `r lifecycle::badge("stable")` - #' Rounds a numeric value to a specified number of digits for display in flextables and plots. - #' @details Uses [base::format] and [base::round] to round a numeric value to a specified number of digits. - #' @param x A numeric value to be rounded. - #' @param digits The number of digits to round to. Default is set using [setPMoptions]. - #' @return A character string representing the rounded value with the specified number of digits. - #' @export - #' @keywords internal - - round2 <- function(x, digits = getPMoptions("digits")) { - format(round(x, digits), nsmall = digits) - } - - - # Print data frame in CLI format ------------------------------------------ - #' @title Print data frame in CLI format - #' @description - #' `r lifecycle::badge("stable")` - #' Prints a data frame in a format suitable for the command line interface (CLI). - #' @details - #' Uses [dplyr::mutate] to convert all columns to character, rounds numeric values using [round2], - #' and formats the output using [knitr::kable] for a simple table format. - #' The function replaces spaces with non-breaking spaces for better alignment in the CLI. - #' @param df A data frame to be printed. - #' @return A formatted text output of the data frame. - #' @export - #' @keywords internal - cli_df <- function(df) { - - highlight <- attr(df, "highlight") # get columns to highlight minimums from attributes - - # Convert all columns to character for uniform formatting - df_chr <- df %>% mutate(across(where(is.double), ~round2(.x))) %>% - mutate(across(everything(), ~as.character(.x, stringsAsFactors = FALSE))) - - - if (highlight){ # highlight minimums in requested columns - # first replace minima with special formatting - # mins <- df %>% summarize(across(c(-run, -nvar, -converged, -pval, -best), ~round2(min(.x, na.rm = TRUE)))) # get minima for each column - mins <- df %>% summarize(across(c(-run, -nvar, -converged, -pval, -best), ~ which(.x == min(.x, na.rm = TRUE)))) %>% unlist() # get minima for each column - - best <- df %>% summarize(across(best, ~ which(.x == max(.x, na.rm = TRUE)))) %>% unlist() # get best for best column - - # create table to get the spacing - df_tab <- knitr::kable(df_chr, format = "simple") - - # rebuild the data frame - df2 <- map_vec(df_tab, \(x) str_split(x, "(?<=\\s)(?=\\S)")) - df2 <- as.data.frame(do.call(rbind, df2)) - - # replace minima with highlighted versions - # first 2 rows are headers and spacers, so need to add 2 to the mins row index - for (p in 1:length(mins)){ - df2[mins[p]+2, p+3] <- stringr::str_replace_all(df2[mins[p]+2, p+3], "(\\d+(?:\\.\\d+)?)(\\s+)", "{.red \\1}\\2") - } +} + - # for(p in 1:length(mins)){ - # df2[, p+3] <- stringr::str_replace_all(df2[, p+3], as.character(mins[p]), paste0("{.strong ", as.character(mins[p]), "}")) - # } - # df2$V18 <- stringr::str_replace(df2$V18, as.character(best), paste0("{.red ", as.character(best), "}")) - df2$V17[best+2] <- stringr::str_replace(df2$V17[best+2], "(\\d+(?:\\.\\d+)?)(\\s+)", "{.red \\1}\\2") - - # print header - header <- df2[1,] %>% stringr::str_replace_all(" ", "\u00A0" ) %>% paste(collapse = "") - cli::cli_text("{.strong {header}}") - cli::cli_div(theme = list(span.red = list(color = "red", "font-weight" = "bold"))) - - # replace ≥2 spaces with non-breaking spaces - for (i in 2:nrow(df2)) { - # m <- gregexpr("\\s{2,}", df_tab[i], perl = TRUE) - # regmatches(df_tab[i], m) <- lapply(regmatches(df_tab[i], m), function(ss) { - # vapply(ss, function(one) { - # paste0(rep("\u00A0", nchar(one)), collapse = "") - # }, character(1)) - # }) - # print each row - cli::cli_text(paste(df2[i,], collapse = "") %>% stringr::str_replace_all(" ", "\u00A0" ) %>% stringr::str_replace_all("strong\u00A0+", "strong ") %>% stringr::str_replace_all("red\u00A0+", "red ")) - } - cli::cli_end() - } else { # no highlighting - - # create table - df_tab <- knitr::kable(df_chr, format = "simple") - - # print header - header <- df_tab[1] %>% stringr::str_replace_all(" ", "\u00A0" ) - cli::cli_text("{.strong {header}}") +# Round to x digits --------------------------------------------------- +#' @title Round to x digits +#' @description +#' `r lifecycle::badge("stable")` +#' Rounds a numeric value to a specified number of digits for display in flextables and plots. +#' @details Uses [base::format] and [base::round] to round a numeric value to a specified number of digits. +#' @param x A numeric value to be rounded. +#' @param digits The number of digits to round to. Default is set using [setPMoptions]. +#' @return A character string representing the rounded value with the specified number of digits. +#' @export +#' @keywords internal + +round2 <- function(x, digits = getPMoptions("digits")) { + format(round(x, digits), nsmall = digits) +} + + +# Print data frame in CLI format ------------------------------------------ +#' @title Print data frame in CLI format +#' @description +#' `r lifecycle::badge("stable")` +#' Prints a data frame in a format suitable for the command line interface (CLI). +#' @details +#' Uses [dplyr::mutate] to convert all columns to character, rounds numeric values using [round2], +#' and formats the output using [knitr::kable] for a simple table format. +#' The function replaces spaces with non-breaking spaces for better alignment in the CLI. +#' @param df A data frame to be printed. +#' @return A formatted text output of the data frame. +#' @export +#' @keywords internal +cli_df <- function(df) { + highlight <- attr(df, "highlight") # get columns to highlight minimums from attributes + + # Convert all columns to character for uniform formatting + df_chr <- df %>% + mutate(across(where(is.double), ~ round2(.x))) %>% + mutate(across(everything(), ~ as.character(.x, stringsAsFactors = FALSE))) + + + if (highlight) { # highlight minimums in requested columns + # first replace minima with special formatting + # mins <- df %>% summarize(across(c(-run, -nvar, -converged, -pval, -best), ~round2(min(.x, na.rm = TRUE)))) # get minima for each column + mins <- df %>% + summarize(across(c(-run, -nvar, -converged, -pval, -best), ~ which(.x == min(.x, na.rm = TRUE)))) %>% + unlist() # get minima for each column + + best <- df %>% + summarize(across(best, ~ which(.x == max(.x, na.rm = TRUE)))) %>% + unlist() # get best for best column + + # create table to get the spacing + df_tab <- knitr::kable(df_chr, format = "simple") + + # rebuild the data frame + df2 <- map_vec(df_tab, \(x) str_split(x, "(?<=\\s)(?=\\S)")) + df2 <- as.data.frame(do.call(rbind, df2)) + + # replace minima with highlighted versions + # first 2 rows are headers and spacers, so need to add 2 to the mins row index + for (p in 1:length(mins)) { + df2[mins[p] + 2, p + 3] <- stringr::str_replace_all(df2[mins[p] + 2, p + 3], "(\\d+(?:\\.\\d+)?)(\\s+)", "{.red \\1}\\2") + } + + # for(p in 1:length(mins)){ + # df2[, p+3] <- stringr::str_replace_all(df2[, p+3], as.character(mins[p]), paste0("{.strong ", as.character(mins[p]), "}")) + # } + # df2$V18 <- stringr::str_replace(df2$V18, as.character(best), paste0("{.red ", as.character(best), "}")) + df2$V17[best + 2] <- stringr::str_replace(df2$V17[best + 2], "(\\d+(?:\\.\\d+)?)(\\s+)", "{.red \\1}\\2") + + # print header + header <- df2[1, ] %>% + stringr::str_replace_all(" ", "\u00A0") %>% + paste(collapse = "") + cli::cli_text("{.strong {header}}") + cli::cli_div(theme = list(span.red = list(color = "red", "font-weight" = "bold"))) + + # replace ≥2 spaces with non-breaking spaces + for (i in 2:nrow(df2)) { + # m <- gregexpr("\\s{2,}", df_tab[i], perl = TRUE) + # regmatches(df_tab[i], m) <- lapply(regmatches(df_tab[i], m), function(ss) { + # vapply(ss, function(one) { + # paste0(rep("\u00A0", nchar(one)), collapse = "") + # }, character(1)) + # }) # print each row - for (i in 2:length(df_tab)) { - cli::cli_text(df_tab[i] %>% stringr::str_replace_all(" ", "\u00A0" )) - } + cli::cli_text(paste(df2[i, ], collapse = "") %>% stringr::str_replace_all(" ", "\u00A0") %>% stringr::str_replace_all("strong\u00A0+", "strong ") %>% stringr::str_replace_all("red\u00A0+", "red ")) } - - } - - #' @title Convert correlation matrix to covariance matrix - #' @description - #' `r lifecycle::badge("stable")` - #' Converts a correlation matrix to a covariance matrix using standard deviations. - #' @details - #' Uses matrix multiplication to convert a correlation matrix to a covariance matrix. - #' @param cor A correlation matrix. - #' @param sd A vector of standard deviations corresponding to the variables in the correlation matrix. - #' @return A covariance matrix. - #' @export - #' @author Michael Neely - #' - cor2cov <- function(cor, sd){ - cov_matrix <- diag(sd) %*% cor %*% diag(sd) - return(cov_matrix) - } - - - #' @title Check if a matrix is positive definite - #' @description - #' `r lifecycle::badge("stable")` - #' Checks if a matrix is positive definite and attempts to fix it if necessary. - #' @param mat A covariance matrix to check. - #' @return A positive definite covariance matrix, 1 if aborting, or -1 if unable to fix - #' @export - #' @author Michael Neely - #' @keywords internal - pos_def <- function(mat, id, source){ - # check to make sure mat (within 15 sig digits, which is in file) is pos-def and fix if necessary - posdef <- rlang::try_fetch(eigen(signif(mat, 15)), + cli::cli_end() + } else { # no highlighting + + # create table + df_tab <- knitr::kable(df_chr, format = "simple") + + # print header + header <- df_tab[1] %>% stringr::str_replace_all(" ", "\u00A0") + cli::cli_text("{.strong {header}}") + + # print each row + for (i in 2:length(df_tab)) { + cli::cli_text(df_tab[i] %>% stringr::str_replace_all(" ", "\u00A0")) + } + } +} + +#' @title Convert correlation matrix to covariance matrix +#' @description +#' `r lifecycle::badge("stable")` +#' Converts a correlation matrix to a covariance matrix using standard deviations. +#' @details +#' Uses matrix multiplication to convert a correlation matrix to a covariance matrix. +#' @param cor A correlation matrix. +#' @param sd A vector of standard deviations corresponding to the variables in the correlation matrix. +#' @return A covariance matrix. +#' @export +#' @author Michael Neely +#' +cor2cov <- function(cor, sd) { + cov_matrix <- diag(sd) %*% cor %*% diag(sd) + return(cov_matrix) +} + + +#' @title Check if a matrix is positive definite +#' @description +#' `r lifecycle::badge("stable")` +#' Checks if a matrix is positive definite and attempts to fix it if necessary. +#' @param mat A covariance matrix to check. +#' @return A positive definite covariance matrix, 1 if aborting, or -1 if unable to fix +#' @export +#' @author Michael Neely +#' @keywords internal +pos_def <- function(mat, id, source) { + # check to make sure mat (within 15 sig digits, which is in file) is pos-def and fix if necessary + posdef <- rlang::try_fetch(eigen(signif(mat, 15)), error = function(e) { return(list(values = 0)) } ) ans <- NULL if (any(posdef$values < 0)) { - - mat_names <- dimnames(mat)[[1]] #store for later + mat_names <- dimnames(mat)[[1]] # store for later if (is.null(ans)) { cli::cli_alert_warning("Warning: your covariance matrix is not positive definite. This is typically due to small population size.\nChoose one of the following:\n1) end simulation\n2) fix covariances\n3) set covariances to 0\n ") ans <- readline("\n") @@ -1560,24 +1568,22 @@ wtd.var <- function(x, weights = NULL, if (ans == 2) { # eigen decomposition to fix the matrix for (j in 1:10) { # try up to 10 times - eps <- 1e-8 # threshold for small eigenvalues + eps <- 1e-8 # threshold for small eigenvalues eig <- eigen(mat) - eig$values[eig$values < eps] <- eps # threshold small eigenvalues + eig$values[eig$values < eps] <- eps # threshold small eigenvalues mat <- eig$vectors %*% diag(eig$values) %*% t(eig$vectors) - - + + posdef <- eigen(signif(mat, 15)) - + if (all(posdef$values >= 0)) { # success, break out of loop break } - if(j == 10) browser() + if (j == 10) browser() } posdef <- eigen(signif(mat, 15)) # last check if (any(posdef$values < 0)) { - return(-1) - } mat <- data.frame(mat) names(mat) <- mat_names @@ -1591,7 +1597,7 @@ wtd.var <- function(x, weights = NULL, mat <- mat2 } } - + return(mat) } @@ -1599,7 +1605,7 @@ wtd.var <- function(x, weights = NULL, #' @title Modify a list with another list, allowing NULL values #' @description #' `r lifecycle::badge("stable")` -#' Version of [utils::modifyList()] that works with lists which have unnamed elements. +#' Version of [utils::modifyList()] that works with lists which have unnamed elements. #' @param x A list to be modified. #' @param val A list of values to modify `x`. #' @param keep.null A logical value indicating whether to keep NULL values in `val`. @@ -1607,32 +1613,34 @@ wtd.var <- function(x, weights = NULL, #' @return A modified list, as in [utils::modifyList()]. #' @export #' @keywords internal -modifyList2 <- function (x, val, keep.null = FALSE) -{ +modifyList2 <- function(x, val, keep.null = FALSE) { stopifnot(is.list(x), is.list(val)) xnames <- names(x) vnames <- names(val) # handle unnamed lists - if(is.null(xnames)) xnames <- 1:length(x) - if(is.null(vnames)) vnames <- 1:length(val) + if (is.null(xnames)) xnames <- 1:length(x) + if (is.null(vnames)) vnames <- 1:length(val) # handle unnamed elements xnames <- ifelse(xnames == "", as.character(seq_along(xnames)), xnames) vnames <- ifelse(vnames == "", as.character(seq_along(vnames)), vnames) - + vnames <- vnames[nzchar(vnames)] if (keep.null) { for (v in vnames) { - x[v] <- if (v %in% xnames && is.list(x[[v]]) && is.list(val[[v]])) - list(modifyList(x[[v]], val[[v]], keep.null = keep.null)) - else val[v] + x[v] <- if (v %in% xnames && is.list(x[[v]]) && is.list(val[[v]])) { + list(modifyList(x[[v]], val[[v]], keep.null = keep.null)) + } else { + val[v] + } } - } - else { + } else { for (v in vnames) { - x[[v]] <- if (v %in% xnames && is.list(x[[v]]) && - is.list(val[[v]])) - modifyList2(x[[v]], val[[v]], keep.null = keep.null) - else val[[v]] + x[[v]] <- if (v %in% xnames && is.list(x[[v]]) && + is.list(val[[v]])) { + modifyList2(x[[v]], val[[v]], keep.null = keep.null) + } else { + val[[v]] + } } } x @@ -1646,6 +1654,6 @@ modifyList2 <- function (x, val, keep.null = FALSE) #' @return NULL #' @export #' @keywords internal -clear_build <- function(){ +clear_build <- function() { fs::dir_delete(system.file("template", package = "Pmetrics")) } diff --git a/R/hermes_remote_client.R b/R/hermes_remote_client.R new file mode 100644 index 000000000..77876601e --- /dev/null +++ b/R/hermes_remote_client.R @@ -0,0 +1,222 @@ +pm_remote_validate_profile_config <- function(profile) { + required <- c("base_url", "queue", "api_key_alias", "timeout_sec", "poll_interval_sec") + missing <- required[!required %in% names(profile)] + if (length(missing) > 0) { + stop( + sprintf( + "Profile '%s' is missing required fields: %s", + profile$profile_name %||% "unknown", + paste(missing, collapse = ", ") + ), + call. = FALSE + ) + } + if (!nzchar(profile$base_url)) { + stop("Remote base URL is empty. Re-run pm_remote_configure().", call. = FALSE) + } + invisible(profile) +} + +pm_remote_request <- function(profile, path, method = "GET", body = NULL, timeout = NULL) { + pm_remote_validate_profile_config(profile) + url <- pm_remote_join_url(profile$base_url, path) + req <- httr2::request(url) + req <- httr2::req_method(req, method) + req <- httr2::req_headers(req, Accept = "application/json") + + api_key <- pm_remote_get_api_key(profile$api_key_alias, required = FALSE) + if (!is.null(api_key)) { + req <- httr2::req_headers(req, "X-API-Key" = api_key) + } + ua <- sprintf("Pmetrics/%s (remote)", utils::packageVersion("Pmetrics")) + req <- httr2::req_user_agent(req, ua) + verify <- isTRUE(profile$verify_tls) + if (!verify) { + req <- httr2::req_options(req, ssl_verifypeer = 0L, ssl_verifyhost = 0L) + } + timeout_val <- if (!is.null(timeout)) timeout else profile$timeout_sec + req <- httr2::req_timeout(req, timeout_val) + if (!is.null(body)) { + req <- httr2::req_body_json(req, data = body, auto_unbox = TRUE, digits = NA) + } + resp <- httr2::req_perform(req) + status <- httr2::resp_status(resp) + if (status >= 400) { + detail <- suppressWarnings(httr2::resp_body_string(resp)) + detail <- trimws(detail) + + if ((status == 401 || status == 403) && is.null(api_key)) { + stop( + paste( + "Hermes requires an API key for this endpoint.", + "Set PM_HERMES_API_KEY or run pm_remote_configure(..., api_key = 'your_key')." + ), + call. = FALSE + ) + } + + stop( + sprintf("Hermes request failed (%s): %s", status, detail), + call. = FALSE + ) + } + httr2::resp_body_json(resp, simplifyVector = TRUE) +} + +pm_remote_enqueue <- function(payload, profile = NULL, config = NULL) { + if (!is.list(payload) || !all(c("model", "data", "settings") %in% names(payload))) { + stop("payload must contain model, data, and settings fields", call. = FALSE) + } + prof <- pm_remote_profile_config(profile, config) # nolint + response <- pm_remote_request( + prof, + path = sprintf("%s/enqueue", prof$queue), + method = "POST", + body = list(payload = payload) + ) + list(job_id = response$id, queue = response$queue, profile = prof$profile_name) +} + +pm_remote_job_status <- function(job_id, profile = NULL, config = NULL) { + if (!nzchar(job_id)) { + stop("job_id must be provided", call. = FALSE) + } + prof <- pm_remote_profile_config(profile, config) + pm_remote_request( + prof, + path = sprintf("%s/%s/status", prof$queue, job_id), + method = "GET" + ) +} + +pm_remote_fetch_result <- function(job_id, profile = NULL, config = NULL) { + if (!nzchar(job_id)) { + stop("job_id must be provided", call. = FALSE) + } + prof <- pm_remote_profile_config(profile, config) + pm_remote_request( + prof, + path = sprintf("%s/%s/result", prof$queue, job_id), + method = "GET", + timeout = max(prof$timeout_sec, 120) + ) +} + +pm_remote_build_payload <- function(model_txt, data_csv, settings = NULL, settings_json = NULL) { + if (!is.character(model_txt) || length(model_txt) != 1 || !nzchar(model_txt)) { + stop("model_txt must be a single string", call. = FALSE) + } + if (!is.character(data_csv) || length(data_csv) != 1 || !nzchar(data_csv)) { + stop("data_csv must be a single string", call. = FALSE) + } + if (!is.null(settings_json) && !is.null(settings)) { + stop("Specify either settings or settings_json, not both", call. = FALSE) + } + settings_blob <- if (!is.null(settings_json)) { + pm_remote_validate_settings_json(settings_json) + } else if (!is.null(settings)) { + jsonlite::toJSON(settings, auto_unbox = TRUE, null = "null", digits = NA) + } else { + stop("settings or settings_json must be supplied", call. = FALSE) + } + + list( + model = model_txt, + data = data_csv, + settings = settings_blob + ) +} + +pm_remote_validate_settings_json <- function(value) { + if (!is.character(value) || length(value) != 1 || !nzchar(value)) { + stop("settings_json must be a JSON string", call. = FALSE) + } + tryCatch( + { + jsonlite::fromJSON(value) + value + }, + error = function(e) { + stop(sprintf("settings_json is not valid JSON: %s", e$message), call. = FALSE) + } + ) +} + +pm_remote_wait_for_job <- function(job_id, profile = NULL, config = NULL, poll_interval = NULL, timeout = NULL) { + if (!nzchar(job_id)) { + stop("job_id must be provided", call. = FALSE) + } + prof <- pm_remote_profile_config(profile, config) + pm_remote_validate_profile_config(prof) + + interval <- poll_interval + if (is.null(interval) || !is.finite(interval)) { + interval <- prof$poll_interval_sec + } + if (is.null(interval) || !is.finite(interval)) { + interval <- 5 + } + interval <- max(0.5, as.numeric(interval)) + + timeout_limit <- timeout + if (is.null(timeout_limit) || !is.finite(timeout_limit)) { + timeout_limit <- prof$timeout_sec + } + deadline <- if (!is.null(timeout_limit) && is.finite(timeout_limit)) { + Sys.time() + timeout_limit + } else { + Inf + } + + history <- list() + last_status <- NULL + + repeat { + status <- pm_remote_job_status(job_id, config = prof) + status$polled_at <- format(Sys.time(), tz = "UTC", usetz = TRUE) + history[[length(history) + 1]] <- status + + message <- status$status + if (is.null(message) || !nzchar(message)) { + message <- "(status unavailable)" + } + progress <- status$progress + if (!identical(message, last_status)) { + progress_msg <- if (!is.null(progress) && length(progress) == 1 && is.finite(progress)) { + sprintf(" (%d%%)", as.integer(progress)) + } else { + "" + } + cli::cli_inform(c("i" = sprintf("Hermes job %s: %s%s", job_id, message, progress_msg))) + last_status <- message + } + + if (!is.null(status$error) && nzchar(status$error)) { + stop(sprintf("Hermes job %s failed: %s", job_id, status$error), call. = FALSE) + } + + if (identical(message, "Job completed successfully")) { + return(list(status = status, history = history, profile = prof)) + } + + if (is.finite(deadline) && Sys.time() > deadline) { + stop(sprintf("Timed out waiting for Hermes job %s to complete.", job_id), call. = FALSE) + } + + Sys.sleep(interval) + } +} + +pm_remote_join_url <- function(base_url, path) { + base <- sub("/+$", "", base_url) + tail <- sub("^/+", "", path) + paste(base, tail, sep = "/") +} + +`%||%` <- function(lhs, rhs) { + if (is.null(lhs) || (is.character(lhs) && length(lhs) == 1 && !nzchar(lhs))) { + rhs + } else { + lhs + } +} diff --git a/R/hermes_remote_config.R b/R/hermes_remote_config.R new file mode 100644 index 000000000..c8014d9cc --- /dev/null +++ b/R/hermes_remote_config.R @@ -0,0 +1,324 @@ +if (!exists("%||%", mode = "function")) { + `%||%` <- function(lhs, rhs) { + if (is.null(lhs)) { + rhs + } else if (is.character(lhs) && length(lhs) == 1 && !nzchar(lhs)) { + rhs + } else { + lhs + } + } +} + +pm_remote_default_settings <- function() { + list( + profile_name = "default", + base_url = "", + queue = "heavy-jobs", + poll_interval_sec = 5, + timeout_sec = 3600, + verify_tls = TRUE, + api_key_alias = "hermes-default" + ) +} + +pm_options_user_dir <- function() { + dplyr::case_when( + getOS() %in% c(1, 3) ~ fs::path_expand("~/.PMopts"), + getOS() == 2 ~ file.path(Sys.getenv("APPDATA"), "PMopts"), + TRUE ~ fs::path_expand("~/.PMopts") + ) +} + +pm_options_user_file <- function() { + file.path(pm_options_user_dir(), "PMoptions.json") +} + +#' Configure Hermes remote execution for Pmetrics +#' +#' This helper stores the connection details (URL, queue, TLS policy) and +#' optionally persists an API key reference for Hermes so that remote fits can +#' be submitted without re-entering credentials every session. +#' +#' The configuration is saved in the same preferences directory used by other +#' Pmetrics options (typically `~/.PMopts` on macOS/Linux or `%APPDATA%/PMopts` +#' on Windows). API keys are written to the system keyring under the service +#' name "Pmetrics Hermes"; when the keyring is unavailable you can set the +#' `PM_HERMES_API_KEY` environment variable as a fallback before submitting a +#' remote job. +#' +#' @param base_url Hermes base URL, e.g. `https://hermes.example.com`. +#' @param api_key Optional API key to store securely. Use `NULL` to skip +#' storage and rely on `PM_HERMES_API_KEY` instead. +#' @param queue Target Hermes queue (defaults to `"heavy-jobs"`). +#' @param poll_interval Seconds between status polls once a job is submitted. +#' @param timeout Request timeout in seconds for Hermes HTTP calls. +#' @param allow_insecure Set to `TRUE` only for local testing with self-signed +#' certificates. Production deployments should always verify TLS. +#' @param profile Named profile to create or update (defaults to `"default"`). +#' @param set_active When `TRUE`, mark this profile as the active remote target. +#' +#' @return The profile definition (invisibly). +#' @export +pm_remote_configure <- function( + base_url, + api_key = NULL, + queue = "heavy-jobs", + poll_interval = 5, + timeout = 3600, + allow_insecure = FALSE, + profile = "default", + set_active = TRUE) { + if (missing(base_url) || !is.character(base_url) || length(base_url) != 1) { + stop("base_url must be a single string", call. = FALSE) + } + + base_url <- pm_remote_normalize_url(base_url) + queue <- pm_remote_validate_queue(queue) + poll_interval <- pm_remote_validate_numeric(poll_interval, name = "poll_interval", min_value = 1) + timeout <- pm_remote_validate_numeric(timeout, name = "timeout", min_value = 30) + profile <- pm_remote_validate_profile(profile) + + api_key_alias <- paste0("hermes-", profile) + profile_entry <- list( + profile_name = profile, + base_url = base_url, + queue = queue, + poll_interval_sec = poll_interval, + timeout_sec = timeout, + verify_tls = !isTRUE(allow_insecure), + api_key_alias = api_key_alias + ) + + opts <- pm_remote_read_options() + if (identical(opts, -1)) { + opts <- jsonlite::read_json( + paste(system.file("options", package = "Pmetrics"), "PMoptions.json", sep = "/"), + simplifyVector = TRUE + ) + } + if (!is.list(opts) || length(opts) == 0) { + opts <- list() + } + + opts$remote <- profile_entry + if (isTRUE(set_active)) { + opts$backend <- "remote" + } + + dir.create(dirname(pm_options_user_file()), recursive = TRUE, showWarnings = FALSE) + jsonlite::write_json(opts, pm_options_user_file(), pretty = TRUE, auto_unbox = TRUE) + + if (!is.null(api_key) && nzchar(api_key)) { + pm_remote_store_api_key(api_key_alias, api_key) + } + + invisible(profile_entry) +} + +pm_remote_validate_queue <- function(queue) { + if (!is.character(queue) || length(queue) != 1 || !nzchar(queue)) { + stop("queue must be a non-empty string", call. = FALSE) + } + trimws(queue) +} + +pm_remote_validate_numeric <- function(value, name, min_value) { + if (!is.numeric(value) || length(value) != 1 || is.na(value)) { + stop(sprintf("%s must be numeric", name), call. = FALSE) + } + value <- as.numeric(value) + if (value < min_value) { + stop(sprintf("%s must be >= %s", name, min_value), call. = FALSE) + } + value +} + +pm_remote_validate_profile <- function(profile) { + if (!is.character(profile) || length(profile) != 1 || !nzchar(profile)) { + stop("profile must be a non-empty string", call. = FALSE) + } + profile <- trimws(profile) + profile +} + +pm_remote_normalize_url <- function(url) { + url <- trimws(url) + if (!nzchar(url)) { + stop("base_url cannot be empty", call. = FALSE) + } + if (!grepl("^https?://", url, ignore.case = TRUE)) { + stop("base_url must start with http:// or https://", call. = FALSE) + } + sub("/+$", "", url) +} + +if (!exists("%||%", mode = "function")) { + `%||%` <- function(lhs, rhs) { + if (is.null(lhs)) { + rhs + } else if (is.character(lhs) && length(lhs) == 1 && !nzchar(lhs)) { + rhs + } else { + lhs + } + } + + pm_remote_default_settings <- function() { + list( + profile_name = "default", + base_url = "", + queue = "heavy-jobs", + poll_interval_sec = 5, + timeout_sec = 3600, + verify_tls = TRUE, + api_key_alias = "hermes-default" + ) + } + + pm_options_user_dir <- function() { + dplyr::case_when( + getOS() %in% c(1, 3) ~ fs::path_expand("~/.PMopts"), + getOS() == 2 ~ file.path(Sys.getenv("APPDATA"), "PMopts"), + TRUE ~ fs::path_expand("~/.PMopts") + ) + } + + pm_options_user_file <- function() { + file.path(pm_options_user_dir(), "PMoptions.json") + } +} + +pm_remote_profile_config <- function(profile = NULL, config = NULL) { + if (!is.null(config)) { + remote <- config + } else { + opts <- pm_remote_read_options() + if (!identical(opts, -1) && is.list(opts)) { + remote <- opts$remote + } else { + remote <- NULL + } + } + + defaults <- pm_remote_default_settings() + if (is.null(remote) || !is.list(remote)) { + remote <- defaults + } else { + remote <- utils::modifyList(defaults, remote) + } + + if (!is.null(profile) && nzchar(profile)) { + remote$profile_name <- profile + remote$api_key_alias <- paste0("hermes-", profile) + } + + remote$base_url <- remote$base_url %||% "" + remote$queue <- remote$queue %||% "heavy-jobs" + remote$poll_interval_sec <- remote$poll_interval_sec %||% 5 + remote$timeout_sec <- remote$timeout_sec %||% 3600 + remote$verify_tls <- if (is.null(remote$verify_tls)) TRUE else isTRUE(remote$verify_tls) + remote$api_key_alias <- remote$api_key_alias %||% paste0("hermes-", remote$profile_name %||% "default") + + remote +} + +pm_remote_read_options <- function() { + user_file <- pm_options_user_file() + if (fs::file_exists(user_file)) { + return(jsonlite::read_json(user_file, simplifyVector = TRUE)) + } + + default_file <- file.path(system.file("options", package = "Pmetrics"), "PMoptions.json") + if (fs::file_exists(default_file)) { + return(jsonlite::read_json(default_file, simplifyVector = TRUE)) + } + + list() +} + +pm_remote_store_api_key <- function(alias, api_key) { + if (!nzchar(api_key)) { + return(invisible(FALSE)) + } + if (!pm_remote_keyring_enabled()) { + warning( + "Keyring disabled; set PM_HERMES_API_KEY in your environment before running remote fits.", + call. = FALSE + ) + return(invisible(FALSE)) + } + + tryCatch( + { + keyring::key_set_with_value( + service = pm_remote_key_service(), + username = alias, + password = api_key + ) + TRUE + }, + error = function(e) { + stop(sprintf("Failed to store API key: %s", e$message), call. = FALSE) + } + ) +} + +pm_remote_get_api_key <- function(alias, required = TRUE) { + env_key <- Sys.getenv("PM_HERMES_API_KEY", unset = NA_character_) + if (!is.na(env_key) && nzchar(env_key)) { + return(env_key) + } + + if (!pm_remote_keyring_enabled()) { + if (isTRUE(required)) { + stop( + paste( + "No Hermes API key found.", + "Set PM_HERMES_API_KEY or run pm_remote_configure(..., api_key = 'your_key')." + ), + call. = FALSE + ) + } + return(NULL) + } + + tryCatch( + keyring::key_get(service = pm_remote_key_service(), username = alias), + error = function(e) { + if (isTRUE(required)) { + stop( + sprintf( + "Failed to read API key from keyring (profile '%s'): %s", + alias, + e$message + ), + call. = FALSE + ) + } + NULL + } + ) +} + +pm_remote_key_service <- function() { + "Pmetrics Hermes" +} + +pm_remote_keyring_enabled <- function() { + !identical(Sys.getenv("PM_REMOTE_DISABLE_KEYRING", unset = "0"), "1") +} + +pm_remote_detect_os <- function() { + sys <- tryCatch(Sys.info()[["sysname"]], error = function(...) NA_character_) + if (identical(sys, "Darwin")) { + return(1L) + } + if (identical(sys, "Windows")) { + return(2L) + } + if (identical(sys, "Linux")) { + return(3L) + } + 0L +} diff --git a/R/hermes_remote_result.R b/R/hermes_remote_result.R new file mode 100644 index 000000000..b3004c494 --- /dev/null +++ b/R/hermes_remote_result.R @@ -0,0 +1,589 @@ +pm_remote_prepare_result <- function(result) { + if (is.null(result)) { + cli::cli_abort(c("x" = "Hermes response did not include a fit result.")) + } + + theta <- result$theta + if (is.null(theta) && !is.null(result$theta_json)) { + theta <- jsonlite::fromJSON(result$theta_json) + } + theta <- pm_remote_as_matrix(theta, "theta") + + weights <- result$weights + if (is.null(weights)) { + cli::cli_abort(c("x" = "Hermes result is missing support point weights.")) + } + + parameter_names <- result$parameter_names + if (is.null(parameter_names) && !is.null(colnames(theta))) { + parameter_names <- colnames(theta) + } + if (is.null(parameter_names)) { + parameter_names <- paste0("param_", seq_len(ncol(theta))) + } + parameter_names <- as.character(parameter_names) + if (!is.null(parameter_names) && length(parameter_names) != ncol(theta)) { + cli::cli_abort(c( + "x" = sprintf( + "Theta columns (%d) do not match parameter names (%d).", + ncol(theta), + length(parameter_names) + ) + )) + } + + posterior <- result$posterior + if (is.null(posterior) && !is.null(result$posterior_json)) { + posterior <- jsonlite::fromJSON(result$posterior_json) + } + posterior <- pm_remote_as_matrix(posterior, "posterior") + + posterior_subject_ids <- result$posterior_subject_ids + if (!is.null(posterior_subject_ids)) { + posterior_subject_ids <- as.character(posterior_subject_ids) + } + if (is.null(posterior_subject_ids) && !is.null(posterior)) { + cli::cli_abort(c("x" = "Hermes result is missing posterior subject ids.")) + } + if (!is.null(posterior) && length(posterior_subject_ids) != nrow(posterior)) { + cli::cli_abort(c( + "x" = sprintf( + "Posterior rows (%d) do not match subject ids (%d).", + nrow(posterior), + length(posterior_subject_ids) + ) + )) + } + + predictions <- result$predictions + if (is.null(predictions) && !is.null(result$predictions_json)) { + predictions <- jsonlite::fromJSON(result$predictions_json, simplifyDataFrame = TRUE) + } + predictions_df <- pm_remote_predictions_df(predictions) + + covariates <- result$covariates + covariates_df <- pm_remote_covariates_df(covariates) + + settings <- result$settings_canonical + if (is.null(settings) && !is.null(result$settings_json)) { + settings <- jsonlite::fromJSON(result$settings_json, simplifyVector = TRUE) + } + if (is.null(settings)) { + settings <- list() + } + + cycle_log <- result$cycle_log + if (!is.null(cycle_log) && !is.list(cycle_log)) { + cycle_log <- jsonlite::fromJSON(cycle_log, simplifyVector = FALSE) + } + + n_outputs <- NULL + if (!is.null(predictions_df) && nrow(predictions_df) > 0 && "outeq" %in% names(predictions_df)) { + n_outputs <- suppressWarnings(max(predictions_df$outeq, na.rm = TRUE)) + if (is.finite(n_outputs)) { + n_outputs <- as.integer(n_outputs) + 1L + } else { + n_outputs <- NULL + } + } + if (is.null(n_outputs) && !is.null(cycle_log)) { + entries <- pm_remote_cycle_entries(cycle_log) + if (length(entries) > 0) { + first_models <- entries[[1]]$error_models + if (!is.null(first_models)) { + models <- first_models$models %||% first_models + n_outputs <- length(models) + } + } + } + + list( + success = isTRUE(result$success), + cycles_completed = result$cycles_completed %||% NA_integer_, + objective_value = result$objective_value %||% NA_real_, + converged = isTRUE(result$converged), + theta = theta, + weights = as.numeric(weights), + parameter_names = parameter_names, + posterior = posterior, + posterior_subject_ids = posterior_subject_ids, + predictions = predictions_df, + covariates = covariates_df, + settings = settings, + cycle_log = cycle_log, + n_outputs = n_outputs + ) +} + +pm_remote_write_outputs <- function(prepared, out_dir) { + pm_remote_write_theta(prepared$theta, prepared$weights, prepared$parameter_names, out_dir) + pm_remote_write_posterior( + prepared$theta, + prepared$posterior, + prepared$posterior_subject_ids, + prepared$parameter_names, + out_dir + ) + pm_remote_write_predictions(prepared$predictions, out_dir) + pm_remote_write_covariates(prepared$covariates, out_dir) + pm_remote_write_cycles( + prepared$cycle_log, + prepared$parameter_names, + prepared$n_outputs, + out_dir + ) + pm_remote_write_settings(prepared$settings, out_dir) +} + +pm_remote_write_theta <- function(theta, weights, parameter_names, out_dir) { + if (is.null(theta) || nrow(theta) == 0) { + cli::cli_abort(c("x" = "Hermes result did not include theta support points.")) + } + df <- as.data.frame(theta, stringsAsFactors = FALSE) + colnames(df) <- parameter_names + df$prob <- as.numeric(weights) + readr::write_csv(df, file.path(out_dir, "theta.csv"), na = "") +} + +pm_remote_write_posterior <- function(theta, posterior, subject_ids, parameter_names, out_dir) { + if (is.null(posterior) || length(subject_ids) == 0) { + cli::cli_abort(c("x" = "Hermes result did not include posterior probabilities.")) + } + theta_df <- as.data.frame(theta, stringsAsFactors = FALSE) + colnames(theta_df) <- parameter_names + point_index <- seq_len(nrow(theta_df)) - 1L + + rows <- lapply(seq_along(subject_ids), function(idx) { + subject <- subject_ids[[idx]] + probs <- posterior[idx, ] + df <- theta_df + df$id <- subject + df$point <- point_index + df$prob <- probs + df[c("id", "point", parameter_names, "prob")] + }) + + posterior_df <- dplyr::bind_rows(rows) + posterior_df <- posterior_df[c("id", "point", parameter_names, "prob")] + readr::write_csv(posterior_df, file.path(out_dir, "posterior.csv"), na = "") +} + +pm_remote_write_predictions <- function(predictions, out_dir) { + if (is.null(predictions)) { + cli::cli_abort(c("x" = "Hermes result did not include predictions.")) + } + expected_cols <- c( + "id", + "time", + "outeq", + "block", + "obs", + "censoring", + "pop_mean", + "pop_median", + "post_mean", + "post_median" + ) + missing <- setdiff(expected_cols, names(predictions)) + if ("censoring" %in% missing && "cens" %in% names(predictions)) { + predictions$censoring <- predictions$cens + missing <- setdiff(missing, "censoring") + } + if (length(missing) > 0) { + cli::cli_abort(c( + "x" = sprintf( + "Hermes predictions are missing required columns: %s", + paste(missing, collapse = ", ") + ) + )) + } + + predictions$outeq <- as.integer(predictions$outeq) + predictions$block <- as.integer(predictions$block) + predictions$time <- as.numeric(predictions$time) + if ("obs" %in% names(predictions)) { + predictions$obs <- suppressWarnings(as.numeric(predictions$obs)) + } + order_idx <- order(predictions$id, predictions$time, predictions$outeq, predictions$block) + predictions <- predictions[order_idx, , drop = FALSE] + output_cols <- c( + "id", + "time", + "outeq", + "block", + "obs", + "censoring", + "pop_mean", + "pop_median", + "post_mean", + "post_median" + ) + readr::write_csv(predictions[, output_cols, drop = FALSE], file.path(out_dir, "pred.csv"), na = "") +} + +pm_remote_write_covariates <- function(covariates, out_dir) { + cov_path <- file.path(out_dir, "covs.csv") + if (is.null(covariates) || nrow(covariates) == 0) { + readr::write_csv( + tibble::tibble(id = character(), time = numeric(), block = integer()), + cov_path, + na = "" + ) + return(invisible(NULL)) + } + readr::write_csv(covariates, cov_path, na = "") +} + +pm_remote_write_cycles <- function(cycle_log, parameter_names, n_outputs, out_dir) { + cycle_path <- file.path(out_dir, "cycles.csv") + entries <- pm_remote_cycle_entries(cycle_log) + if (length(entries) == 0) { + empty_df <- pm_remote_empty_cycle_df(parameter_names, n_outputs) + readr::write_csv(empty_df, cycle_path, na = "") + return(invisible(NULL)) + } + + cycle_df <- pm_remote_cycle_df(entries, parameter_names, n_outputs) + readr::write_csv(cycle_df, cycle_path, na = "") +} + +pm_remote_write_settings <- function(settings, out_dir) { + settings_path <- file.path(out_dir, "settings.json") + jsonlite::write_json(settings, settings_path, pretty = TRUE, auto_unbox = TRUE, na = "null") +} + +pm_remote_cycle_entries <- function(cycle_log) { + if (is.null(cycle_log)) { + return(list()) + } + entries <- cycle_log$cycles %||% cycle_log + if (is.data.frame(entries)) { + return(pm_remote_cycle_entries_from_df(entries)) + } + entries +} + +pm_remote_cycle_entries_from_df <- function(cycle_df) { + if (nrow(cycle_df) == 0) { + return(list()) + } + lapply(seq_len(nrow(cycle_df)), function(idx) { + pm_remote_cycle_row_as_list(cycle_df, idx) + }) +} + +pm_remote_cycle_row_as_list <- function(df, idx) { + row <- lapply(df, function(column) { + pm_remote_cycle_cell_value(column, idx) + }) + names(row) <- names(df) + row +} + +pm_remote_cycle_cell_value <- function(column, idx) { + if (is.null(column)) { + return(NULL) + } + if (is.data.frame(column)) { + if (nrow(column) == 0) { + return(list()) + } + return(pm_remote_cycle_row_as_list(column, idx)) + } + if (is.list(column)) { + return(column[[idx]]) + } + column[[idx]] +} + +pm_remote_cycle_df <- function(entries, parameter_names, n_outputs_hint) { + n_outputs <- n_outputs_hint %||% pm_remote_detect_outputs_from_cycle(entries) + gamlam_names <- if (is.null(n_outputs) || n_outputs == 0) { + character() + } else { + paste0("gamlam.", seq_len(n_outputs) - 1L) + } + + mean_names <- paste0(parameter_names, ".mean") + median_names <- paste0(parameter_names, ".median") + sd_names <- paste0(parameter_names, ".sd") + + rows <- lapply(entries, function(entry) { + status <- pm_remote_cycle_status_label(entry$status) + converged <- pm_remote_is_converged_status(status) + neg2ll <- entry$objf %||% NA_real_ + nspp <- entry$nspp %||% NA_real_ + + gamlam_vals <- pm_remote_cycle_gamlam(entry$error_models, length(gamlam_names)) + param_stats <- pm_remote_cycle_parameter_stats(entry$theta, parameter_names) + + row <- c( + list( + cycle = as.integer(entry$cycle %||% NA_integer_), + converged = converged, + status = status, + neg2ll = as.numeric(neg2ll), + nspp = as.integer(nspp) + ), + as.list(gamlam_vals), + as.list(param_stats$mean), + as.list(param_stats$median), + as.list(param_stats$sd) + ) + row + }) + + cycle_df <- dplyr::bind_rows(rows) + expected_cols <- c("cycle", "converged", "status", "neg2ll", "nspp", gamlam_names, mean_names, median_names, sd_names) + missing_cols <- setdiff(expected_cols, names(cycle_df)) + if (length(missing_cols) > 0) { + for (col in missing_cols) { + cycle_df[[col]] <- switch(col, + cycle = rep(NA_integer_, nrow(cycle_df)), + nspp = rep(NA_integer_, nrow(cycle_df)), + converged = rep(NA, nrow(cycle_df)), + status = rep(NA_character_, nrow(cycle_df)), + rep(NA_real_, nrow(cycle_df)) + ) + } + } + cycle_df <- cycle_df[expected_cols] + cycle_df +} + +pm_remote_cycle_gamlam <- function(error_models, n_outputs) { + if (n_outputs == 0) { + return(numeric(0)) + } + values <- rep(NA_real_, n_outputs) + names(values) <- paste0("gamlam.", seq_len(n_outputs) - 1L) + if (is.null(error_models)) { + return(values) + } + models <- error_models$models %||% error_models + for (idx in seq_len(min(length(models), n_outputs))) { + values[idx] <- pm_remote_error_model_factor(models[[idx]]) + } + values +} + +pm_remote_cycle_parameter_stats <- function(theta_entry, parameter_names) { + theta_matrix <- NULL + if (is.list(theta_entry) && !is.null(theta_entry$matrix)) { + theta_matrix <- theta_entry$matrix + } else { + theta_matrix <- theta_entry + } + theta_matrix <- pm_remote_as_matrix(theta_matrix, "cycle theta") + if (is.null(theta_matrix) || ncol(theta_matrix) == 0) { + na_vec <- rep(NA_real_, length(parameter_names)) + names(na_vec) <- parameter_names + return(list( + mean = setNames(na_vec, paste0(parameter_names, ".mean")), + median = setNames(na_vec, paste0(parameter_names, ".median")), + sd = setNames(na_vec, paste0(parameter_names, ".sd")) + )) + } + colnames(theta_matrix) <- parameter_names + mean_vals <- colMeans(theta_matrix) + median_vals <- apply(theta_matrix, 2, stats::median) + sd_vals <- apply(theta_matrix, 2, pm_remote_sample_sd) + list( + mean = setNames(mean_vals, paste0(parameter_names, ".mean")), + median = setNames(median_vals, paste0(parameter_names, ".median")), + sd = setNames(sd_vals, paste0(parameter_names, ".sd")) + ) +} + +pm_remote_sample_sd <- function(x) { + x <- as.numeric(x) + n <- length(x) + if (n <= 1) { + return(NA_real_) + } + stats::sd(x) +} + +pm_remote_error_model_factor <- function(model_entry) { + if (is.null(model_entry)) { + return(NA_real_) + } + if (!is.null(model_entry$Additive)) { + lambda <- model_entry$Additive$lambda + return(pm_remote_extract_scalar(lambda)) + } + if (!is.null(model_entry$Proportional)) { + gamma <- model_entry$Proportional$gamma + return(pm_remote_extract_scalar(gamma)) + } + if (!is.null(model_entry$None)) { + return(NA_real_) + } + pm_remote_extract_scalar(model_entry) +} + +pm_remote_extract_scalar <- function(value) { + if (is.null(value)) { + return(NA_real_) + } + if (is.list(value)) { + for (key in c("Variable", "Fixed", "value")) { + if (!is.null(value[[key]])) { + return(as.numeric(value[[key]])) + } + } + flat <- unlist(value, recursive = TRUE, use.names = FALSE) + if (length(flat) > 0) { + return(as.numeric(flat[[1]])) + } + return(NA_real_) + } + as.numeric(value) +} + +pm_remote_cycle_status_label <- function(status) { + if (is.null(status)) { + return("") + } + if (is.character(status) && length(status) == 1) { + return(status) + } + if (is.list(status)) { + if (!is.null(status$Stop)) { + stop_reason <- status$Stop + if (is.list(stop_reason) && length(stop_reason) == 1) { + stop_reason <- stop_reason[[1]] + } + return(paste0("Stop: ", stop_reason)) + } + if (!is.null(status$Continue)) { + return("Continue") + } + } + as.character(status) +} + +pm_remote_is_converged_status <- function(status) { + if (is.null(status) || !nzchar(status)) { + return(FALSE) + } + grepl("converged", status, ignore.case = TRUE) +} + +pm_remote_detect_outputs_from_cycle <- function(entries) { + for (entry in entries) { + models <- entry$error_models + if (!is.null(models)) { + models <- models$models %||% models + return(length(models)) + } + } + NULL +} + +pm_remote_empty_cycle_df <- function(parameter_names, n_outputs) { + n_outputs <- n_outputs %||% 0L + gamlam_names <- if (n_outputs > 0) paste0("gamlam.", seq_len(n_outputs) - 1L) else character() + mean_names <- paste0(parameter_names, ".mean") + median_names <- paste0(parameter_names, ".median") + sd_names <- paste0(parameter_names, ".sd") + cols <- c("cycle", "converged", "status", "neg2ll", "nspp", gamlam_names, mean_names, median_names, sd_names) + empty_cols <- setNames(lapply(cols, function(col_name) { + if (col_name %in% c("cycle", "nspp")) { + integer(0) + } else if (col_name == "converged") { + logical(0) + } else if (col_name == "status") { + character(0) + } else { + numeric(0) + } + }), cols) + tibble::as_tibble(empty_cols) +} + +pm_remote_as_matrix <- function(value, label) { + if (is.null(value)) { + return(NULL) + } + if (is.matrix(value)) { + return(value) + } + if (is.data.frame(value)) { + return(as.matrix(value)) + } + if (is.list(value)) { + row_list <- lapply(value, function(row) { + if (is.list(row)) { + unlist(row, recursive = FALSE, use.names = FALSE) + } else { + row + } + }) + suppressWarnings({ + mat <- do.call(rbind, row_list) + }) + if (is.null(mat)) { + cli::cli_abort(c("x" = "Unable to coerce {label} to a numeric matrix.")) + } + if (!is.matrix(mat)) { + mat <- as.matrix(mat) + } + mode(mat) <- "numeric" + return(mat) + } + cli::cli_abort(c("x" = "Unsupported {label} representation from Hermes.")) +} + +pm_remote_predictions_df <- function(predictions) { + if (is.null(predictions)) { + return(NULL) + } + if (inherits(predictions, "data.frame")) { + return(predictions) + } + if (is.list(predictions)) { + df <- dplyr::bind_rows(predictions) + return(df) + } + cli::cli_abort(c("x" = "Unable to coerce predictions into a data frame.")) +} + +pm_remote_covariates_df <- function(covariates) { + if (is.null(covariates)) { + return(NULL) + } + if (inherits(covariates, "data.frame")) { + if (nrow(covariates) == 0) { + return(tibble::tibble()) + } + order_idx <- order(covariates$id, covariates$time, covariates$block) + return(covariates[order_idx, , drop = FALSE]) + } + if (length(covariates) == 0) { + return(tibble::tibble()) + } + cov_names <- unique(unlist(lapply(covariates, function(row) names(row$covariates)))) + cov_names <- sort(cov_names) + rows <- lapply(covariates, function(row) { + cov_values <- vapply(cov_names, function(name) { + value <- row$covariates[[name]] + if (is.null(value) || (is.na(value) && length(value) == 1)) { + NA_real_ + } else { + as.numeric(value) + } + }, numeric(1)) + data.frame( + id = row$id, + time = as.numeric(row$time), + block = as.integer(row$block), + t(cov_values), + check.names = FALSE, + stringsAsFactors = FALSE + ) + }) + df <- dplyr::bind_rows(rows) + order_idx <- order(df$id, df$time, df$block) + df[order_idx, , drop = FALSE] +} diff --git a/R/options.R b/R/options.R index b067102bb..f07929af6 100755 --- a/R/options.R +++ b/R/options.R @@ -1,105 +1,107 @@ setPMoptions <- function(launch.app = TRUE) { - - # --- Helper: OS Detection Function --- getOS <- function() { sysname <- Sys.info()[["sysname"]] - if (sysname == "Darwin") return(1) # Mac - if (sysname == "Windows") return(2) # Windows - if (sysname == "Linux") return(3) # Linux - return(0) # unknown + if (sysname == "Darwin") { + return(1) + } # Mac + if (sysname == "Windows") { + return(2) + } # Windows + if (sysname == "Linux") { + return(3) + } # Linux + return(0) # unknown } - + opt_dir <- dplyr::case_when( getOS() %in% c(1, 3) ~ fs::path_expand("~/.PMopts"), getOS() == 2 ~ file.path(Sys.getenv("APPDATA"), "PMopts"), - TRUE ~ tempdir() # fallback + TRUE ~ tempdir() # fallback ) - - fs::dir_create(opt_dir) # ensure directory exists + + fs::dir_create(opt_dir) # ensure directory exists PMoptionsUserFile <- file.path(opt_dir, "PMoptions.json") - + # If file doesn't exist in user space, copy default if (!fs::file_exists(PMoptionsUserFile)) { PMoptionsFile <- glue::glue(system.file("options", package = "Pmetrics"), "/PMoptions.json") fs::file_copy(PMoptionsFile, PMoptionsUserFile, overwrite = TRUE) } - + app <- shiny::shinyApp( - + # --- UI --- ui = bslib::page_fluid( theme = bslib::bs_theme(bootswatch = "flatly"), title = "Pmetrics Options", - tags$details( tags$summary("📁 Data File Reading"), selectInput("sep", "Field separator", - choices = c(Comma = ",", Semicolon = ";", Tab = "\t"), - selected = ","), - + choices = c(Comma = ",", Semicolon = ";", Tab = "\t"), + selected = "," + ), selectInput("dec", "Decimal mark", - choices = c(Period = ".", Comma = ","), - selected = ".") + choices = c(Period = ".", Comma = ","), + selected = "." + ) ), # Formatting options tags$details( tags$summary("📏 Formatting Options"), numericInput("digits", "Number of digits to display", - value = 3, min = 0, max = 10, step = 1) + value = 3, min = 0, max = 10, step = 1 + ) ), - conditionalPanel( condition = "input.show == false", - #Fit options - tags$details( - tags$summary("🔍 Fit Options"), - selectInput("backend", "Default backend", - choices = c("Rust" = "rust"), - selected = "rust"), - markdown("*Rust is the only backend currently supported by Pmetrics.*") - ) - ), - + # Fit options + tags$details( + tags$summary("🔍 Fit Options"), + selectInput("backend", "Default backend", + choices = c("Rust" = "rust", "Hermes Remote" = "remote"), + selected = "rust" + ), + markdown("Select Hermes Remote to run fits via Hermes. Configure credentials with {.fn pm_remote_configure}.") + ) + ), tags$details( tags$summary("📊 Prediction Error Metrics"), br(), checkboxInput("show_metrics", "Display error metrics on obs-pred plots with linear regression", TRUE), selectInput("bias_method", "Bias Method", - choices = c( - "Mean absolute error (MAE)" = "mae", - "Mean weighted error (MWE)" = "mwe" + choices = c( + "Mean absolute error (MAE)" = "mae", + "Mean weighted error (MWE)" = "mwe" + ), + selected = "mwe" ), - selected = "mwe"), - selectInput("imp_method", "Imprecision Method", - choices = c( - - "Mean squared error (MSE)" = "mse", - "Mean weighted squared error (MWSE)" = "mwse", - "Root mean squared error (RMSE)" = "rmse", - "Mean, bias-adjusted, squared error (MBASE)" = "mbase", - "Mean, bias-adjusted, weighted, squared error (MBAWSE)" = "mbawse", - "Root mean, bias-adjusted, weighted, squared error (RMBAWSE)" = "rmbawse" + choices = c( + "Mean squared error (MSE)" = "mse", + "Mean weighted squared error (MWSE)" = "mwse", + "Root mean squared error (RMSE)" = "rmse", + "Mean, bias-adjusted, squared error (MBASE)" = "mbase", + "Mean, bias-adjusted, weighted, squared error (MBAWSE)" = "mbawse", + "Root mean, bias-adjusted, weighted, squared error (RMBAWSE)" = "rmbawse" + ), + selected = "rmbawse" ), - selected = "rmbawse"), - checkboxInput("use_percent", "Use percent for error metrics", value = TRUE), - selectInput("ic_method", "Information Criterion Method", choices = c( - "Akaike Information Criterion (AIC)" = "aic", - "Bayesian Information Criterion (BIC)" = "bic" - ), - selected = "aic") - + "Akaike Information Criterion (AIC)" = "aic", + "Bayesian Information Criterion (BIC)" = "bic" + ), + selected = "aic" + ) ), - tags$details( tags$summary("📝 Report Generation"), - selectInput("report_template", "Default report template", - choices = c("plotly", "ggplot2"), - selected = "plotly") + selectInput("report_template", "Default report template", + choices = c("plotly", "ggplot2"), + selected = "plotly" + ) ), br(), div( @@ -107,24 +109,25 @@ setPMoptions <- function(launch.app = TRUE) { actionButton("save", "Save"), actionButton("exit", "Exit"), ), - br(), br(), shiny::verbatimTextOutput("settings_location"), br(), - - actionButton("open_file", "Open Options File", - icon = icon("folder-open"), class = "btn-primary") + actionButton("open_file", "Open Options File", + icon = icon("folder-open"), class = "btn-primary" + ) ), - + # --- Server --- server = function(input, output, session) { - # Load settings from external file - settings <- tryCatch({ - jsonlite::fromJSON(PMoptionsUserFile) - }, error = function(e) NULL) - + settings <- tryCatch( + { + jsonlite::fromJSON(PMoptionsUserFile) + }, + error = function(e) NULL + ) + # update this list every time a new option is added input_types <- list( sep = updateSelectInput, @@ -139,74 +142,76 @@ setPMoptions <- function(launch.app = TRUE) { backend = updateSelectInput ) - + # Apply updates purrr::imap(settings, function(val, name) { updater <- input_types[[name]] - arg_name <- input_types[[name]] %>% formals() %>% names() %>% keep(~ .x %in% c("value", "selected")) - + arg_name <- input_types[[name]] %>% + formals() %>% + names() %>% + keep(~ .x %in% c("value", "selected")) + if (!is.null(updater) && !is.null(arg_name)) { args <- list(session = session, inputId = name) - args[[arg_name]] <- val %>% stringr::str_remove("^percent_") # remove 'percent_' prefix if present + args[[arg_name]] <- val %>% stringr::str_remove("^percent_") # remove 'percent_' prefix if present do.call(updater, args) - } + } }) - - - - - + + + + + # Display path to user settings file output$settings_location <- renderText({ glue::glue("Options file path:\n{PMoptionsUserFile}") }) - - + + ### Action button handlers - + # Save updated settings observeEvent(input$save, { - settings <- list(sep = input$sep, dec = input$dec, digits = input$digits, show_metrics = input$show_metrics, - bias_method = glue::glue(c("","percent_")[1+as.numeric(input$use_percent)], input$bias_method), - imp_method = glue::glue(c("","percent_")[1+as.numeric(input$use_percent)], input$imp_method), + settings <- list( + sep = input$sep, dec = input$dec, digits = input$digits, show_metrics = input$show_metrics, + bias_method = glue::glue(c("", "percent_")[1 + as.numeric(input$use_percent)], input$bias_method), + imp_method = glue::glue(c("", "percent_")[1 + as.numeric(input$use_percent)], input$imp_method), ic_method = input$ic_method, - report_template = input$report_template, backend = input$backend) - - save_status <- tryCatch(jsonlite::write_json(settings, PMoptionsUserFile, pretty = TRUE, auto_unbox = TRUE), + report_template = input$report_template, backend = input$backend + ) + + save_status <- tryCatch(jsonlite::write_json(settings, PMoptionsUserFile, pretty = TRUE, auto_unbox = TRUE), error = function(e) { shiny::showNotification( paste("Error saving settings:", e$message), type = "error", duration = 5 ) return(FALSE) - }) - shiny::showNotification( - "Settings saved", type = "message", duration = 3 - ) - }) - - # Exit the app - observeEvent(input$exit, { - shiny::stopApp() - }) - - # Open the options file in the default application - observeEvent(input$open_file, { - system(glue::glue("open {PMoptionsUserFile}")) - }) - } #end server - ) #end shinyApp - - - # Launch the app without trying to launch another browser - if(launch.app){ - shiny::runApp(app, launch.browser = TRUE) - } - - return(invisible(NULL)) - + } + ) + shiny::showNotification( + "Settings saved", + type = "message", duration = 3 + ) + }) + + # Exit the app + observeEvent(input$exit, { + shiny::stopApp() + }) + + # Open the options file in the default application + observeEvent(input$open_file, { + system(glue::glue("open {PMoptionsUserFile}")) + }) + } # end server + ) # end shinyApp + + # Launch the app without trying to launch another browser + if (launch.app) { + shiny::runApp(app, launch.browser = TRUE) + } + + return(invisible(NULL)) } # end of PM_options function - - - \ No newline at end of file diff --git a/inst/options/PMoptions.json b/inst/options/PMoptions.json index c75eebc94..3e6482411 100755 --- a/inst/options/PMoptions.json +++ b/inst/options/PMoptions.json @@ -3,5 +3,14 @@ "dec": ["."], "lang": ["en"], "backend": ["rust"], - "op_stats": [true] + "op_stats": [true], + "remote": { + "profile_name": "default", + "base_url": "", + "queue": "heavy-jobs", + "poll_interval_sec": 5, + "timeout_sec": 3600, + "verify_tls": true, + "api_key_alias": "hermes-default" + } } diff --git a/scripts/bke_remote.R b/scripts/bke_remote.R new file mode 100644 index 000000000..e3c77b949 --- /dev/null +++ b/scripts/bke_remote.R @@ -0,0 +1,165 @@ +#!/usr/bin/env Rscript +# +# Bimodal ke remote fit example using PM_model/PM_fit + Hermes +# Reimplements hermes/hermes/examples/bke.rs with the high-level Pmetrics interfaces. +# +# Prerequisites: +# * Pmetrics installed with the remote helpers (pm_remote_*) +# * Hermes API reachable (defaults to http://localhost:8080) +# * Either set PM_HERMES_API_KEY in your environment or store an API key in the +# system keyring under the alias defined below (default "hermes-bke"). +# +# Usage: +# Rscript bke_remote.R +# +# Environment overrides: +# HERMES_URL Base URL for Hermes (default http://localhost:8080) +# HERMES_QUEUE Queue name (default heavy-jobs) +# HERMES_POLL Poll interval seconds (default 2) +# HERMES_TIMEOUT Request timeout seconds (default 3600) +# HERMES_INSECURE Set to 1 to skip TLS verification (local dev only) +# HERMES_API_ALIAS Keyring alias to read (default hermes-bke) +# +# Data source: +# ../PMcore/examples/bimodal_ke/bimodal_ke.csv (same as bke.rs) + +suppressPackageStartupMessages({ + library(cli) + library(readr) +}) +devtools::load_all("/Users/siel/code/LAPKB/Pmetrics_rust") + +# Resolve Hermes connection details ---------------------------------------- +hermes_url <- Sys.getenv("HERMES_URL", "http://localhost:8080") +hermes_queue <- Sys.getenv("HERMES_QUEUE", "heavy-jobs") +hermes_poll <- as.numeric(Sys.getenv("HERMES_POLL", "2")) +hermes_timeout <- as.numeric(Sys.getenv("HERMES_TIMEOUT", "3600")) +hermes_verify <- !identical(Sys.getenv("HERMES_INSECURE", "0"), "1") +hermes_alias <- Sys.getenv("HERMES_API_ALIAS", "hermes-bke") + +profile_cfg <- pm_remote_profile_config(config = list( + profile_name = "bke-example", + base_url = hermes_url, + queue = hermes_queue, + poll_interval_sec = hermes_poll, + timeout_sec = hermes_timeout, + verify_tls = hermes_verify, + api_key_alias = hermes_alias +)) +pm_remote_validate_profile_config(profile_cfg) + +cli_inform(sprintf("Using Hermes profile %s (%s)", profile_cfg$profile_name, profile_cfg$base_url)) +cli_inform("Set PM_HERMES_API_KEY or store a keyring secret under the alias above before running.") + +# Build PM_model + PM_data objects ---------------------------------------- +data_path <- file.path("PMcore", "examples", "bimodal_ke", "bimodal_ke.csv") +if (!file.exists(data_path)) { + stop(sprintf("Unable to locate data file at %s", normalizePath(data_path, mustWork = FALSE))) +} + +mod_list <- list( + pri = c( + ke = ab(0.001, 3.0), + v = ab(25.0, 250.0) + ), + eqn = function() { + dx[1] <- -ke * x[1] + rateiv[1] + }, + out = function() { + y[1] <- x[1] / v + }, + err = c( + additive(0, c(0.0, 0.5, 0.0, 0.0)) + ) +) + +mod <- PM_model$new(mod_list) +data_obj <- PM_data$new(data_path, quiet = TRUE) + +fit_result <- mod$fit( + data = data_obj, + algorithm = "NPAG", + idelta = 0.1, + tad = 0, + cycles = 1000, + prior = "sobol", + points = 2028, + seed = 22, + remote = TRUE, + remote_config = profile_cfg, +) # This returns a PM_result object via Hermes +print(fit_result$runInfo) + +# # Stage working directories similar to PM_model$fit ----------------------- +# run_root <- file.path("examples", "bke", "pmfit_remote") +# inputs_dir <- file.path(run_root, "inputs") +# outputs_dir <- file.path(run_root, "outputs") +# dir.create(inputs_dir, recursive = TRUE, showWarnings = FALSE) +# dir.create(outputs_dir, recursive = TRUE, showWarnings = FALSE) + +# gendata_path <- file.path(inputs_dir, "gendata.csv") +# data_obj$save(gendata_path, header = FALSE) +# data_csv <- read_file(gendata_path) + +# model_rust <- fit_obj$model$.__enclos_env__$private$render_model_to_rust() +# writeLines(model_rust, file.path(inputs_dir, "model.rs")) +# saveRDS(list(data = data_obj, model = mod), file = file.path(inputs_dir, "fit.rds")) + +# # Prepare Hermes payload from fit configuration -------------------------- +# ranges <- lapply(mod$model_list$pri, function(x) c(x$min, x$max)) +# names(ranges) <- tolower(names(ranges)) + +# fit_params <- list( +# ranges = ranges, +# algorithm = "NPAG", +# error_models = lapply(mod$model_list$err, function(x) x$flatten()), +# idelta = 0.1, +# tad = 0, +# max_cycles = 1000, +# prior = "sobol", +# points = 2028, +# seed = 22 +# ) + +# payload <- pm_remote_build_payload( +# model_txt = model_rust, +# data_csv = data_csv, +# settings = fit_params +# ) + +# # Submit job --------------------------------------------------------------- +# job <- pm_remote_enqueue(payload, config = profile_cfg) +# cli_inform(sprintf("Hermes job %s enqueued on %s", job$job_id, job$queue)) + +# status <- pm_remote_wait_for_job(job$job_id, config = profile_cfg) +# job_status <- status$status$status +# if (is.null(job_status)) { +# job_status <- "(unknown)" +# } +# cli_inform(sprintf("Job %s finished with status: %s", job$job_id, job_status)) + +# result <- pm_remote_fetch_result(job$job_id, config = profile_cfg) +# if (is.null(result$result) || !isTRUE(result$result$success)) { +# stop("Hermes job did not return a successful FitResult.") +# } + +# # Materialize outputs + parse via Pmetrics --------------------------------- +# prepared <- pm_remote_prepare_result(result$result) +# pm_remote_write_outputs(prepared, outputs_dir) +# jsonlite::write_json(result, file.path(outputs_dir, "hermes_result.json"), pretty = TRUE, auto_unbox = TRUE) + +# job_meta <- list( +# job = job, +# profile = profile_cfg[c("profile_name", "base_url", "queue")], +# status = status$status, +# history = status$history +# ) +# jsonlite::write_json(job_meta, file.path(inputs_dir, "hermes_job.json"), pretty = TRUE, auto_unbox = TRUE) + +# cli_inform(sprintf("Artifacts written to %s", normalizePath(run_root))) + +# PM_parse(path = outputs_dir) +# fit_result <- PM_load(path = outputs_dir, file = "PMout.Rdata") +# cli_inform("PM_result successfully reconstructed from Hermes payload.") + +# print(fit_result$runInfo) diff --git a/scripts/bke_remote_raw.R b/scripts/bke_remote_raw.R new file mode 100644 index 000000000..935986c90 --- /dev/null +++ b/scripts/bke_remote_raw.R @@ -0,0 +1,128 @@ +#!/usr/bin/env Rscript +# +# Bimodal ke remote fit example using Pmetrics + Hermes +# This mirrors hermes/hermes/examples/bke.rs but drives the job from R instead of Rust. +# +# Prerequisites: +# * Pmetrics installed with the remote helpers (pm_remote_*) +# * Hermes API reachable (defaults to http://localhost:8080) +# * Either set PM_HERMES_API_KEY in your environment or store an API key in the +# system keyring under the alias defined below (default "hermes-bke"). +# +# Usage: +# Rscript bke_remote.R +# +# Environment overrides: +# HERMES_URL Base URL for Hermes (default http://localhost:8080) +# HERMES_QUEUE Queue name (default heavy-jobs) +# HERMES_POLL Poll interval seconds (default 2) +# HERMES_TIMEOUT Request timeout seconds (default 3600) +# HERMES_INSECURE Set to 1 to skip TLS verification (local dev only) +# HERMES_API_ALIAS Keyring alias to read (default hermes-bke) +# +# Data source: +# ../PMcore/examples/bimodal_ke/bimodal_ke.csv (same as bke.rs) + +suppressPackageStartupMessages({ + library(readr) + library(cli) +}) +devtools::load_all("/Users/siel/code/LAPKB/Pmetrics_rust") + +# Resolve Hermes connection details ---------------------------------------- +hermes_url <- Sys.getenv("HERMES_URL", "http://localhost:8080") +hermes_queue <- Sys.getenv("HERMES_QUEUE", "heavy-jobs") +hermes_poll <- as.numeric(Sys.getenv("HERMES_POLL", "2")) +hermes_timeout <- as.numeric(Sys.getenv("HERMES_TIMEOUT", "3600")) +hermes_verify <- !identical(Sys.getenv("HERMES_INSECURE", "0"), "1") +hermes_alias <- Sys.getenv("HERMES_API_ALIAS", "hermes-bke") + +profile <- pm_remote_profile_config(config = list( + profile_name = "bke-example", + base_url = hermes_url, + queue = hermes_queue, + poll_interval_sec = hermes_poll, + timeout_sec = hermes_timeout, + verify_tls = hermes_verify, + api_key_alias = hermes_alias +)) +pm_remote_validate_profile_config(profile) + +cli_inform(sprintf("Using Hermes profile %s (%s)", profile$profile_name, profile$base_url)) +cli_inform("Set PM_HERMES_API_KEY or store a keyring secret under the alias above before running.") + +# Prepare payload ---------------------------------------------------------- +model_txt <- "equation::ODE::new( + |x, p, _t, dx, _b, rateiv, _cov| { + fetch_params!(p, ke, _v); + dx[0] = -ke * x[0] + rateiv[0]; + }, + |_p, _t, _cov| lag! {}, + |_p, _t, _cov| fa! {}, + |_p, _t, _cov, _x| {}, + |x, p, _t, _cov, y| { + fetch_params!(p, _ke, v); + y[0] = x[0] / v; + }, + (1, 1), + )" + +data_path <- file.path("PMcore", "examples", "bimodal_ke", "bimodal_ke.csv") +if (!file.exists(data_path)) { + stop(sprintf("Unable to locate data file at %s", normalizePath(data_path, mustWork = FALSE))) +} +data_csv <- read_file(data_path) + +settings <- list( + ranges = list( + ke = c(0.001, 3.0), + v = c(25.0, 250.0) + ), + algorithm = "npag", + error_models = list( + list(type = "additive", initial = 0.0, coeff = c(0.0, 0.5, 0.0, 0.0)) + ), + idelta = 0.1, + tad = 0, + max_cycles = 1000, + prior = "sobol", + points = 2028, + seed = 22 +) + +payload <- pm_remote_build_payload( + model_txt = model_txt, + data_csv = data_csv, + settings = settings +) + +# Submit job --------------------------------------------------------------- +job <- pm_remote_enqueue(payload, config = profile) +cli_inform(sprintf("Hermes job %s enqueued on %s", job$job_id, job$queue)) + +status <- pm_remote_wait_for_job(job$job_id, config = profile) +job_status <- status$status$status +if (is.null(job_status)) { + job_status <- "(unknown)" +} +cli_inform(sprintf("Job %s finished with status: %s", job$job_id, job_status)) + +result <- pm_remote_fetch_result(job$job_id, config = profile) +if (is.null(result$result) || !isTRUE(result$result$success)) { + stop("Hermes job did not return a successful FitResult.") +} + +# Materialize outputs + parse via Pmetrics --------------------------------- +output_dir <- file.path("examples", "bke", "output") +dir.create(output_dir, recursive = TRUE, showWarnings = FALSE) +prepared <- pm_remote_prepare_result(result$result) +pm_remote_write_outputs(prepared, output_dir) +jsonlite::write_json(result, file.path(output_dir, "hermes_result.json"), pretty = TRUE, auto_unbox = TRUE) + +cli_inform(sprintf("Artifacts written to %s", normalizePath(output_dir))) + +PM_parse(path = output_dir) +fit <- PM_load(path = output_dir, file = "PMout.Rdata") +cli_inform("PM_result successfully reconstructed from Hermes payload.") + +print(fit$runInfo) diff --git a/scripts/capture_bke_payload.R b/scripts/capture_bke_payload.R new file mode 100644 index 000000000..ad8890e39 --- /dev/null +++ b/scripts/capture_bke_payload.R @@ -0,0 +1,54 @@ +suppressPackageStartupMessages({ + library(readr) + library(cli) +}) +devtools::load_all("/Users/siel/code/LAPKB/Pmetrics_rust") + +profile <- pm_remote_profile_config(config = list( + profile_name = "bke-example", + base_url = Sys.getenv("HERMES_URL", "http://localhost:8080"), + queue = Sys.getenv("HERMES_QUEUE", "heavy-jobs"), + poll_interval_sec = as.numeric(Sys.getenv("HERMES_POLL", "2")), + timeout_sec = as.numeric(Sys.getenv("HERMES_TIMEOUT", "3600")), + verify_tls = !identical(Sys.getenv("HERMES_INSECURE", "0"), "1"), + api_key_alias = Sys.getenv("HERMES_API_ALIAS", "hermes-bke") +)) + +model_txt <- "equation::ODE::new(\n |x, p, _t, dx, _b, rateiv, _cov| {\n fetch_params!(p, ke, _v);\n dx[0] = -ke * x[0] + rateiv[0];\n },\n |_p, _t, _cov| lag! {},\n |_p, _t, _cov| fa! {},\n |_p, _t, _cov, _x| {},\n |x, p, _t, _cov, y| {\n fetch_params!(p, _ke, v);\n y[0] = x[0] / v;\n },\n (1, 1),\n )" + +data_csv <- read_file(file.path("PMcore", "examples", "bimodal_ke", "bimodal_ke.csv")) + +settings <- list( + ranges = list( + ke = c(0.001, 3.0), + v = c(25.0, 250.0) + ), + algorithm = "npag", + error_models = list( + list(type = "additive", initial = 0.0, coeff = c(0.0, 0.5, 0.0, 0.0)), + list(type = "none", initial = 0.0) + ), + idelta = 0.1, + tad = 0, + max_cycles = 1000, + prior = "sobol", + points = 2028, + seed = 22 +) + +payload <- pm_remote_build_payload( + model_txt = model_txt, + data_csv = data_csv, + settings = settings +) + +job <- pm_remote_enqueue(payload, config = profile) +status <- pm_remote_wait_for_job(job$job_id, config = profile) +result <- pm_remote_fetch_result(job$job_id, config = profile) + +saveRDS( + list(job = job, status = status, result = result), + file = "Pmetrics_rust/tmp_result.rds" +) + +cli_inform(sprintf("Captured job %s outputs to Pmetrics_rust/tmp_result.rds", job$job_id)) diff --git a/scripts/inspect_bke_fit_payload.R b/scripts/inspect_bke_fit_payload.R new file mode 100644 index 000000000..2de178230 --- /dev/null +++ b/scripts/inspect_bke_fit_payload.R @@ -0,0 +1,65 @@ +suppressPackageStartupMessages({ + library(jsonlite) + library(cli) +}) + +devtools::load_all("/Users/siel/code/LAPKB/Pmetrics_rust") + +mod_list <- list( + pri = c( + ke = ab(0.001, 3.0), + v = ab(25.0, 250.0) + ), + eqn = function() { + dx[1] <- -ke * x[1] + rateiv[1] + }, + out = function() { + y[1] <- x[1] / v + }, + err = c( + additive(1, c(0.0, 0.5, 0.0, 0.0)) + ) +) + +mod <- PM_model$new(mod_list) + +data_path <- file.path("..", "PMcore", "examples", "bimodal_ke", "bimodal_ke.csv") +if (!file.exists(data_path)) { + stop(sprintf("Data not found at %s", normalizePath(data_path, mustWork = FALSE))) +} +data_obj <- PM_data$new(data_path, quiet = TRUE) + +data_filtered <- data_obj$standard_data +inputs_dir <- tempfile(pattern = "pmfit_inputs_") +dir.create(inputs_dir, recursive = TRUE, showWarnings = FALSE) +gendata_path <- file.path(inputs_dir, "gendata.csv") +data_obj$save(gendata_path, header = FALSE) +model_rust <- mod$.__enclos_env__$private$render_model_to_rust() + +ranges <- lapply(mod$model_list$pri, function(x) c(x$min, x$max)) +names(ranges) <- tolower(names(ranges)) +error_models <- lapply(mod$model_list$err, function(x) x$flatten()) + +settings <- list( + ranges = ranges, + algorithm = "NPAG", + error_models = error_models, + idelta = 0.1, + tad = 0, + max_cycles = 1000, + prior = "sobol", + points = 2028, + seed = 22 +) + +cat(cli::col_green("Quick payload diff helper"), "\n", sep = "") +cat(cli::col_cyan("Rust model snippet:"), "\n", sep = "") +cat(substr(model_rust, 1, 200), "...\n\n", sep = "") + +cat(cli::col_cyan("Settings JSON:"), "\n", sep = "") +cat(prettify(toJSON(settings, auto_unbox = TRUE, null = "null", digits = NA))) +cat("\n\n") + +cat(cli::col_cyan("First five lines of gendata.csv:"), "\n", sep = "") +cat(paste(readLines(gendata_path, n = 5), collapse = "\n")) +cat("\n") diff --git a/scripts/inspect_cycle_log.R b/scripts/inspect_cycle_log.R new file mode 100644 index 000000000..8ad24e6dd --- /dev/null +++ b/scripts/inspect_cycle_log.R @@ -0,0 +1,63 @@ +suppressPackageStartupMessages({ + library(jsonlite) +}) + +pm_print_str_limited <- function(obj, max_level = 2L, vec_len = 6L, max_lines = 80L) { + output <- capture.output(str(obj, max.level = max_level, vec.len = vec_len, give.attr = FALSE)) + pm_cat_limited(output, max_lines) +} + +pm_print_vector_preview <- function(values, max_items = 20L) { + if (length(values) == 0) { + cat("(none)\n") + return(invisible(NULL)) + } + shown <- values[seq_len(min(length(values), max_items))] + suffix <- if (length(values) > max_items) sprintf(" ... (%d total)", length(values)) else "" + cat(paste(shown, collapse = ", "), suffix, "\n", sep = "") + invisible(NULL) +} + +pm_cat_limited <- function(lines, max_lines = 80L) { + if (length(lines) > max_lines) { + omitted <- length(lines) - max_lines + lines <- c(lines[seq_len(max_lines)], sprintf("... truncated %d additional lines ...", omitted)) + } + cat(paste(lines, collapse = "\n"), "\n", sep = "") +} + +args <- commandArgs(trailingOnly = TRUE) +if (length(args) == 0) { + stop("Usage: Rscript inspect_cycle_log.R ", call. = FALSE) +} +source_file <- args[[1]] +if (!file.exists(source_file)) { + stop(sprintf("File not found: %s", source_file), call. = FALSE) +} +blob <- readRDS(source_file) +cycle_log <- blob$result$result$cycle_log +if (is.null(cycle_log)) { + stop("cycle_log is NULL in the provided result", call. = FALSE) +} +cat("Top-level cycle_log structure:\n") +pm_print_str_limited(cycle_log) +entries <- cycle_log$cycles +if (is.null(entries)) { + if (is.list(cycle_log)) { + entries <- cycle_log + } else { + stop("cycle_log is not a list", call. = FALSE) + } +} +cat(sprintf("Entry container class: %s\n", paste(class(entries), collapse = ", "))) +if (is.data.frame(entries)) { + cat(sprintf("Data frame rows: %d, cols: %d\n", nrow(entries), ncol(entries))) + cat("Column names:\n") + pm_print_vector_preview(names(entries)) + cat("First row overview:\n") + pm_print_str_limited(as.list(entries[1, , drop = FALSE])) +} else if (is.list(entries) && length(entries) > 0) { + cat(sprintf("Entry count: %d\n", length(entries))) + cat("First entry overview:\n") + pm_print_str_limited(entries[[1]]) +} diff --git a/src/rust/Cargo.toml b/src/rust/Cargo.toml index 2ee9e7262..276d349f2 100755 --- a/src/rust/Cargo.toml +++ b/src/rust/Cargo.toml @@ -9,7 +9,7 @@ name = 'pm_rs' [dependencies] extendr-api = '*' -pmcore = {version ="=0.21.1", features = ["exa"]} +pmcore = {version ="=0.22.0", features = ["exa"]} # pmcore = { path = "../../../PMcore", features = ["exa"] } rayon = "1.10.0" diff --git a/src/rust/src/executor.rs b/src/rust/src/executor.rs index 2866673a7..2f22bbabe 100755 --- a/src/rust/src/executor.rs +++ b/src/rust/src/executor.rs @@ -42,7 +42,7 @@ pub(crate) fn fit( let data = data::read_pmetrics(data.to_str().unwrap()).expect("Failed to read data"); //dbg!(&data); let mut algorithm = dispatch_algorithm(settings, eq, data)?; - let result = algorithm.fit()?; + let mut result = algorithm.fit()?; result.write_outputs()?; Ok(()) } From 19eb53b961e7ab58a14c2ccfa318938e667d4e12 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Juli=C3=A1n=20D=2E=20Ot=C3=A1lvaro?= Date: Tue, 18 Nov 2025 00:18:30 +0000 Subject: [PATCH 2/4] report generation --- R/PMoptions.R | 31 ++++++++++++++++++++++++++++--- inst/options/PMoptions.json | 7 +++++++ scripts/bke_remote.R | 3 ++- 3 files changed, 37 insertions(+), 4 deletions(-) diff --git a/R/PMoptions.R b/R/PMoptions.R index 2a9cfd93f..b3639f09f 100755 --- a/R/PMoptions.R +++ b/R/PMoptions.R @@ -28,6 +28,29 @@ pm_options_user_file <- function() { file.path(pm_options_user_dir(), "PMoptions.json") } +pm_options_default_file <- function() { + file.path(system.file("options", package = "Pmetrics"), "PMoptions.json") +} + +pm_options_load_defaults <- function() { + defaults_path <- pm_options_default_file() + if (!file.exists(defaults_path)) { + return(list()) + } + jsonlite::read_json(defaults_path, simplifyVector = TRUE) +} + +pm_options_merge_defaults <- function(user_settings) { + defaults <- pm_options_load_defaults() + if (length(defaults) == 0) { + return(user_settings) + } + if (is.null(user_settings) || length(user_settings) == 0) { + return(defaults) + } + utils::modifyList(defaults, user_settings) +} + pm_remote_default_settings <- function() { list( profile_name = "default", @@ -55,7 +78,7 @@ getPMoptions <- function(opt, warn = TRUE, quiet = FALSE) { if (dir.exists(opt_dir)) { # external options file exists PMoptionsFile <- file.path(opt_dir, "PMoptions.json") } else { # external options file does not exist - PMoptionsFile <- paste(system.file("options", package = "Pmetrics"), "PMoptions.json", sep = "/") + PMoptionsFile <- pm_options_default_file() } @@ -66,7 +89,8 @@ getPMoptions <- function(opt, warn = TRUE, quiet = FALSE) { } # read the options file - PMopts <- jsonlite::read_json(path = PMoptionsFile, simplifyVector = TRUE) + PMopts_raw <- jsonlite::read_json(path = PMoptionsFile, simplifyVector = TRUE) + PMopts <- pm_options_merge_defaults(PMopts_raw) if (missing(opt)) { return(PMopts) } else { @@ -106,7 +130,7 @@ setPMoptions <- function(launch.app = TRUE) { # If file doesn't exist in user space, copy default if (!fs::file_exists(PMoptionsUserFile)) { - PMoptionsFile <- glue::glue(system.file("options", package = "Pmetrics"), "/PMoptions.json") + PMoptionsFile <- pm_options_default_file() fs::file_copy(PMoptionsFile, PMoptionsUserFile, overwrite = TRUE) } @@ -114,6 +138,7 @@ setPMoptions <- function(launch.app = TRUE) { jsonlite::read_json(PMoptionsUserFile, simplifyVector = TRUE), error = function(e) list() ) + settings <- pm_options_merge_defaults(settings) remote_defaults <- pm_remote_default_settings() remote_settings <- remote_defaults diff --git a/inst/options/PMoptions.json b/inst/options/PMoptions.json index 3e6482411..e2eb46d5c 100755 --- a/inst/options/PMoptions.json +++ b/inst/options/PMoptions.json @@ -2,6 +2,13 @@ "sep": [","], "dec": ["."], "lang": ["en"], + "digits": [3], + "show_metrics": [true], + "bias_method": ["percent_mwe"], + "imp_method": ["percent_rmbawse"], + "use_percent": [true], + "ic_method": ["aic"], + "report_template": ["plotly"], "backend": ["rust"], "op_stats": [true], "remote": { diff --git a/scripts/bke_remote.R b/scripts/bke_remote.R index e3c77b949..b9252f619 100644 --- a/scripts/bke_remote.R +++ b/scripts/bke_remote.R @@ -86,9 +86,10 @@ fit_result <- mod$fit( points = 2028, seed = 22, remote = TRUE, - remote_config = profile_cfg, + remote_config = profile_cfg ) # This returns a PM_result object via Hermes print(fit_result$runInfo) +# fit_result$op$plot() # # Stage working directories similar to PM_model$fit ----------------------- # run_root <- file.path("examples", "bke", "pmfit_remote") From e74d83fe99a55e00d4359011cabe96c9b10084de Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Juli=C3=A1n=20D=2E=20Ot=C3=A1lvaro?= Date: Tue, 18 Nov 2025 12:57:43 +0000 Subject: [PATCH 3/4] working using default settings --- R/PM_model.R | 13 +-- R/PMoptions.R | 175 +++++++++++++++++++++++++++++++++++++-- R/hermes_remote_client.R | 2 +- R/hermes_remote_config.R | 28 +++++-- scripts/bke_remote.R | 106 ++---------------------- 5 files changed, 192 insertions(+), 132 deletions(-) diff --git a/R/PM_model.R b/R/PM_model.R index fb5928c0a..d6d41c694 100644 --- a/R/PM_model.R +++ b/R/PM_model.R @@ -962,9 +962,6 @@ PM_model <- R6::R6Class( #' @param remote Optional logical flag to override the backend defined via [setPMoptions]. #' When `TRUE`, the fit runs via Hermes remote execution; when `FALSE`, the local Rust backend #' is forced. If `NULL` (default) the backend follows the current option setting. - #' @param remote_config Optional list of Hermes profile overrides passed to [pm_remote_profile_config]. - #' Use this to provide run-specific queue or credential settings without changing global options. - #' Ignored unless `remote = TRUE` (either explicitly or via [setPMoptions]). #' @param report If missing, the default Pmetrics report template as specified in [getPMoptions] #' is used. Otherwise can be "plotly", "ggplot", or "none". #' @return A successful run will result in creation of a new folder in the working @@ -986,7 +983,6 @@ PM_model <- R6::R6Class( overwrite = FALSE, algorithm = "NPAG", # POSTPROB for posteriors, select when cycles = 0, allow for "NPOD" remote = NULL, - remote_config = NULL, report = getPMoptions("report_template")) { msg <- character() # status message at end of run run_error <- 0 @@ -1118,13 +1114,6 @@ PM_model <- R6::R6Class( "i" = "See help for {.fn setPMoptions}" )) } - if (!is.null(remote_config) && backend != "remote") { - cli::cli_warn(c( - "!" = "Ignoring {.arg remote_config} because the remote backend is not active.", - "i" = "Set {.arg remote = TRUE} to use the provided configuration." - )) - } - #### Include or exclude subjects #### if (is.null(include)) { include <- unique(data$standard_data$id) @@ -1285,7 +1274,7 @@ PM_model <- R6::R6Class( PM_parse(path = out_path) res <- PM_load(path = normalizePath(out_path), file = "PMout.Rdata") } else { - profile_cfg <- pm_remote_profile_config(config = remote_config) + profile_cfg <- pm_remote_profile_config() pm_remote_validate_profile_config(profile_cfg) data_csv <- readr::read_file(gendata_path) payload <- pm_remote_build_payload( diff --git a/R/PMoptions.R b/R/PMoptions.R index b3639f09f..9a3864ae6 100755 --- a/R/PMoptions.R +++ b/R/PMoptions.R @@ -53,13 +53,13 @@ pm_options_merge_defaults <- function(user_settings) { pm_remote_default_settings <- function() { list( - profile_name = "default", - base_url = "", + profile_name = "bke-example", + base_url = "http://localhost:8080", queue = "heavy-jobs", - poll_interval_sec = 5, + poll_interval_sec = 2, timeout_sec = 3600, verify_tls = TRUE, - api_key_alias = "hermes-default" + api_key_alias = "hermes-bke" ) } @@ -71,6 +71,103 @@ pm_options_store_remote_key <- function(alias, api_key) { handler(alias, api_key) } +pm_options_persist_settings <- function(settings, path) { + jsonlite::write_json(settings, path, pretty = TRUE, auto_unbox = TRUE) +} + +pm_options_numeric_or_default <- function(value, fallback, min_value = NULL) { + numeric_value <- suppressWarnings(as.numeric(value)) + if (length(numeric_value) != 1 || is.na(numeric_value) || !is.finite(numeric_value)) { + numeric_value <- fallback + } + if (!is.null(min_value) && numeric_value < min_value) { + numeric_value <- min_value + } + numeric_value +} + +pm_options_remote_validators <- function() { + list( + normalize_url = get0("pm_remote_normalize_url", mode = "function"), + validate_queue = get0("pm_remote_validate_queue", mode = "function"), + validate_numeric = get0("pm_remote_validate_numeric", mode = "function"), + validate_profile = get0("pm_remote_validate_profile", mode = "function"), + profile_config = get0("pm_remote_validate_profile_config", mode = "function") + ) +} + +pm_options_normalize_remote_override <- function(remote) { + if (is.null(remote) || !is.list(remote) || length(remote) == 0) { + return(NULL) + } + + normalized <- list() + normalized$profile_name <- remote$profile_name %||% remote$profile + normalized$base_url <- remote$base_url %||% remote$url + normalized$queue <- remote$queue + normalized$poll_interval_sec <- remote$poll_interval_sec %||% remote$poll_interval + normalized$timeout_sec <- remote$timeout_sec %||% remote$timeout + + if (!is.null(remote$verify_tls)) { + normalized$verify_tls <- isTRUE(remote$verify_tls) + } + if (!is.null(remote$allow_insecure)) { + normalized$verify_tls <- !isTRUE(remote$allow_insecure) + } + + normalized$api_key_alias <- remote$api_key_alias %||% remote$alias + compact_normalized <- Filter(function(x) !is.null(x), normalized) + if (length(compact_normalized) == 0) { + return(NULL) + } + compact_normalized +} + +pm_options_validate_remote <- function(values, defaults, require_base_url = FALSE) { + candidate <- defaults + if (!is.null(values) && length(values) > 0) { + candidate <- utils::modifyList(candidate, values) + } + + candidate$profile_name <- candidate$profile_name %||% defaults$profile_name %||% "default" + candidate$api_key_alias <- candidate$api_key_alias %||% defaults$api_key_alias %||% paste0("hermes-", candidate$profile_name) + candidate$queue <- candidate$queue %||% defaults$queue + candidate$poll_interval_sec <- pm_options_numeric_or_default(candidate$poll_interval_sec, defaults$poll_interval_sec, min_value = 1) + candidate$timeout_sec <- pm_options_numeric_or_default(candidate$timeout_sec, defaults$timeout_sec, min_value = 30) + candidate$verify_tls <- isTRUE(candidate$verify_tls) + + if (!nzchar(candidate$base_url %||% "")) { + if (isTRUE(require_base_url)) { + stop("Hermes base URL is required when using the remote backend.", call. = FALSE) + } + candidate$base_url <- candidate$base_url %||% "" + candidate$queue <- trimws(candidate$queue) + candidate$api_key_alias <- trimws(candidate$api_key_alias) + if (!nzchar(candidate$api_key_alias)) { + candidate$api_key_alias <- paste0("hermes-", candidate$profile_name) + } + return(candidate) + } + + validators <- pm_options_remote_validators() + if (any(vapply(validators, is.null, logical(1)))) { + stop("Hermes remote helpers are unavailable; reinstall Pmetrics to enable remote fits.", call. = FALSE) + } + + candidate$profile_name <- validators$validate_profile(candidate$profile_name) + candidate$base_url <- validators$normalize_url(candidate$base_url) + candidate$queue <- validators$validate_queue(candidate$queue) + candidate$poll_interval_sec <- validators$validate_numeric(candidate$poll_interval_sec, name = "poll_interval", min_value = 1) + candidate$timeout_sec <- validators$validate_numeric(candidate$timeout_sec, name = "timeout", min_value = 30) + candidate$verify_tls <- isTRUE(candidate$verify_tls) + candidate$api_key_alias <- trimws(candidate$api_key_alias) + if (!nzchar(candidate$api_key_alias)) { + candidate$api_key_alias <- paste0("hermes-", candidate$profile_name) + } + validators$profile_config(candidate) + candidate +} + getPMoptions <- function(opt, warn = TRUE, quiet = FALSE) { # check for existing options opt_dir <- pm_options_user_dir() @@ -117,12 +214,20 @@ getPMoptions <- function(opt, warn = TRUE, quiet = FALSE) { #' of the Pmetrics package, so that your options will persist when Pmetrics is updated. #' #' @param launch.app Launch the app to set options. Default `TRUE`. +#' @param backend Optional backend override when calling programmatically. Use +#' `"remote"` to select Hermes by default. +#' @param remote Optional named list of Hermes remote settings (e.g., base URL, +#' queue, poll/poll_interval_sec, timeout/timeout_sec, verify_tls, +#' profile_name, api_key_alias). When supplied, the settings are validated and +#' written without launching the UI. +#' @param remote_api_key Optional Hermes API key to store in the system keychain +#' when updating remote settings programmatically. #' @return The user preferences file will be updated. This will persist from session to session #' and if stored in the external location, through Pmetrics versions. #' @author Michael Neely #' @export -setPMoptions <- function(launch.app = TRUE) { +setPMoptions <- function(launch.app = TRUE, backend = NULL, remote = NULL, remote_api_key = NULL) { opt_dir <- pm_options_user_dir() fs::dir_create(opt_dir) # ensure directory exists @@ -146,11 +251,42 @@ setPMoptions <- function(launch.app = TRUE) { remote_settings <- utils::modifyList(remote_defaults, settings$remote) } + remote_override <- pm_options_normalize_remote_override(remote) + overrides_requested <- !is.null(remote_override) || !is.null(backend) || !is.null(remote_api_key) + + if (overrides_requested) { + target_backend <- backend %||% settings$backend %||% "rust" + candidate <- remote_settings + if (!is.null(remote_override)) { + candidate <- utils::modifyList(candidate, remote_override) + } + override_names <- names(remote_override %||% list()) + require_base_url <- identical(target_backend, "remote") || ("base_url" %in% override_names) + candidate <- pm_options_validate_remote(candidate, remote_defaults, require_base_url = require_base_url) + remote_settings <- candidate + settings$remote <- remote_settings + if (!is.null(backend)) { + settings$backend <- backend + } + pm_options_persist_settings(settings, PMoptionsUserFile) + + if (!is.null(remote_api_key) && nzchar(remote_api_key)) { + alias <- remote_settings$api_key_alias %||% remote_defaults$api_key_alias + pm_options_store_remote_key(alias, remote_api_key) + } + + if (!isTRUE(launch.app)) { + return(invisible(settings)) + } + } + settings$remote_base_url <- remote_settings$base_url settings$remote_queue <- remote_settings$queue settings$remote_poll_interval <- remote_settings$poll_interval_sec settings$remote_timeout <- remote_settings$timeout_sec settings$remote_allow_insecure <- !isTRUE(remote_settings$verify_tls) + settings$remote_profile_name <- remote_settings$profile_name + settings$remote_api_key_alias <- remote_settings$api_key_alias app <- shiny::shinyApp( @@ -190,6 +326,9 @@ setPMoptions <- function(launch.app = TRUE) { condition = "input.backend == 'remote'", shiny::div( class = "mt-3", + shiny::textInput("remote_profile_name", "Profile name", + value = remote_settings$profile_name %||% "default" + ), shiny::textInput("remote_base_url", "Hermes base URL", placeholder = "https://hermes.example.com", value = remote_settings$base_url @@ -204,6 +343,9 @@ setPMoptions <- function(launch.app = TRUE) { shiny::checkboxInput("remote_allow_insecure", "Disable TLS verification (local testing only)", value = !remote_settings$verify_tls ), + shiny::textInput("remote_api_key_alias", "API key alias", + value = remote_settings$api_key_alias + ), shiny::passwordInput("remote_api_key", "Hermes API key", value = ""), shiny::helpText("API keys are saved to the system keychain. Leave blank to keep the stored key.") ) @@ -289,7 +431,9 @@ setPMoptions <- function(launch.app = TRUE) { remote_queue = shiny::updateTextInput, remote_poll_interval = shiny::updateNumericInput, remote_timeout = shiny::updateNumericInput, - remote_allow_insecure = shiny::updateCheckboxInput + remote_allow_insecure = shiny::updateCheckboxInput, + remote_profile_name = shiny::updateTextInput, + remote_api_key_alias = shiny::updateTextInput ) @@ -323,14 +467,27 @@ setPMoptions <- function(launch.app = TRUE) { shiny::observeEvent(input$save, { percent_prefix <- c("", "percent_")[1 + as.numeric(input$use_percent)] remote_payload <- list( - profile_name = remote_settings$profile_name %||% "default", + profile_name = input$remote_profile_name %||% remote_settings$profile_name %||% "default", base_url = input$remote_base_url %||% "", queue = input$remote_queue %||% "heavy-jobs", poll_interval_sec = as.numeric(input$remote_poll_interval %||% remote_defaults$poll_interval_sec), timeout_sec = as.numeric(input$remote_timeout %||% remote_defaults$timeout_sec), verify_tls = !isTRUE(input$remote_allow_insecure), - api_key_alias = remote_settings$api_key_alias %||% remote_defaults$api_key_alias + api_key_alias = input$remote_api_key_alias %||% remote_settings$api_key_alias %||% remote_defaults$api_key_alias + ) + + require_remote <- identical(input$backend, "remote") || nzchar(remote_payload$base_url) + remote_payload <- tryCatch( + pm_options_validate_remote(remote_payload, remote_defaults, require_base_url = require_remote), + error = function(e) { + shiny::showNotification(e$message, type = "error", duration = 6) + return(NULL) + } ) + if (is.null(remote_payload)) { + return(invisible(NULL)) + } + settings <- list( sep = input$sep, dec = input$dec, @@ -344,7 +501,7 @@ setPMoptions <- function(launch.app = TRUE) { remote = remote_payload ) - save_status <- tryCatch(jsonlite::write_json(settings, PMoptionsUserFile, pretty = TRUE, auto_unbox = TRUE), + save_status <- tryCatch(pm_options_persist_settings(settings, PMoptionsUserFile), error = function(e) { shiny::showNotification( paste("Error saving settings:", e$message), diff --git a/R/hermes_remote_client.R b/R/hermes_remote_client.R index 77876601e..c823ea9fd 100644 --- a/R/hermes_remote_client.R +++ b/R/hermes_remote_client.R @@ -195,7 +195,7 @@ pm_remote_wait_for_job <- function(job_id, profile = NULL, config = NULL, poll_i stop(sprintf("Hermes job %s failed: %s", job_id, status$error), call. = FALSE) } - if (identical(message, "Job completed successfully")) { + if (message %in% c("Artifacts uploaded", "Job completed successfully")) { return(list(status = status, history = history, profile = prof)) } diff --git a/R/hermes_remote_config.R b/R/hermes_remote_config.R index c8014d9cc..c07238c4b 100644 --- a/R/hermes_remote_config.R +++ b/R/hermes_remote_config.R @@ -12,13 +12,13 @@ if (!exists("%||%", mode = "function")) { pm_remote_default_settings <- function() { list( - profile_name = "default", - base_url = "", + profile_name = "bke-example", + base_url = "http://localhost:8080", queue = "heavy-jobs", - poll_interval_sec = 5, + poll_interval_sec = 2, timeout_sec = 3600, verify_tls = TRUE, - api_key_alias = "hermes-default" + api_key_alias = "hermes-bke" ) } @@ -56,6 +56,8 @@ pm_options_user_file <- function() { #' @param allow_insecure Set to `TRUE` only for local testing with self-signed #' certificates. Production deployments should always verify TLS. #' @param profile Named profile to create or update (defaults to `"default"`). +#' @param api_key_alias Optional keyring alias to associate with the profile. +#' Defaults to `"hermes-"` + `profile`. #' @param set_active When `TRUE`, mark this profile as the active remote target. #' #' @return The profile definition (invisibly). @@ -68,6 +70,7 @@ pm_remote_configure <- function( timeout = 3600, allow_insecure = FALSE, profile = "default", + api_key_alias = NULL, set_active = TRUE) { if (missing(base_url) || !is.character(base_url) || length(base_url) != 1) { stop("base_url must be a single string", call. = FALSE) @@ -79,7 +82,14 @@ pm_remote_configure <- function( timeout <- pm_remote_validate_numeric(timeout, name = "timeout", min_value = 30) profile <- pm_remote_validate_profile(profile) - api_key_alias <- paste0("hermes-", profile) + if (!is.null(api_key_alias)) { + if (!is.character(api_key_alias) || length(api_key_alias) != 1 || !nzchar(api_key_alias)) { + stop("api_key_alias must be a non-empty string", call. = FALSE) + } + api_key_alias <- trimws(api_key_alias) + } else { + api_key_alias <- paste0("hermes-", profile) + } profile_entry <- list( profile_name = profile, base_url = base_url, @@ -166,13 +176,13 @@ if (!exists("%||%", mode = "function")) { pm_remote_default_settings <- function() { list( - profile_name = "default", - base_url = "", + profile_name = "bke-example", + base_url = "http://localhost:8080", queue = "heavy-jobs", - poll_interval_sec = 5, + poll_interval_sec = 2, timeout_sec = 3600, verify_tls = TRUE, - api_key_alias = "hermes-default" + api_key_alias = "hermes-bke" ) } diff --git a/scripts/bke_remote.R b/scripts/bke_remote.R index b9252f619..e3f41d34b 100644 --- a/scripts/bke_remote.R +++ b/scripts/bke_remote.R @@ -12,13 +12,10 @@ # Usage: # Rscript bke_remote.R # -# Environment overrides: -# HERMES_URL Base URL for Hermes (default http://localhost:8080) -# HERMES_QUEUE Queue name (default heavy-jobs) -# HERMES_POLL Poll interval seconds (default 2) -# HERMES_TIMEOUT Request timeout seconds (default 3600) -# HERMES_INSECURE Set to 1 to skip TLS verification (local dev only) -# HERMES_API_ALIAS Keyring alias to read (default hermes-bke) +# Remote configuration: +# Use `setPMoptions(launch.app = TRUE)` to point Pmetrics at your Hermes deployment. +# The packaged defaults target http://localhost:8080, queue heavy-jobs, poll interval 2s, +# timeout 3600s, TLS verification enabled, API alias hermes-bke, profile bke-example. # # Data source: # ../PMcore/examples/bimodal_ke/bimodal_ke.csv (same as bke.rs) @@ -29,23 +26,7 @@ suppressPackageStartupMessages({ }) devtools::load_all("/Users/siel/code/LAPKB/Pmetrics_rust") -# Resolve Hermes connection details ---------------------------------------- -hermes_url <- Sys.getenv("HERMES_URL", "http://localhost:8080") -hermes_queue <- Sys.getenv("HERMES_QUEUE", "heavy-jobs") -hermes_poll <- as.numeric(Sys.getenv("HERMES_POLL", "2")) -hermes_timeout <- as.numeric(Sys.getenv("HERMES_TIMEOUT", "3600")) -hermes_verify <- !identical(Sys.getenv("HERMES_INSECURE", "0"), "1") -hermes_alias <- Sys.getenv("HERMES_API_ALIAS", "hermes-bke") - -profile_cfg <- pm_remote_profile_config(config = list( - profile_name = "bke-example", - base_url = hermes_url, - queue = hermes_queue, - poll_interval_sec = hermes_poll, - timeout_sec = hermes_timeout, - verify_tls = hermes_verify, - api_key_alias = hermes_alias -)) +profile_cfg <- pm_remote_profile_config() pm_remote_validate_profile_config(profile_cfg) cli_inform(sprintf("Using Hermes profile %s (%s)", profile_cfg$profile_name, profile_cfg$base_url)) @@ -86,81 +67,4 @@ fit_result <- mod$fit( points = 2028, seed = 22, remote = TRUE, - remote_config = profile_cfg ) # This returns a PM_result object via Hermes -print(fit_result$runInfo) -# fit_result$op$plot() - -# # Stage working directories similar to PM_model$fit ----------------------- -# run_root <- file.path("examples", "bke", "pmfit_remote") -# inputs_dir <- file.path(run_root, "inputs") -# outputs_dir <- file.path(run_root, "outputs") -# dir.create(inputs_dir, recursive = TRUE, showWarnings = FALSE) -# dir.create(outputs_dir, recursive = TRUE, showWarnings = FALSE) - -# gendata_path <- file.path(inputs_dir, "gendata.csv") -# data_obj$save(gendata_path, header = FALSE) -# data_csv <- read_file(gendata_path) - -# model_rust <- fit_obj$model$.__enclos_env__$private$render_model_to_rust() -# writeLines(model_rust, file.path(inputs_dir, "model.rs")) -# saveRDS(list(data = data_obj, model = mod), file = file.path(inputs_dir, "fit.rds")) - -# # Prepare Hermes payload from fit configuration -------------------------- -# ranges <- lapply(mod$model_list$pri, function(x) c(x$min, x$max)) -# names(ranges) <- tolower(names(ranges)) - -# fit_params <- list( -# ranges = ranges, -# algorithm = "NPAG", -# error_models = lapply(mod$model_list$err, function(x) x$flatten()), -# idelta = 0.1, -# tad = 0, -# max_cycles = 1000, -# prior = "sobol", -# points = 2028, -# seed = 22 -# ) - -# payload <- pm_remote_build_payload( -# model_txt = model_rust, -# data_csv = data_csv, -# settings = fit_params -# ) - -# # Submit job --------------------------------------------------------------- -# job <- pm_remote_enqueue(payload, config = profile_cfg) -# cli_inform(sprintf("Hermes job %s enqueued on %s", job$job_id, job$queue)) - -# status <- pm_remote_wait_for_job(job$job_id, config = profile_cfg) -# job_status <- status$status$status -# if (is.null(job_status)) { -# job_status <- "(unknown)" -# } -# cli_inform(sprintf("Job %s finished with status: %s", job$job_id, job_status)) - -# result <- pm_remote_fetch_result(job$job_id, config = profile_cfg) -# if (is.null(result$result) || !isTRUE(result$result$success)) { -# stop("Hermes job did not return a successful FitResult.") -# } - -# # Materialize outputs + parse via Pmetrics --------------------------------- -# prepared <- pm_remote_prepare_result(result$result) -# pm_remote_write_outputs(prepared, outputs_dir) -# jsonlite::write_json(result, file.path(outputs_dir, "hermes_result.json"), pretty = TRUE, auto_unbox = TRUE) - -# job_meta <- list( -# job = job, -# profile = profile_cfg[c("profile_name", "base_url", "queue")], -# status = status$status, -# history = status$history -# ) -# jsonlite::write_json(job_meta, file.path(inputs_dir, "hermes_job.json"), pretty = TRUE, auto_unbox = TRUE) - -# cli_inform(sprintf("Artifacts written to %s", normalizePath(run_root))) - -# PM_parse(path = outputs_dir) -# fit_result <- PM_load(path = outputs_dir, file = "PMout.Rdata") -# cli_inform("PM_result successfully reconstructed from Hermes payload.") - -# print(fit_result$runInfo) From 4adb4f083fd00086d3d3b881f596ea8713dbfc3e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Juli=C3=A1n=20D=2E=20Ot=C3=A1lvaro?= Date: Tue, 18 Nov 2025 13:14:47 +0000 Subject: [PATCH 4/4] trying to set the remote options via the setPMoptions shiny app --- R/PMoptions.R | 70 ++++++++++++++++++++++++--------------------------- 1 file changed, 33 insertions(+), 37 deletions(-) diff --git a/R/PMoptions.R b/R/PMoptions.R index 9a3864ae6..c0e3b6480 100755 --- a/R/PMoptions.R +++ b/R/PMoptions.R @@ -312,44 +312,40 @@ setPMoptions <- function(launch.app = TRUE, backend = NULL, remote = NULL, remot value = 3, min = 0, max = 10, step = 1 ) ), - shiny::conditionalPanel( - condition = "input.show == false", - # Fit options - shiny::tags$details( - shiny::tags$summary("🔍 Fit Options"), - shiny::selectInput("backend", "Default backend", - choices = c("Rust" = "rust", "Hermes Remote" = "remote"), - selected = settings$backend %||% "rust" + # Fit options + shiny::tags$details( + shiny::tags$summary("🔍 Fit Options"), + shiny::selectInput("backend", "Default backend", + choices = c("Rust" = "rust", "Hermes Remote" = "remote"), + selected = settings$backend %||% "rust" + ), + shiny::markdown("Select Hermes Remote to run fits via the Hermes service."), + shiny::div( + class = "mt-3 p-3 border rounded bg-light", + shiny::tags$strong("Hermes Remote Settings"), + shiny::helpText("These values are used whenever the backend is set to Hermes Remote."), + shiny::textInput("remote_profile_name", "Profile name", + value = remote_settings$profile_name %||% "default" ), - shiny::markdown("Select Hermes Remote to run fits via the Hermes service."), - shiny::conditionalPanel( - condition = "input.backend == 'remote'", - shiny::div( - class = "mt-3", - shiny::textInput("remote_profile_name", "Profile name", - value = remote_settings$profile_name %||% "default" - ), - shiny::textInput("remote_base_url", "Hermes base URL", - placeholder = "https://hermes.example.com", - value = remote_settings$base_url - ), - shiny::textInput("remote_queue", "Queue name", value = remote_settings$queue), - shiny::numericInput("remote_poll_interval", "Poll interval (seconds)", - value = remote_settings$poll_interval_sec, min = 1, step = 1 - ), - shiny::numericInput("remote_timeout", "Request timeout (seconds)", - value = remote_settings$timeout_sec, min = 30, step = 30 - ), - shiny::checkboxInput("remote_allow_insecure", "Disable TLS verification (local testing only)", - value = !remote_settings$verify_tls - ), - shiny::textInput("remote_api_key_alias", "API key alias", - value = remote_settings$api_key_alias - ), - shiny::passwordInput("remote_api_key", "Hermes API key", value = ""), - shiny::helpText("API keys are saved to the system keychain. Leave blank to keep the stored key.") - ) - ) + shiny::textInput("remote_base_url", "Hermes base URL", + placeholder = "https://hermes.example.com", + value = remote_settings$base_url + ), + shiny::textInput("remote_queue", "Queue name", value = remote_settings$queue), + shiny::numericInput("remote_poll_interval", "Poll interval (seconds)", + value = remote_settings$poll_interval_sec, min = 1, step = 1 + ), + shiny::numericInput("remote_timeout", "Request timeout (seconds)", + value = remote_settings$timeout_sec, min = 30, step = 30 + ), + shiny::checkboxInput("remote_allow_insecure", "Disable TLS verification (local testing only)", + value = !remote_settings$verify_tls + ), + shiny::textInput("remote_api_key_alias", "API key alias", + value = remote_settings$api_key_alias + ), + shiny::passwordInput("remote_api_key", "Hermes API key", value = ""), + shiny::helpText("API keys are saved to the system keychain. Leave blank to keep the stored key.") ) ), shiny::tags$details(