R/mcp_tools.R

In Certara.Xpose.NLME: Enhances 'xpose' Diagnostics for Pharmacometric Models from 'Certara.RsNLME' and Phoenix NLME

# MCP tool layer for Certara.Xpose.NLME.
#
# `xpose_mcp_tools()` is the builder the Certara.R MCP host discovers via
# `inst/mcp/tools/manifest.json` ("builder" mode). It returns a list of
# `ellmer::tool()` objects. Because it declares a `groups` formal, the host
# intersects this provider's groups with the active launch profile and calls
# `xpose_mcp_tools(groups = <intersection>)`; only matching tools are returned.
#
# Tool handlers are package-internal closures (builder mode never resolves them
# by name), so only `xpose_mcp_tools` is exported. Handlers that create an object
# or artifact record the exact runnable R code they ran into the host's shared
# reproducible/audit script via the Certara.R repro SDK (see .xpose_record).

# ---- ellmer type shorthands -------------------------------------------------

.xts <- function(desc, required = FALSE) ellmer::type_string(desc, required = required)
.xti <- function(desc, required = FALSE) ellmer::type_integer(desc, required = required)
.xtn <- function(desc, required = FALSE) ellmer::type_number(desc, required = required)
.xtb <- function(desc, required = FALSE) ellmer::type_boolean(desc, required = required)
.xta_str <- function(desc, required = FALSE) {
  ellmer::type_array(items = ellmer::type_string(), description = desc,
                     required = required)
}

.xptool <- function(fun, name, description, arguments = list()) {
  ellmer::tool(fun, name = name, description = description, arguments = arguments)
}

# ---- reproducible-script recording (delegated to the Certara.R host) ---------
#
# Recording an audit-ready, runnable R script is a core MCP capability owned by
# the host, not by this provider. `.xpose_certara_fn()` (mcp_session.R) only
# resolves a hook when Certara.R has already loaded itself, so these thin
# wrappers record into the shared script when the host is present, and
# degrade to no-ops for standalone/non-host use.

.xpose_repro_libs <- function() c("Certara.Xpose.NLME", "xpose")

# Mark a value to be emitted verbatim (an R symbol/expression), e.g. a handle
# used as the variable name in the recorded script.
.xpose_sym <- function(x) {
  fn <- .xpose_certara_fn("mcp_repro_sym")
  if (!is.null(fn)) fn(x) else structure(as.character(x), class = "mcp_repro_sym")
}

# Render a runnable R call to a string (NULL when no host is available).
.xpose_call <- function(fn, args = list(), var = NULL) {
  call_fn <- .xpose_certara_fn("mcp_repro_call")
  if (!is.null(call_fn)) call_fn(fn, args, var) else NULL
}

# Append a runnable code block to the host's reproducible script.
.xpose_record <- function(code) {
  record_fn <- .xpose_certara_fn("mcp_repro_record")
  if (!is.null(code) && !is.null(record_fn)) {
    record_fn(code, libraries = .xpose_repro_libs())
  }
  invisible(NULL)
}

# Current reproducible-script path (NA when no host is available).
.xpose_repro_path <- function() {
  fn <- .xpose_certara_fn("mcp_repro_path")
  if (!is.null(fn)) fn() else NA_character_
}

# Current report Rmd path (NA when no host is available).
.xpose_report_path <- function() {
  fn <- .xpose_certara_fn("mcp_report_path")
  if (!is.null(fn)) fn() else NA_character_
}

# Register a saved figure in the host report Rmd (no-op without host).
.xpose_report_figure <- function(path, caption, section, key = NULL) {
  fn <- .xpose_certara_fn("mcp_report_figure")
  if (!is.null(fn)) fn(path, caption, section, key = key)
  invisible(NULL)
}

# Standard plot-tool payload (path + repro + report).
.xpose_plot_payload <- function(path, caption, section, key = NULL) {
  .xpose_report_figure(path, caption, section, key = key)
  list(
    plot_path = path,
    repro_script = .xpose_repro_path(),
    report_rmd = .xpose_report_path()
  )
}

# Record the ggsave companion line for a plot tool. Defaults mirror
# .xpose_save_plot() so the recorded code reproduces the saved PNG exactly.
.xpose_record_ggsave <- function(path, width = 7, height = 5, dpi = 150) {
  .xpose_record(.xpose_call(
    "ggplot2::ggsave",
    list(filename = path, plot = .xpose_sym("p"), width = width,
         height = height, dpi = dpi)
  ))
}

# ---- shared helpers ---------------------------------------------------------

