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..d6d41c694 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,2130 @@ 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 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,
+ 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}"
+ ))
+ }
+ #### 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()
+ 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..c0e3b6480 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,28 +16,178 @@
#' @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_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 = "bke-example",
+ base_url = "http://localhost:8080",
+ queue = "heavy-jobs",
+ poll_interval_sec = 2,
+ timeout_sec = 3600,
+ verify_tls = TRUE,
+ api_key_alias = "hermes-bke"
+ )
+}
+
+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)
+}
+
+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 <- 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 = "/")
+ PMoptionsFile <- pm_options_default_file()
}
-
-
+
+
# 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)
+ PMopts_raw <- jsonlite::read_json(path = PMoptionsFile, simplifyVector = TRUE)
+ PMopts <- pm_options_merge_defaults(PMopts_raw)
if (missing(opt)) {
return(PMopts)
} else {
@@ -61,225 +211,342 @@ 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`.
+#' @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) {
-
-
- # --- 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")
-
+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
+ 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")
+ PMoptionsFile <- pm_options_default_file()
fs::file_copy(PMoptionsFile, PMoptionsUserFile, overwrite = TRUE)
}
-
+
+ settings <- tryCatch(
+ 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
+ if (!is.null(settings$remote)) {
+ 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(
-
+
# --- 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(
- 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"
+ # 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"
),
- 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"
+ 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::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(
+ 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,
+ remote_profile_name = shiny::updateTextInput,
+ remote_api_key_alias = shiny::updateTextInput
)
-
+
# 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 = 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 = 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,
+ 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(pm_options_persist_settings(settings, PMoptionsUserFile),
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..c823ea9fd
--- /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 (message %in% c("Artifacts uploaded", "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..c07238c4b
--- /dev/null
+++ b/R/hermes_remote_config.R
@@ -0,0 +1,334 @@
+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 = "bke-example",
+ base_url = "http://localhost:8080",
+ queue = "heavy-jobs",
+ poll_interval_sec = 2,
+ timeout_sec = 3600,
+ verify_tls = TRUE,
+ api_key_alias = "hermes-bke"
+ )
+}
+
+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 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).
+#' @export
+pm_remote_configure <- function(
+ base_url,
+ api_key = NULL,
+ queue = "heavy-jobs",
+ poll_interval = 5,
+ 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)
+ }
+
+ 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)
+
+ 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,
+ 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 = "bke-example",
+ base_url = "http://localhost:8080",
+ queue = "heavy-jobs",
+ poll_interval_sec = 2,
+ timeout_sec = 3600,
+ verify_tls = TRUE,
+ api_key_alias = "hermes-bke"
+ )
+ }
+
+ 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..e2eb46d5c 100755
--- a/inst/options/PMoptions.json
+++ b/inst/options/PMoptions.json
@@ -2,6 +2,22 @@
"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]
+ "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..e3f41d34b
--- /dev/null
+++ b/scripts/bke_remote.R
@@ -0,0 +1,70 @@
+#!/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
+#
+# 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)
+
+suppressPackageStartupMessages({
+ library(cli)
+ library(readr)
+})
+devtools::load_all("/Users/siel/code/LAPKB/Pmetrics_rust")
+
+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))
+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,
+) # This returns a PM_result object via Hermes
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(())
}