feat: Domain specific language

Cargo.toml

@@ -14,3 +14,6 @@ exclude = [
 
 [profile.release]
 panic = "unwind"
+
+# [patch."https://github.com/LAPKB/PMcore"]
+# pmcore = { path = "../PMcore-structure" }

DESCRIPTION

@@ -28,6 +28,7 @@ Depends:
     R (>= 4.2)
 Imports:
     bslib,
+    callr,
     cli,
     clipr,
     crayon,
@@ -40,6 +41,7 @@ Imports:
     grid,
     htmltools,
     htmlwidgets,
+    httpuv,
     jsonlite,
     knitr,
     lifecycle,
@@ -79,7 +81,7 @@ Suggests:
 VignetteBuilder: 
     knitr
 Config/Needs/website: r-lib/pkgdown, quarto
-Config/rextendr/version: 0.4.2
+Config/rextendr/version: 0.5.0
 Config/roxygen2/version: 8.0.0
 Config/testthat/edition: 3
 Encoding: UTF-8

NAMESPACE

@@ -20,6 +20,7 @@ S3method(plot,PMvalid)
 S3method(print,PM_compare)
 S3method(print,PMerr)
 S3method(print,PMnpc)
+S3method(print,pm_dsl)
 S3method(print,summary.PM_cycle)
 S3method(print,summary.PM_data)
 S3method(print,summary.PM_final)
@@ -59,7 +60,6 @@ export(PM_manual)
 export(PM_model)
 export(PM_op)
 export(PM_opt)
-export(PM_parse)
 export(PM_pop)
 export(PM_post)
 export(PM_pta)
@@ -102,11 +102,10 @@ export(clear_build)
 export(cli_ask)
 export(cli_df)
 export(click_plot)
-export(compile_model)
+export(close_live_session)
 export(cor2cov)
 export(create_pmetrics_project)
 export(downloadR)
-export(dummy_compile)
 export(export_plotly)
 export(fit)
 export(getCov)
@@ -118,6 +117,7 @@ export(interp)
 export(is_cargo_installed)
 export(latestR)
 export(lit_sim)
+export(load_pm_parse_fit_object)
 export(makeAUC)
 export(makeErrorPoly)
 export(makeNCA)
@@ -140,6 +140,8 @@ export(plotlygg)
 export(pm_plot)
 export(pos_def)
 export(proportional)
+export(publish_live_report_failed)
+export(publish_live_report_result)
 export(qgrowth)
 export(rgba_to_rgb)
 export(round2)
@@ -149,9 +151,9 @@ export(setup_logs)
 export(simulate_all)
 export(simulate_one)
 export(ss.PK)
+export(start_live_session)
 export(sub_plot)
 export(template)
-export(temporary_path)
 export(three_comp_bolus)
 export(three_comp_bolus_cl)
 export(three_comp_iv)
@@ -160,6 +162,8 @@ export(two_comp_bolus)
 export(two_comp_bolus_cl)
 export(two_comp_iv)
 export(two_comp_iv_cl)
+export(validate_model_source)
+export(wait_live_session_connected)
 export(zBMI)
 importFrom(R6,R6Class)
 importFrom(bslib,accordion)

R/PM_bridge_errors.R

@@ -0,0 +1,198 @@
+pm_bridge_error_prefix <- "PMETRICS_BRIDGE_ERROR="
+
+pm_bridge_scalar <- function(x) {
+  if (is.null(x) || !length(x)) {
+    return(NULL)
+  }
+
+  x[[1]]
+}
+
+pm_bridge_first_or <- function(x, default = NULL) {
+  value <- pm_bridge_scalar(x)
+  if (is.null(value)) {
+    return(default)
+  }
+
+  value
+}
+
+pm_bridge_stage <- function(stage, default_stage = "runtime") {
+  stage <- pm_bridge_scalar(stage)
+  if (is.null(stage) || !nzchar(as.character(stage))) {
+    return(default_stage)
+  }
+
+  stage <- tolower(as.character(stage))
+  if (!stage %in% c("compile", "data", "settings", "runtime", "handoff")) {
+    return(default_stage)
+  }
+
+  stage
+}
+
+parse_pm_bridge_error <- function(message) {
+  message <- as.character(message[[1]])
+  if (!nzchar(message)) {
+    return(list(
+      structured = FALSE,
+      kind = "error",
+      schema_version = NULL,
+      stage = NULL,
+      code = NULL,
+      message = "",
+      diagnostic = NULL,
+      details = list()
+    ))
+  }
+
+  prefix_loc <- regexpr(pm_bridge_error_prefix, message, fixed = TRUE)[[1]]
+  if (is.na(prefix_loc) || prefix_loc < 1) {
+    return(list(
+      structured = FALSE,
+      kind = "error",
+      schema_version = NULL,
+      stage = NULL,
+      code = NULL,
+      message = message,
+      diagnostic = NULL,
+      details = list()
+    ))
+  }
+
+  display_message <- sub("[\r\n]+$", "", substr(message, 1, prefix_loc - 1))
+  payload_text <- substr(message, prefix_loc + nchar(pm_bridge_error_prefix), nchar(message))
+  payload <- tryCatch(
+    jsonlite::fromJSON(payload_text, simplifyVector = FALSE),
+    error = function(e) NULL
+  )
+
+  if (!is.list(payload)) {
+    return(list(
+      structured = FALSE,
+      kind = "error",
+      schema_version = NULL,
+      stage = NULL,
+      code = NULL,
+      message = if (nzchar(display_message)) display_message else message,
+      diagnostic = NULL,
+      details = list()
+    ))
+  }
+
+  details <- payload$details
+  if (!is.list(details)) {
+    details <- list()
+  }
+
+  diagnostic <- pm_bridge_scalar(payload$diagnostic)
+  if (!is.null(diagnostic)) {
+    diagnostic <- as.character(diagnostic)
+  }
+
+  list(
+    structured = TRUE,
+    kind = as.character(pm_bridge_first_or(payload$kind, "error")),
+    schema_version = pm_bridge_scalar(payload$schema_version),
+    stage = pm_bridge_stage(payload$stage),
+    code = as.character(pm_bridge_first_or(payload$code, "bridge_error")),
+    message = if (nzchar(display_message)) {
+      display_message
+    } else {
+      as.character(pm_bridge_first_or(payload$message, message))
+    },
+    diagnostic = diagnostic,
+    details = details
+  )
+}
+
+pm_bridge_error_classes <- function(stage, structured = TRUE) {
+  stage_class <- paste0("pmetrics_bridge_", pm_bridge_stage(stage), "_error")
+  if (isTRUE(structured)) {
+    return(c(stage_class, "pmetrics_bridge_error"))
+  }
+
+  c(stage_class, "pmetrics_bridge_unstructured_error", "pmetrics_bridge_error")
+}
+
+abort_pm_bridge_message <- function(
+  message,
+  stage,
+  code,
+  diagnostic = NULL,
+  details = list(),
+  parent = NULL,
+  structured = TRUE,
+  schema_version = NULL
+) {
+  message <- as.character(pm_bridge_first_or(message, ""))
+  if (!nzchar(message) && !is.null(diagnostic)) {
+    message <- as.character(diagnostic)
+  }
+
+  if (!is.list(details)) {
+    details <- list()
+  }
+
+  rlang::abort(
+    message = message,
+    class = pm_bridge_error_classes(stage, structured = structured),
+    stage = pm_bridge_stage(stage),
+    code = as.character(pm_bridge_first_or(code, "bridge_error")),
+    diagnostic = if (is.null(diagnostic)) NULL else as.character(diagnostic),
+    details = details,
+    structured = isTRUE(structured),
+    schema_version = schema_version,
+    parent = parent
+  )
+}
+
+abort_pm_bridge_error <- function(
+  error,
+  default_stage = "runtime",
+  default_code = "bridge_error",
+  details = list()
+) {
+  bridge_error <- parse_pm_bridge_error(conditionMessage(error))
+  bridge_details <- bridge_error$details
+  if (!is.list(bridge_details)) {
+    bridge_details <- list()
+  }
+  if (is.list(details) && length(details)) {
+    bridge_details <- utils::modifyList(bridge_details, details)
+  }
+
+  abort_pm_bridge_message(
+    message = bridge_error$message,
+    stage = if (is.null(bridge_error$stage)) default_stage else bridge_error$stage,
+    code = if (is.null(bridge_error$code)) default_code else bridge_error$code,
+    diagnostic = bridge_error$diagnostic,
+    details = bridge_details,
+    parent = error,
+    structured = isTRUE(bridge_error$structured),
+    schema_version = bridge_error$schema_version
+  )
+}
+
+call_pm_bridge <- function(code, default_stage = "runtime", default_code = "bridge_error", details = list()) {
+  tryCatch(
+    code,
+    error = function(error) {
+      abort_pm_bridge_error(
+        error,
+        default_stage = default_stage,
+        default_code = default_code,
+        details = details
+      )
+    }
+  )
+}
+
+utils::globalVariables(c(
+  "call_pm_bridge",
+  "close_live_session",
+  "publish_live_report_failed",
+  "publish_live_report_result",
+  "start_live_session",
+  "wait_live_session_connected"
+))

R/PM_cov.R

@@ -94,31 +94,14 @@ PM_cov <- R6::R6Class(
   ), # end public
   private = list(
     make = function(data, path) {
-      if (file.exists(file.path(path, "posterior.csv"))) {
-        posts <- readr::read_csv(file = file.path(path, "posterior.csv"), show_col_types = FALSE)
-      } else if (inherits(data, "PM_cov") & !is.null(data$data)) { # file not there, and already PM_cov
+      if (inherits(data, "PM_cov") & !is.null(data$data)) { # file not there, and already PM_cov
         class(data$data) <- c("PM_cov_data", "data.frame")
         return(data$data)
-      } else {
-        cli::cli_warn(c(
-          "!" = "Unable to generate covariate-posterior information.",
-          "i" = "{.file {file.path(path, 'posterior.csv')}} does not exist, and result does not have valid {.code PM_cov} object."
-        ))
-        return(NULL)
       }
 
-      if (file.exists(file.path(path, "covs.csv"))) {
-        covs <- readr::read_csv(file = file.path(path, "covs.csv"), show_col_types = FALSE)
-      } else if (inherits(data, "PM_cov")) { # file not there, and already PM_cov
-        class(data$data) <- c("PM_cov_data", "data.frame")
-        return(data$data)
-      } else {
-        cli::cli_warn(c(
-          "!" = "Unable to generate covariate-posterior information.",
-          "i" = "{.file {file.path(path, 'covs.csv')}} does not exist, and result does not have valid {.code PM_cov} object."
-        ))
-        return(NULL)
-      }
+      fit_payload <- fit_payload_from_source(data, path)
+      posts <- tibble::as_tibble(fit_payload$posterior)
+      covs <- tibble::as_tibble(fit_payload$covariates)
 
       covs <- covs |> mutate(block = block + 1)
 
@@ -254,22 +237,21 @@ PM_cov <- R6::R6Class(
 #' @family PMplots
 
 plot.PM_cov <- function(
-  x,
-  formula,
-  line = list(lm = NULL, loess = NULL, ref = NULL),
-  marker = TRUE,
-  colors,
-  icen = "median",
-  include = NULL, exclude = NULL,
-  legend,
-  log = FALSE,
-  grid = TRUE,
-  xlab, ylab,
-  title,
-  stats = TRUE,
-  xlim, ylim,
-  print = TRUE, ...
-) {
+    x,
+    formula,
+    line = list(lm = NULL, loess = NULL, ref = NULL),
+    marker = TRUE,
+    colors,
+    icen = "median",
+    include = NULL, exclude = NULL,
+    legend,
+    log = FALSE,
+    grid = TRUE,
+    xlab, ylab,
+    title,
+    stats = TRUE,
+    xlim, ylim,
+    print = TRUE, ...) {
   if (inherits(x, "PM_cov")) {
     x <- x$data
   }