# Working directory for saved plots: explicit out_dir wins, else session
# figures/ when the host project root is set, else the run dir the handle was
# created from, else the session temp dir.
.xpose_session_dir <- function(handle, out_dir = NULL) {
  if (!is.null(out_dir) && nzchar(out_dir)) {
    return(out_dir)
  }
  fig_fn <- .xpose_certara_fn("mcp_session_figures_dir")
  if (!is.null(fig_fn)) {
    fig_dir <- fig_fn()
    if (!is.null(fig_dir)) return(fig_dir)
  }
  meta <- .xpose_state$sessions[[handle]]$meta
  d <- meta$dir %||% ""
  if (nzchar(d) && dir.exists(d)) d else tempdir()
}

.xpose_plot_path <- function(out_dir, stem, handle) {
  safe <- gsub("[^A-Za-z0-9_.-]+", "_", stem)
  file.path(out_dir, sprintf("%s_%s.png", safe, handle))
}

# Save any xpose/ggplot/GGally plot to PNG. Tool execution and the recorded code
# both use ggplot2::ggsave() so the script reproduces the file exactly.
.xpose_save_plot <- function(p, path, width = 7, height = 5, dpi = 150) {
  dir.create(dirname(path), showWarnings = FALSE, recursive = TRUE)
  ggplot2::ggsave(filename = path, plot = p, width = width, height = height,
                  dpi = dpi)
  path
}

# Compact, JSON-friendly payload for a table-returning tool.
.xpose_table_payload <- function(df) {
  df <- as.data.frame(df, stringsAsFactors = FALSE)
  list(
    n_rows = nrow(df),
    columns = names(df),
    table = df,
    repro_script = .xpose_repro_path()
  )
}

.xp_resolve_global <- function(var) {
  if (!is.character(var) || length(var) != 1L || !nzchar(var)) {
    stop("Object name must be a single non-empty string.", call. = FALSE)
  }
  if (!exists(var, envir = globalenv(), inherits = TRUE)) {
    stop(sprintf("Object '%s' not found in the R session.", var), call. = FALSE)
  }
  get(var, envir = globalenv(), inherits = TRUE)
}

# ---- data group: create / inspect / tables ----------------------------------

# Read-only, dependency-free check of the `fit_manifest.json` contract a
# Certara.RsNLME fit stamps beside its artifacts (see that package's
# `.mcp_verify_manifest_in_dir()`). Deliberately does not depend on
# Certara.RsNLME (a Suggests, not an Imports, for this package) - it just
# re-hashes the same watched files with `tools::md5sum()` and compares
# against the recorded manifest, so a directory whose
# dmp.txt/residuals.csv/fit.rds was silently overwritten (e.g. by a
# mis-rerooted bootstrap) is caught before an xpdb is built from it. Never
# writes the manifest - only Certara.RsNLME does that, at fit-collection
# time.
.xp_manifest_watched_names <- function() {
  c("dmp.txt", "residuals.csv", "fit.rds")
}

.xp_manifest_watched_files <- function(dir) {
  candidates <- .xp_manifest_watched_names()
  paths <- file.path(dir, candidates)
  stats::setNames(paths, candidates)[file.exists(paths)]
}

.xp_hash_file <- function(path) {
  h <- tryCatch(unname(tools::md5sum(path)), error = function(e) NA_character_)
  if (length(h) != 1L) NA_character_ else h
}

.xp_verify_fit_manifest <- function(dir) {
  manifest_path <- file.path(dir, "fit_manifest.json")
  if (!file.exists(manifest_path)) {
    return(list(status = "not_applicable"))
  }
  recorded <- tryCatch(jsonlite::fromJSON(manifest_path, simplifyVector = TRUE),
                       error = function(e) NULL)
  if (is.null(recorded) || is.null(recorded$artifact_hashes)) {
    return(list(status = "not_applicable"))
  }
  rec_hashes <- recorded$artifact_hashes
  current <- vapply(.xp_manifest_watched_files(dir), .xp_hash_file, character(1))
  # Only compare keys in this package's watched set. Extra keys in a future
  # or extended manifest must not compare against NA and false-trip a
  # violation; within the watched set, union(recorded, present) matches
  # Certara.RsNLME's `.mcp_manifest_diff()` so a newly appeared watched
  # file (or a deleted one) is still flagged.
  watched <- .xp_manifest_watched_names()
  compare_names <- union(
    intersect(names(rec_hashes), watched),
    names(current)
  )
  mismatched <- character(0)
  for (nm in compare_names) {
    rec <- if (nm %in% names(rec_hashes)) {
      as.character(rec_hashes[[nm]])
    } else {
      NA_character_
    }
    cur <- if (nm %in% names(current)) {
      as.character(current[[nm]])
    } else {
      NA_character_
    }
    if (!identical(rec, cur)) {
      mismatched <- c(mismatched, nm)
    }
  }
  if (!length(mismatched)) {
    return(list(status = "ok"))
  }
  list(
    status = "violation",
    mismatched_files = mismatched,
    recorded_at = recorded$recorded_at %||% NA_character_,
    message = paste0(
      "Fit artifacts in '", dir, "' no longer match the fit_manifest.json ",
      "recorded at ", recorded$recorded_at %||% "an earlier collection",
      ". Changed file(s): ", paste(mismatched, collapse = ", "), ". This ",
      "usually means another run (e.g. a bootstrap or a re-fit) wrote into ",
      "this directory after the fit was selected; diagnostics built from it ",
      "would describe the wrong run. Point at the fit's untouched artifacts, ",
      "or pass allow_integrity_violation = TRUE to proceed anyway."
    )
  )
}

.xp_create_from_dir <- function(dir, model_name = "", dmp_file = "dmp.txt",
                                data_file = "data1.txt",
                                log_file = "nlme7engine.log",
                                allow_integrity_violation = FALSE) {
  if (!is.character(dir) || length(dir) != 1L || !nzchar(dir)) {
    stop("`dir` must be a single path to an NLME run directory.", call. = FALSE)
  }
  if (!dir.exists(dir)) {
    stop(sprintf("Run directory does not exist: %s", dir), call. = FALSE)
  }
  integrity <- .xp_verify_fit_manifest(dir)
  if (identical(integrity$status, "violation") &&
      !isTRUE(allow_integrity_violation)) {
    stop("Refusing to build an xpdb: ", integrity$message, call. = FALSE)
  }
  xpdb <- xposeNlme(dir = dir, modelName = model_name, dmpFile = dmp_file,
                    dataFile = data_file, logFile = log_file)
  handle <- .xpose_store(xpdb, meta = list(model_name = model_name, dir = dir))
  .xpose_record(.xpose_call(
    "xposeNlme",
    list(dir = dir, modelName = model_name, dmpFile = dmp_file,
         dataFile = data_file, logFile = log_file),
    var = handle
  ))
  vars <- .xpose_vars_summary(xpdb)
  list(handle = handle, model_name = model_name,
       continuous_covariates = vars$continuous_covariates,
       categorical_covariates = vars$categorical_covariates,
       artifact_integrity = integrity,
       repro_script = .xpose_repro_path())
}

.xp_create_from_fit <- function(fit_var, model_var = NULL) {
  fit <- .xp_resolve_global(fit_var)
  if (!is.null(model_var)) {
    model <- .xp_resolve_global(model_var)
    xpdb <- xposeNlmeModel(model, fit)
    call <- .xpose_call("xposeNlmeModel",
                        list(.xpose_sym(model_var), .xpose_sym(fit_var)))
  } else {
    xpdb <- xposeNlmeModel(fit)
    call <- .xpose_call("xposeNlmeModel", list(.xpose_sym(fit_var)))
  }
  handle <- .xpose_store(xpdb, meta = list(model_name = fit_var))
  if (!is.null(call)) .xpose_record(paste0(handle, " <- ", call))
  vars <- .xpose_vars_summary(xpdb)
  list(handle = handle,
       continuous_covariates = vars$continuous_covariates,
       categorical_covariates = vars$categorical_covariates,
       repro_script = .xpose_repro_path())
}

.xpose_vars_summary <- function(xpdb) {
  idx <- tryCatch(xpdb$data$index[[1]], error = function(e) NULL)
  if (is.null(idx)) {
    return(list(continuous_covariates = character(0),
                categorical_covariates = character(0)))
  }
  list(
    continuous_covariates = .get_cont_cov(idx),
    categorical_covariates = .get_cat_cov(idx)
  )
}

.xp_list_sessions <- function() {
  list(sessions = .xpose_sessions_overview(),
       repro_script = .xpose_repro_path())
}

.xp_list_vars <- function(handle) {
  xpdb <- .xpose_get(handle)
  txt <- paste(utils::capture.output(xpose::list_vars(xpdb)), collapse = "\n")
  .xpose_record(.xpose_call("list_vars", list(.xpose_sym(handle))))
  list(handle = handle, vars = txt, repro_script = .xpose_repro_path())
}

.xp_get_summary <- function(handle, shrinkage = "engine", digits = NULL) {
  xpdb <- .xpose_get(handle)
  df <- get_summaryNlme(xpdb, shrinkage = shrinkage, digits = digits)
  .xpose_record(.xpose_call(
    "get_summaryNlme",
    list(.xpose_sym(handle), shrinkage = shrinkage, digits = digits),
    var = "summary_tbl"
  ))
  .xpose_table_payload(df)
}

.xp_get_params <- function(handle, digits = 6, show_all = FALSE) {
  xpdb <- .xpose_get(handle)
  df <- get_prmNlme(xpdb, digits = digits, show_all = show_all)
  .xpose_record(.xpose_call(
    "get_prmNlme",
    list(.xpose_sym(handle), digits = digits, show_all = show_all),
    var = "prm_tbl"
  ))
  .xpose_table_payload(df)
}

.xp_get_overall <- function(handle, conditionNumber = NULL) {
  xpdb <- .xpose_get(handle)
  df <- get_overallNlme(xpdb, conditionNumber = conditionNumber)
  .xpose_record(.xpose_call(
    "get_overallNlme",
    list(.xpose_sym(handle), conditionNumber = conditionNumber),
    var = "overall_tbl"
  ))
  .xpose_table_payload(df)
}

.xp_get_eta_subject <- function(handle) {
  xpdb <- .xpose_get(handle)
  df <- get_etaSubjectNlme(xpdb)
  .xpose_record(.xpose_call("get_etaSubjectNlme", list(.xpose_sym(handle)),
                            var = "eta_subject_tbl"))
  .xpose_table_payload(df)
}

.xp_get_boot_summary <- function(boot_rds, handle = NULL, metric = "Median",
                                 digits = 3) {
  if (!is.character(boot_rds) || length(boot_rds) != 1L ||
      !file.exists(boot_rds)) {
    stop(sprintf("Bootstrap .rds file not found: %s", boot_rds), call. = FALSE)
  }
  boot_result <- readRDS(boot_rds)
  xpdb <- if (!is.null(handle)) .xpose_get(handle) else NULL
  df <- get_bootSummaryNlme(boot_result, xpdb = xpdb, metric = metric,
                            digits = digits)
  .xpose_record(.xpose_call("readRDS", list(boot_rds), var = "boot_result"))
  .xpose_record(.xpose_call(
    "get_bootSummaryNlme",
    list(.xpose_sym("boot_result"),
         xpdb = if (!is.null(handle)) .xpose_sym(handle) else NULL,
         metric = metric, digits = digits),
    var = "boot_tbl"
  ))
  .xpose_table_payload(df)
}

# ---- interpretation group: diagnostic plots ---------------------------------

.xp_plot_res_vs_cov <- function(handle, covariate, res = "CWRES",
                                type = "bpls", out_dir = NULL) {
  xpdb <- .xpose_get(handle)
  p <- res_vs_cov(xpdb, covariate = covariate, res = res, type = type)
  path <- .xpose_plot_path(.xpose_session_dir(handle, out_dir),
                           paste0("res_vs_", covariate), handle)
  .xpose_save_plot(p, path)
  .xpose_record(.xpose_call(
    "res_vs_cov",
    list(.xpose_sym(handle), covariate = covariate, res = res, type = type),
    var = "p"
  ))
  .xpose_record_ggsave(path)
  stem <- paste0("res_vs_", covariate)
  .xpose_plot_payload(path, sprintf("Residuals vs %s", covariate),
                      section = "diagnostics.covariates", key = stem)
}

.xp_plot_eta_vs_cov <- function(handle, covariate, type = "bpls",
                                out_dir = NULL) {
  xpdb <- .xpose_get(handle)
  p <- eta_vs_cov(xpdb, covariate = covariate, type = type)
  path <- .xpose_plot_path(.xpose_session_dir(handle, out_dir),
                           paste0("eta_vs_", covariate), handle)
  .xpose_save_plot(p, path)
  .xpose_record(.xpose_call(
    "eta_vs_cov",
    list(.xpose_sym(handle), covariate = covariate, type = type),
    var = "p"
  ))
  .xpose_record_ggsave(path)
  stem <- paste0("eta_vs_", covariate)
  .xpose_plot_payload(path, sprintf("ETA vs %s", covariate),
                      section = "diagnostics.covariates", key = stem)
}

.xp_plot_prm_vs_cov <- function(handle, covariate, type = "bpls",
                                out_dir = NULL) {
  xpdb <- .xpose_get(handle)
  p <- prm_vs_cov(xpdb, covariate = covariate, type = type)
  path <- .xpose_plot_path(.xpose_session_dir(handle, out_dir),
                           paste0("prm_vs_", covariate), handle)
  .xpose_save_plot(p, path)
  .xpose_record(.xpose_call(
    "prm_vs_cov",
    list(.xpose_sym(handle), covariate = covariate, type = type),
    var = "p"
  ))
  .xpose_record_ggsave(path)
  stem <- paste0("prm_vs_", covariate)
  .xpose_plot_payload(path, sprintf("Parameters vs %s", covariate),
                      section = "diagnostics.covariates", key = stem)
}

.xp_plot_cov_splom <- function(handle, cov_cols, out_dir = NULL) {
  xpdb <- .xpose_get(handle)
  p <- nlme.cov.splom(xpdb, covColNames = cov_cols)
  path <- .xpose_plot_path(.xpose_session_dir(handle, out_dir),
                           "cov_splom", handle)
  .xpose_save_plot(p, path, height = 7)
  .xpose_record(.xpose_call(
    "nlme.cov.splom",
    list(.xpose_sym(handle), covColNames = cov_cols),
    var = "p"
  ))
  .xpose_record_ggsave(path, height = 7)
  .xpose_plot_payload(path, "Covariate scatterplot matrix",
                      section = "diagnostics.covariates", key = "cov_splom")
}

.xpose_gof_fns <- function() {
  c("dv_vs_pred", "dv_vs_ipred", "res_vs_pred", "res_vs_idv",
    "eta_distrib", "prm_distrib", "cov_distrib", "ind_plots")
}

# The classic population-level scatter GOFs: dv_vs_*/res_vs_* accept xpose's
# p/l/s/t type vocabulary. Distribution kinds (*_distrib) use an unrelated
# histogram/density/rug vocabulary, and ind_plots is a per-subject
# concentration-time profile where line joins are the point of the plot -
# neither should be defaulted to "ps".
.xpose_gof_scatter_fns <- function() {
  c("dv_vs_pred", "dv_vs_ipred", "res_vs_pred", "res_vs_idv")
}

# Resolve the `type` to actually pass through for a GOF kind: an explicit
# override always wins; xpose's own default for the scatter GOFs is "pls",
# which joins points into per-subject lines and produces unreadable
# spaghetti for a population-level scatter diagnostic, so those default to
# "ps" (points + loess smooth) instead. Distribution/ind_plots kinds keep
# xpose's own default (NULL = don't pass type at all) unless overridden.
.xpose_gof_effective_type <- function(kind, type = NULL) {
  type %||% if (kind %in% .xpose_gof_scatter_fns()) "ps" else NULL
}

.xp_plot_gof <- function(handle, kind, type = NULL, out_dir = NULL) {
  xpdb <- .xpose_get(handle)
  if (!kind %in% .xpose_gof_fns()) {
    stop(sprintf("Unknown GOF plot '%s'. Supported: %s", kind,
                 paste(.xpose_gof_fns(), collapse = ", ")), call. = FALSE)
  }
  effective_type <- .xpose_gof_effective_type(kind, type)
  fn <- getExportedValue("xpose", kind)
  p <- if (is.null(effective_type)) fn(xpdb) else fn(xpdb, type = effective_type)
  path <- .xpose_plot_path(.xpose_session_dir(handle, out_dir),
                           paste0("gof_", kind), handle)
  .xpose_save_plot(p, path)
  .xpose_record(.xpose_call(
    paste0("xpose::", kind),
    if (is.null(effective_type)) list(.xpose_sym(handle))
    else list(.xpose_sym(handle), type = effective_type),
    var = "p"
  ))
  .xpose_record_ggsave(path)
  stem <- paste0("gof_", kind)
  .xpose_plot_payload(path, sprintf("GOF: %s", kind),
                      section = "diagnostics.gof", key = stem)
}

.xp_update_eta_shrinkage <- function(handle, threshold = 1e-6,
                                     eta_threshold = NULL, eta_name = NULL) {
  xpdb <- .xpose_get(handle)
  updated <- update_etaShrinkageNlme(xpdb, threshold = threshold,
                                     eta_threshold = eta_threshold,
                                     eta_name = eta_name)
  meta <- .xpose_state$sessions[[handle]]$meta
  new_handle <- .xpose_store(updated, meta = meta)
  .xpose_record(.xpose_call(
    "update_etaShrinkageNlme",
    list(.xpose_sym(handle), threshold = threshold,
         eta_threshold = eta_threshold, eta_name = eta_name),
    var = new_handle
  ))
  list(handle = new_handle, source_handle = handle,
       repro_script = .xpose_repro_path())
}

# ---- comparison group -------------------------------------------------------

.xp_compare_eta_shrinkage <- function(handle, threshold = 1e-6,
                                      eta_threshold = NULL, eta_name = NULL) {
  xpdb <- .xpose_get(handle)
  df <- compare_etaShrinkageNlme(xpdb, threshold = threshold,
                                 eta_threshold = eta_threshold,
                                 eta_name = eta_name)
  .xpose_record(.xpose_call(
    "compare_etaShrinkageNlme",
    list(.xpose_sym(handle), threshold = threshold,
         eta_threshold = eta_threshold, eta_name = eta_name),
    var = "eta_shrinkage_cmp"
  ))
  .xpose_table_payload(df)
}

# Multi-model parameter comparison: resolve an ordered array of xpdb handles
# into a named list and hand it to compare_prmNlme(). Column headers come from
# `labels` (defaulting to the handles); the first model is the OFV-diff
# reference. Only the handle-list entry point is exposed here - the file-based
# `dir=` auto-detect path is a standalone-script convenience, not an MCP
# session operation.
.xp_compare_params <- function(handles, labels = NULL,
                               transform = "untransformed",
                               rse_separate = FALSE,
                               param_order = "original",
                               drop_dOFV = FALSE) {
  if (!is.character(handles) || length(handles) < 1L) {
    stop("`handles` must be a non-empty array of xpdb handles.", call. = FALSE)
  }
  labs <- if (is.null(labels) || !length(labels)) handles else as.character(labels)
  if (length(labs) != length(handles)) {
    stop("`labels` must have the same length as `handles`.", call. = FALSE)
  }
  if (anyDuplicated(labs)) {
    stop("Model labels must be unique (they become column headers).",
         call. = FALSE)
  }
  xpdb_list <- stats::setNames(lapply(handles, .xpose_get), labs)
  df <- compare_prmNlme(xpdb_list, transform = transform,
                        rse_separate = rse_separate, param_order = param_order,
                        drop_dOFV = drop_dOFV)
  # Repro: build the recorded models argument with structured quoting so a
  # label containing backticks/commas/newlines cannot break or inject into the
  # host repro script. Handles are internal symbols (xpdb1, ...); labels are
  # emitted as escaped string literals via deparse(). Yields, e.g.
  # compare_prmNlme(stats::setNames(list(xpdb1, xpdb2), c("OneCpt", "TwoCpt")), ...).
  handles_expr <- paste(handles, collapse = ", ")
  labels_expr  <- paste(vapply(labs, deparse, character(1)), collapse = ", ")
  models_expr <- sprintf("stats::setNames(list(%s), c(%s))",
                         handles_expr, labels_expr)
  .xpose_record(.xpose_call(
    "compare_prmNlme",
    list(.xpose_sym(models_expr), transform = transform,
         rse_separate = rse_separate, param_order = param_order,
         drop_dOFV = drop_dOFV),
    var = "prm_comparison"
  ))
  .xpose_table_payload(df)
}

# ---- builder ----------------------------------------------------------------

# Internal catalog: each tool tagged with the launch-profile group that gates it.
.xpose_tool_catalog <- function() {
  list(
    list(group = "data", tool = function() .xptool(
      .xp_create_from_dir, "xpose_create_from_dir",
      paste(
        "Create an xpose database (xpdb) from an NLME run directory and return",
        "a reusable handle (e.g. 'xpdb1'). Pass the handle to every other",
        "xpose tool. Works with Certara.RsNLME and Phoenix NLME output dirs.",
        "Refuses to build an xpdb when the directory's fit_manifest.json (if",
        "any, written by Certara.RsNLME at fit collection) shows the",
        "dmp.txt/residuals.csv/fit.rds were overwritten since the fit was",
        "selected - pass allow_integrity_violation=TRUE to proceed anyway."
      ),
      arguments = list(
        dir = .xts("Path to the NLME run output directory.", required = TRUE),
        model_name = .xts("Optional model label stored in the xpdb summary."),
        dmp_file = .xts("Engine dump file name (default 'dmp.txt')."),
        data_file = .xts("NLME input data file name (default 'data1.txt')."),
        log_file = .xts("Engine log file name (default 'nlme7engine.log')."),
        allow_integrity_violation = .xtb(paste(
          "Proceed even when fit_manifest.json shows the directory's",
          "artifacts changed since the fit was selected (default FALSE)."))
      )
    )),
    list(group = "data", tool = function() .xptool(
      .xp_create_from_fit, "xpose_create_from_fit",
      paste(
        "Advanced: create an xpdb from a Certara.RsNLME fit (and optional",
        "model) object already present in the R session, referenced by",
        "variable name. Prefer xpose_create_from_dir for robustness."
      ),
      arguments = list(
        fit_var = .xts("Name of the fitmodel() output object in the R session.",
                       required = TRUE),
        model_var = .xts("Optional name of the NlmePmlModel object.")
      )
    )),
    list(group = "data", tool = function() .xptool(
      .xp_list_sessions, "xpose_list_sessions",
      "List active xpdb handles and the reproducible-script path.",
      arguments = list()
    )),
    list(group = "data", tool = function() .xptool(
      .xp_list_vars, "xpose_list_vars",
      paste(
        "List the variables in an xpdb (covariates, parameters, residuals,",
        "etas). Use this to discover exact covariate names before plotting."
      ),
      arguments = list(
        handle = .xts("xpdb handle from a create tool.", required = TRUE)
      )
    )),
    list(group = "data", tool = function() .xptool(
      .xp_get_summary, "xpose_get_summary",
      paste(
        "Publication-ready parameter summary (fixed/random effects, residual",
        "error, secondary) with %RSE and shrinkage."
      ),
      arguments = list(
        handle = .xts("xpdb handle.", required = TRUE),
        shrinkage = .xts("Shrinkage basis: engine, sd, or var (default engine)."),
        digits = .xti("Significant digits (optional).")
      )
    )),
    list(group = "data", tool = function() .xptool(
      .xp_get_params, "xpose_get_params",
      "Raw NLME parameter estimate table (thetas, omegas, sigmas, secondary).",
      arguments = list(
        handle = .xts("xpdb handle.", required = TRUE),
        digits = .xti("Significant digits (default 6)."),
        show_all = .xtb("Keep zero off-diagonal omega elements (default FALSE).")
      )
    )),
    list(group = "data", tool = function() .xptool(
      .xp_get_overall, "xpose_get_overall",
      paste(
        "Overall fit statistics (OFV, AIC, BIC, condition number, nObs, ...).",
        "Condition is the engine's actual reported value when available;",
        "ConditionBasis labels which basis/scope it reflects (e.g.",
        "'Correlation (full)' vs 'Covariance (fixed effects)') - only compare",
        "Condition across rows with the same ConditionBasis. Pass",
        "conditionNumber to force a specific basis instead (recomputed from",
        "the original run directory; 'Full' scopes need Covariance.csv there)."
      ),
      arguments = list(
        handle = .xts("xpdb handle.", required = TRUE),
        conditionNumber = .xts(paste(
          "Optional override for Condition's basis/scope: one of",
          "CovarianceFixef, CorrelationFixef, CovarianceFull,",
          "CorrelationFull (or legacy aliases Covariance/Correlation).",
          "Default NULL keeps the value recorded at import time."
        ))
      )
    )),
    list(group = "data", tool = function() .xptool(
      .xp_get_eta_subject, "xpose_get_eta_subject",
      "Subject-level ETA table (ID, Eta, value, standard error).",
      arguments = list(
        handle = .xts("xpdb handle.", required = TRUE)
      )
    )),
    list(group = "data", tool = function() .xptool(
      .xp_get_boot_summary, "xpose_get_boot_summary",
      paste(
        "Fused original-fit + bootstrap parameter summary from a saved",
        "Certara.RsNLME::bootstrap() result (.rds path). Optionally provide an",
        "xpdb handle as the original-fit source."
      ),
      arguments = list(
        boot_rds = .xts("Path to an .rds file holding the bootstrap result.",
                        required = TRUE),
        handle = .xts("Optional xpdb handle for original-fit columns."),
        metric = .xts("Central metric: Median or Mean (default Median)."),
        digits = .xti("Significant digits (default 3).")
      )
    )),
    list(group = "interpretation", tool = function() .xptool(
      .xp_plot_res_vs_cov, "xpose_plot_res_vs_cov",
      paste(
        "Residuals vs covariate diagnostic plot; saves a PNG and returns its",
        "path. Use type 'b' for categorical covariates, combinations of",
        "p/l/s for continuous."
      ),
      arguments = list(
        handle = .xts("xpdb handle.", required = TRUE),
        covariate = .xts("Covariate column name (see xpose_list_vars).",
                         required = TRUE),
        res = .xts("Residual type (default CWRES)."),
        type = .xts("Plot type: 'b' (categorical) or p/l/s combos (default bpls)."),
        out_dir = .xts("Optional output directory for the PNG.")
      )
    )),
    list(group = "interpretation", tool = function() .xptool(
      .xp_plot_eta_vs_cov, "xpose_plot_eta_vs_cov",
      "ETAs vs covariate diagnostic plot; saves a PNG and returns its path.",
      arguments = list(
        handle = .xts("xpdb handle.", required = TRUE),
        covariate = .xts("Covariate column name.", required = TRUE),
        type = .xts("Plot type: 'b' or p/l/s combos (default bpls)."),
        out_dir = .xts("Optional output directory for the PNG.")
      )
    )),
    list(group = "interpretation", tool = function() .xptool(
      .xp_plot_prm_vs_cov, "xpose_plot_prm_vs_cov",
      "Structural parameters vs covariate plot; saves a PNG and returns its path.",
      arguments = list(
        handle = .xts("xpdb handle.", required = TRUE),
        covariate = .xts("Covariate column name.", required = TRUE),
        type = .xts("Plot type: 'b' or p/l/s combos (default bpls)."),
        out_dir = .xts("Optional output directory for the PNG.")
      )
    )),
    list(group = "interpretation", tool = function() .xptool(
      .xp_plot_cov_splom, "xpose_plot_cov_splom",
      "Covariate scatterplot matrix (SPLOM); saves a PNG and returns its path.",
      arguments = list(
        handle = .xts("xpdb handle.", required = TRUE),
        cov_cols = .xta_str("Covariate column names to include.",
                            required = TRUE),
        out_dir = .xts("Optional output directory for the PNG.")
      )
    )),
    list(group = "interpretation", tool = function() .xptool(
      .xp_plot_gof, "xpose_plot_gof",
      paste(
        "Standard xpose goodness-of-fit plot; saves a PNG and returns its",
        "path. 'kind' is one of:",
        paste(.xpose_gof_fns(), collapse = ", "), "."
      ),
      arguments = list(
        handle = .xts("xpdb handle.", required = TRUE),
        kind = .xts("GOF plot name (e.g. dv_vs_pred, res_vs_idv).",
                    required = TRUE),
        type = .xts(paste(
          "Plot type override: any combination of 'p'/'l'/'s'/'t'",
          "(points/lines/smooth/text). Scatter kinds",
          "(dv_vs_pred, dv_vs_ipred, res_vs_pred, res_vs_idv) default to",
          "'ps' (points + smooth, no per-subject line joins); distribution",
          "and ind_plots kinds keep xpose's own default unless set here."
        )),
        out_dir = .xts("Optional output directory for the PNG.")
      )
    )),
    list(group = "interpretation", tool = function() .xptool(
      .xp_update_eta_shrinkage, "xpose_update_eta_shrinkage",
      paste(
        "Recompute ETA shrinkage after dropping low-information subjects and",
        "return a NEW xpdb handle with the revised shrinkage."
      ),
      arguments = list(
        handle = .xts("xpdb handle.", required = TRUE),
        threshold = .xtn("Global per-subject shrinkage threshold (default 1e-6)."),
        eta_threshold = .xtn("Optional per-ETA override threshold."),
        eta_name = .xts("Optional ETA name the eta_threshold applies to.")
      )
    )),
    list(group = "comparison", tool = function() .xptool(
      .xp_compare_eta_shrinkage, "xpose_compare_eta_shrinkage",
      paste(
        "Compare original vs filtered ETA shrinkage without modifying the",
        "xpdb; returns a per-ETA comparison table."
      ),
      arguments = list(
        handle = .xts("xpdb handle.", required = TRUE),
        threshold = .xtn("Global per-subject shrinkage threshold (default 1e-6)."),
        eta_threshold = .xtn("Optional per-ETA override threshold."),
        eta_name = .xts("Optional ETA name the eta_threshold applies to.")
      )
    )),
    list(group = "comparison", tool = function() .xptool(
      .xp_compare_params, "xpose_compare_params",
      paste(
        "Compare parameter estimates across several models in one wide table,",
        "with a run-diagnostics header (-2LL, OFV diff, method, RetCode,",
        "condition, condition basis, nSub, nObs, runtime). The multi-model companion to",
        "xpose_get_params / xpose_get_summary. Pass an array of xpdb handles",
        "(from xpose_create_from_dir / xpose_create_from_fit) in the order to",
        "compare; the first is the reference for OFV diff. Parameters present",
        "in only some models appear as NA elsewhere. total runtime is engine",
        "CPU time (runtime + covtime), not print.rsnlme_fit wall-clock."
      ),
      arguments = list(
        handles = .xta_str(paste(
          "xpdb handles to compare, in order (first = OFV-diff reference)."),
          required = TRUE),
        labels = .xta_str(paste(
          "Optional column labels, one per handle in the same order",
          "(default: the handles). Must be unique.")),
        transform = .xts(paste(
          "Diagonal-OMEGA transform: untransformed (default), sqrt_om2, or",
          "sqrt_exp_om2_minus_1. SIGMA is always left on the reported scale.")),
        rse_separate = .xtb(
          "Show %RSE in its own rows instead of inline (default FALSE)."),
        param_order = .xts(
          "Parameter order within each section: original (default) or alphabetical."),
        drop_dOFV = .xtb("Omit the OFV diff row (default FALSE).")
      )
    ))
  )
}

# All groups this provider can contribute. Declared as the default so the host's
# unfiltered (full) profile receives every tool, and group-scoped profiles get
# the intersection (see .mcp_builder_call_groups in the host).
.xpose_mcp_groups <- function() c("data", "interpretation", "comparison")

#' Build the Certara.Xpose.NLME MCP tool set
#'
#' Returns a list of [ellmer::tool()] objects for the Certara.R MCP host. This
#' is the builder referenced by `inst/mcp/tools/manifest.json`. The host calls
#' it with the launch profile's provider groups; tools whose group is not
#' requested are omitted.
#'
#' @param groups Character vector of tool groups to include. One or more of
#'   `"data"`, `"interpretation"`, `"comparison"`. Defaults to all.
#' @return A list of `ellmer::tool()` objects (empty list when `ellmer` is not
#'   installed or no group matches).
#' @examples
#' \dontrun{
#' tools <- xpose_mcp_tools()
#' tools <- xpose_mcp_tools(groups = c("data", "interpretation"))
#' }
#' @export
xpose_mcp_tools <- function(groups = c("data", "interpretation", "comparison")) {
  if (!requireNamespace("ellmer", quietly = TRUE)) {
    return(list())
  }
  groups <- intersect(groups, .xpose_mcp_groups())
  catalog <- .xpose_tool_catalog()
  selected <- Filter(function(entry) entry$group %in% groups, catalog)
  lapply(selected, function(entry) entry$tool())
}