ADaMViz.SubmissionSync coverage - 89.76%

Files
Source

.evidence_migrations_path <- function() {
  path <- system.file(
    "sql", "migrations",
    package = "ADaMViz.SubmissionSync"
  )
  if (!nzchar(path)) path <- fs::path("inst", "sql", "migrations")
  path
}

.read_sql_statements <- function(path) {
  sql <- paste(readLines(path, warn = FALSE), collapse = "\n")
  trimws(strsplit(sql, ";", fixed = TRUE)[[1]])
}

.sqlite_connect <- function(path) {
  con <- DBI::dbConnect(RSQLite::SQLite(), path)
  DBI::dbExecute(con, "PRAGMA foreign_keys = ON")
  DBI::dbExecute(con, "PRAGMA busy_timeout = 5000")
  con
}

.initialize_evidence_database <- function(path) {
  fs::dir_create(fs::path_dir(path), recurse = TRUE)
  con <- .sqlite_connect(path)
  on.exit(DBI::dbDisconnect(con), add = TRUE)

  DBI::dbExecute(con, paste(
    "CREATE TABLE IF NOT EXISTS schema_migrations(",
    "version INTEGER PRIMARY KEY, applied_at TEXT NOT NULL)"
  ))
  migrations <- fs::dir_ls(
    .evidence_migrations_path(),
    regexp = "[0-9]+-.*[.]sql$",
    type = "file"
  )
  versions <- as.integer(sub("-.*$", "", fs::path_file(migrations)))
  if (!length(migrations) || anyNA(versions) || anyDuplicated(versions)) {
    cli::cli_abort("Evidence migrations must have unique numeric versions")
  }
  migrations <- migrations[order(versions)]
  versions <- sort(versions)
  applied <- DBI::dbGetQuery(
    con,
    "SELECT version FROM schema_migrations"
  )$version

  for (index in seq_along(migrations)) {
    if (versions[[index]] %in% applied) next
    DBI::dbWithTransaction(con, {
      statements <- .read_sql_statements(migrations[[index]])
      for (statement in statements[nzchar(statements)]) {
        DBI::dbExecute(con, statement)
      }
      DBI::dbExecute(
        con,
        paste(
          "INSERT INTO schema_migrations(version, applied_at)",
          "VALUES (?, ?)"
        ),
        params = list(versions[[index]], .utc_timestamp())
      )
    })
  }
}

.with_evidence_connection <- function(path, code) {
  con <- .sqlite_connect(path)
  on.exit(DBI::dbDisconnect(con), add = TRUE)
  code(con)
}

.with_repository_lock <- function(database_path, code) {
  lock_path <- paste0(database_path, ".lock")
  fs::dir_create(fs::path_dir(lock_path), recurse = TRUE)
  con <- .sqlite_connect(lock_path)
  on.exit(DBI::dbDisconnect(con), add = TRUE)
  DBI::dbExecute(
    con,
    paste0(
      "CREATE TABLE IF NOT EXISTS repository_lock(id INTEGER PRIMARY KEY ",
      "CHECK(id = 1))"
    )
  )
  DBI::dbExecute(con, "INSERT OR IGNORE INTO repository_lock(id) VALUES (1)")
  DBI::dbExecute(con, "BEGIN IMMEDIATE")
  completed <- FALSE
  on.exit(
    {
      if (!completed) try(DBI::dbExecute(con, "ROLLBACK"), silent = TRUE)
    },
    add = TRUE
  )
  result <- code()
  DBI::dbExecute(con, "COMMIT")
  completed <- TRUE
  result
}

.register_command <- function(con, key, command) {
  .validate_identifier(key, "idempotency_key")
  command_hash <- canonical_hash(command)
  prior <- DBI::dbGetQuery(
    con,
    "SELECT command_hash FROM command_keys WHERE idempotency_key = ?",
    params = list(key)
  )
  if (nrow(prior)) {
    if (!identical(prior$command_hash[[1]], command_hash)) {
      cli::cli_abort("Idempotency key was already used for a different command")
    }
    return(FALSE)
  }
  DBI::dbExecute(
    con,
    paste(
      "INSERT INTO command_keys(idempotency_key, command_hash, created_at)",
      "VALUES (?, ?, ?)"
    ),
    params = list(key, command_hash, .utc_timestamp())
  )
  TRUE
}

.current_revision <- function(con, revision_id) {
  result <- DBI::dbGetQuery(con, paste(
    "SELECT r.*, p.status, p.version FROM revisions r",
    "JOIN revision_projection p USING(revision_id) WHERE r.revision_id = ?"
  ), params = list(revision_id))
  if (!nrow(result)) {
    cli::cli_abort("Plot revision {.val {revision_id}} was not found")
  }
  as.list(result[1, , drop = FALSE]) |>
    lapply(\(x) x[[1]])
}

.append_lifecycle_event <- function(
  con,
  revision,
  event_type,
  payload,
  idempotency_key
) {
  last <- DBI::dbGetQuery(
    con,
    paste(
      "SELECT event_sequence, chain_hash FROM lifecycle_events",
      "WHERE plot_id = ? ORDER BY event_sequence DESC LIMIT 1"
    ),
    params = list(revision$plot_id)
  )
  sequence <- if (nrow(last)) last$event_sequence[[1]] + 1L else 1L
  previous <- if (nrow(last)) {
    last$chain_hash[[1]]
  } else {
    paste(rep("0", 64L), collapse = "")
  }
  created_at <- .utc_timestamp()
  payload_json <- canonical_serialize(payload)
  chain_hash <- canonical_hash(list(
    plot_id = revision$plot_id,
    revision_id = revision$revision_id,
    event_sequence = sequence,
    event_type = event_type,
    payload_json = payload_json,
    previous_hash = previous,
    created_at = created_at
  ))
  event_id <- paste0("evt-", substr(canonical_hash(idempotency_key), 1L, 24L))
  DBI::dbExecute(con, paste(
    "INSERT INTO lifecycle_events(event_id, plot_id, revision_id,",
    "event_sequence, event_type,",
    "payload_json, previous_hash, chain_hash, created_at, idempotency_key)",
    "VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?)"
  ), params = list(
    event_id, revision$plot_id, revision$revision_id, sequence, event_type,
    payload_json, previous, chain_hash, created_at, idempotency_key
  ))
  list(
    plot_id = revision$plot_id,
    sequence = sequence,
    chain_hash = chain_hash
  )
}

.read_chain_roots <- function(path) {
  if (!fs::file_exists(path)) {
    return(list())
  }
  jsonlite::fromJSON(path, simplifyVector = TRUE)
}

.write_chain_root <- function(path, root) {
  roots <- .read_chain_roots(path)
  prior <- roots[[root$plot_id]]
  if (!is.null(prior) && prior$sequence > root$sequence) {
    cli::cli_abort("External chain root is newer than the database history")
  }
  if (!is.null(prior) && prior$sequence == root$sequence &&
    !identical(prior$chain_hash, root$chain_hash)) {
    cli::cli_abort("External chain root conflicts with the database history")
  }
  if (!is.null(prior) && prior$sequence == root$sequence) {
    return(invisible(path))
  }
  roots[[root$plot_id]] <- list(
    sequence = root$sequence,
    chain_hash = root$chain_hash
  )
  fs::dir_create(fs::path_dir(path), recurse = TRUE)
  temporary <- fs::file_temp(
    tmp_dir = fs::path_dir(path),
    pattern = "chain-root-"
  )
  writeLines(canonical_serialize(roots), temporary, useBytes = TRUE)
  fs::file_move(temporary, path)
}

.chain_tip <- function(con, plot_id) {
  tip <- DBI::dbGetQuery(
    con,
    paste(
      "SELECT event_sequence, chain_hash FROM lifecycle_events",
      "WHERE plot_id = ? ORDER BY event_sequence DESC LIMIT 1"
    ),
    params = list(plot_id)
  )
  if (!nrow(tip)) {
    return(NULL)
  }
  list(
    plot_id = plot_id,
    sequence = tip$event_sequence[[1]],
    chain_hash = tip$chain_hash[[1]]
  )
}

.reconcile_chain_roots <- function(database_path, chain_root_path) {
  tips <- .with_evidence_connection(database_path, function(con) {
    DBI::dbGetQuery(con, paste(
      "SELECT e.plot_id, e.event_sequence AS sequence, e.chain_hash",
      "FROM lifecycle_events e",
      "JOIN (SELECT plot_id, MAX(event_sequence) AS sequence",
      "FROM lifecycle_events GROUP BY plot_id) latest",
      "ON e.plot_id = latest.plot_id AND e.event_sequence = latest.sequence"
    ))
  })
  if (nrow(tips)) {
    for (index in seq_len(nrow(tips))) {
      .write_chain_root(chain_root_path, as.list(tips[index, ]))
    }
  }
  invisible(chain_root_path)
}

.chain_roots_match <- function(database_path, chain_root_path) {
  tips <- .with_evidence_connection(database_path, function(con) {
    DBI::dbGetQuery(con, paste(
      "SELECT e.plot_id, e.event_sequence AS sequence, e.chain_hash",
      "FROM lifecycle_events e",
      "JOIN (SELECT plot_id, MAX(event_sequence) AS sequence",
      "FROM lifecycle_events GROUP BY plot_id) latest",
      "ON e.plot_id = latest.plot_id AND e.event_sequence = latest.sequence"
    ))
  })
  roots <- .read_chain_roots(chain_root_path)
  root_plot_ids <- names(roots) %||% character()
  if (!identical(sort(root_plot_ids), sort(tips$plot_id))) {
    return(FALSE)
  }
  for (index in seq_len(nrow(tips))) {
    root <- roots[[tips$plot_id[[index]]]]
    if (!identical(
      as.integer(root$sequence), as.integer(tips$sequence[[index]])
    ) ||
      !identical(root$chain_hash, tips$chain_hash[[index]])) {
      return(FALSE)
    }
  }
  TRUE
}

.review_decision_hash <- function(record) {
  canonical_hash(record[c(
    "decision_id", "revision_id", "actor_id", "role", "decision",
    "authorization_json", "comment", "code_hash", "image_hash",
    "analytical_hash", "created_at", "idempotency_key"
  )])
}

.database_table_counts <- function(path) {
  .with_evidence_connection(path, function(con) {
    tables <- DBI::dbListTables(con)
    stats::setNames(
      lapply(tables, function(table) {
        DBI::dbGetQuery(
          con,
          paste0(
            "SELECT COUNT(*) AS n FROM ",
            DBI::dbQuoteIdentifier(con, table)
          )
        )$n[[1]]
      }),
      tables
    )
  })
}

.verify_backup_manifest <- function(backup_path) {
  manifest_path <- fs::path(backup_path, "backup-manifest.json")
  if (!fs::file_exists(manifest_path)) {
    cli::cli_abort("Backup completion manifest is missing")
  }
  manifest <- jsonlite::fromJSON(manifest_path, simplifyVector = FALSE)
  database_path <- fs::path(backup_path, "evidence.sqlite")
  chain_root_path <- fs::path(backup_path, "chain-root.json")
  if (!fs::file_exists(database_path) || !fs::file_exists(chain_root_path)) {
    cli::cli_abort("Backup is incomplete")
  }
  database_hash <- digest::digest(file = database_path, algo = "sha256")
  chain_root_hash <- digest::digest(file = chain_root_path, algo = "sha256")
  if (!identical(database_hash, manifest$database_hash) ||
    !identical(chain_root_hash, manifest$chain_root_hash)) {
    cli::cli_abort("Backup file hashes do not match the completion manifest")
  }
  counts <- .database_table_counts(database_path)
  expected_counts <- unlist(manifest$table_counts, use.names = TRUE)
  actual_counts <- unlist(counts[names(expected_counts)], use.names = TRUE)
  if (!identical(as.numeric(actual_counts), as.numeric(expected_counts)) ||
    !identical(names(actual_counts), names(expected_counts))) {
    cli::cli_abort("Backup row counts do not match the completion manifest")
  }
  invisible(manifest)
}

.project_revision_history <- function(revisions, events) {
  if (!nrow(revisions)) {
    return(data.frame(
      revision_id = character(),
      status = character(),
      version = integer(),
      updated_at = character()
    ))
  }
  events_by_revision <- split(events, events$revision_id)
  projections <- lapply(seq_len(nrow(revisions)), \(index) {
    revision_id <- revisions$revision_id[[index]]
    revision_events <- events_by_revision[[revision_id]]
    if (is.null(revision_events) || !nrow(revision_events)) {
      cli::cli_abort(
        "Revision {.val {revision_id}} has no lifecycle history"
      )
    }
    status <- revisions$initial_status[[index]]
    for (payload_json in revision_events$payload_json) {
      payload <- jsonlite::fromJSON(payload_json, simplifyVector = TRUE)
      if (!is.null(payload$status)) status <- payload$status
      if (!is.null(payload$to)) status <- payload$to
    }
    data.frame(
      revision_id = revision_id,
      status = status,
      version = as.integer(nrow(revision_events)),
      updated_at = utils::tail(revision_events$created_at, 1L)
    )
  })
  result <- do.call(rbind, projections)
  rownames(result) <- NULL
  result
}

sqlite_evidence_repository <- function(
  database_path,
  chain_root_path,
  artifact_store = NULL
) {
  checkmate::assert_string(database_path, min.chars = 1)
  checkmate::assert_string(chain_root_path, min.chars = 1)
  .initialize_evidence_database(database_path)

  transact <- function(idempotency_key, command, code) {
    .with_repository_lock(database_path, function() {
      if (!.chain_roots_match(database_path, chain_root_path)) {
        prior <- .with_evidence_connection(database_path, function(con) {
          DBI::dbGetQuery(
            con,
            "SELECT command_hash FROM command_keys WHERE idempotency_key = ?",
            params = list(idempotency_key)
          )
        })
        is_exact_replay <- nrow(prior) == 1L && identical(
          prior$command_hash[[1]],
          canonical_hash(command)
        )
        if (!is_exact_replay) {
          cli::cli_abort(
            "External chain root must be reconciled before a new command"
          )
        }
        .reconcile_chain_roots(database_path, chain_root_path)
        if (!.chain_roots_match(database_path, chain_root_path)) {
          cli::cli_abort("External chain root cannot be reconciled safely")
        }
      }
      root <- .with_evidence_connection(database_path, function(con) {
        DBI::dbWithTransaction(con, code(con))
      })
      if (is.list(root) &&
        all(c("plot_id", "sequence", "chain_hash") %in% names(root))) {
        .write_chain_root(chain_root_path, root)
      }
      invisible(root)
    })
  }

  write_transaction <- function(code) {
    .with_repository_lock(database_path, function() {
      .with_evidence_connection(database_path, function(con) {
        DBI::dbWithTransaction(con, code(con))
      })
    })
  }

  create_revision <- function(
    plot_id,
    revision_id,
    revision_number,
    creator_id,
    spec_hash,
    code_hash,
    image_hash,
    analytical_hash,
    idempotency_key,
    initial_status = "Draft",
    parent_revision_id = NULL,
    correction_rationale = NULL,
    correction_provenance = NULL
  ) {
    lapply(
      list(
        plot_id = plot_id,
        revision_id = revision_id,
        creator_id = creator_id
      ),
      \(x) .validate_identifier(x, "identifier")
    )
    checkmate::assert_int(revision_number, lower = 1L)
    if (!initial_status %in% c("Draft", "Experimental/Draft")) {
      cli::cli_abort("Invalid initial revision status")
    }
    if (!is.null(artifact_store) && !is.null(code_hash)) {
      artifact_store$verify(code_hash)
    }
    if (!is.null(artifact_store) && !is.null(image_hash)) {
      artifact_store$verify(image_hash)
    }
    command <- list(
      plot_id = plot_id,
      revision_id = revision_id,
      revision_number = revision_number,
      creator_id = creator_id,
      spec_hash = spec_hash,
      code_hash = code_hash,
      image_hash = image_hash,
      analytical_hash = analytical_hash,
      initial_status = initial_status,
      parent_revision_id = parent_revision_id,
      correction_rationale = correction_rationale,
      correction_provenance = correction_provenance
    )
    transact(idempotency_key, command, function(con) {
      if (!.register_command(con, idempotency_key, command)) {
        existing <- .current_revision(con, revision_id)
        return(.chain_tip(con, existing$plot_id))
      }
      if (!is.null(parent_revision_id)) {
        parent <- .current_revision(con, parent_revision_id)
        if (!identical(parent$plot_id, plot_id)) {
          cli::cli_abort(
            "A correction successor must belong to its parent plot"
          )
        }
        if (!parent$status %in% c("Rejected", "Reviewed")) {
          cli::cli_abort(
            "Only a closed revision can have a correction successor"
          )
        }
        if (!checkmate::test_string(correction_rationale, min.chars = 1) ||
          !checkmate::test_string(correction_provenance, min.chars = 1)) {
          cli::cli_abort(
            "A correction successor requires rationale and provenance"
          )
        }
      } else if (!is.null(correction_rationale) ||
        !is.null(correction_provenance)) {
        cli::cli_abort(
          "Correction rationale and provenance require a parent revision"
        )
      }
      DBI::dbExecute(
        con,
        "INSERT OR IGNORE INTO plots(plot_id, created_at) VALUES (?, ?)",
        params = list(plot_id, .utc_timestamp())
      )
      created_at <- .utc_timestamp()
      nullable <- \(x) if (is.null(x)) NA_character_ else x
      DBI::dbExecute(con, paste(
        "INSERT INTO revisions(revision_id, plot_id, revision_number,",
        "creator_id, parent_revision_id,",
        paste(
          "correction_rationale, correction_provenance, spec_hash,",
          "code_hash, image_hash, analytical_hash, initial_status, created_at)"
        ),
        "VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)"
      ), params = list(
        revision_id, plot_id, revision_number, creator_id,
        nullable(parent_revision_id), nullable(correction_rationale),
        nullable(correction_provenance), spec_hash, code_hash,
        nullable(image_hash), nullable(analytical_hash),
        initial_status, created_at
      ))
      DBI::dbExecute(
        con,
        paste(
          "INSERT INTO revision_projection(revision_id, status, version,",
          "updated_at) VALUES (?, ?, 1, ?)"
        ),
        params = list(revision_id, initial_status, created_at)
      )
      revision <- list(plot_id = plot_id, revision_id = revision_id)
      .append_lifecycle_event(
        con,
        revision,
        "revision_created",
        list(status = initial_status),
        idempotency_key
      )
    })
  }

  list_revisions <- function(plot_id) {
    .with_evidence_connection(database_path, \(con) {
      DBI::dbGetQuery(
        con,
        paste(
          "SELECT * FROM revisions WHERE plot_id = ?",
          "ORDER BY revision_number"
        ),
        params = list(plot_id)
      )
    })
  }
  list_events <- function(plot_id) {
    .with_evidence_connection(database_path, \(con) {
      DBI::dbGetQuery(
        con,
        paste(
          "SELECT * FROM lifecycle_events WHERE plot_id = ?",
          "ORDER BY event_sequence"
        ),
        params = list(plot_id)
      )
    })
  }
  get_revision <- function(revision_id) {
    .with_evidence_connection(
      database_path,
      \(con) .current_revision(con, revision_id)
    )
  }

  record_attempt <- function(attempt_id, revision_id, run_id) {
    write_transaction(function(con) {
      .current_revision(con, revision_id)
      prior <- DBI::dbGetQuery(
        con,
        "SELECT revision_id, run_id FROM attempts WHERE attempt_id = ?",
        params = list(attempt_id)
      )
      if (nrow(prior)) {
        if (!identical(prior$revision_id[[1]], revision_id) ||
          !identical(prior$run_id[[1]], run_id)) {
          cli::cli_abort(
            "Attempt identifier was already used for a different command"
          )
        }
        return(invisible(NULL))
      }
      DBI::dbExecute(
        con,
        paste(
          "INSERT INTO attempts(attempt_id, revision_id, run_id, created_at)",
          "VALUES (?, ?, ?, ?)"
        ),
        params = list(attempt_id, revision_id, run_id, .utc_timestamp())
      )
    })
    invisible(attempt_id)
  }
  list_attempts <- function(revision_id) {
    .with_evidence_connection(database_path, \(con) {
      DBI::dbGetQuery(
        con, paste(
          "SELECT a.*, o.outcome, o.created_at AS completed_at FROM attempts a",
          paste(
            "LEFT JOIN attempt_outcomes o USING(attempt_id)",
            "WHERE a.revision_id = ? ORDER BY a.created_at, a.attempt_id"
          )
        ),
        params = list(revision_id)
      )
    })
  }
  complete_attempt <- function(attempt_id, outcome, idempotency_key) {
    if (!outcome %in% c("succeeded", "failed", "cancelled", "timed_out")) {
      cli::cli_abort("Invalid terminal attempt outcome")
    }
    write_transaction(function(con) {
      command <- list(attempt_id = attempt_id, outcome = outcome)
      if (!.register_command(con, idempotency_key, command)) {
        return(invisible(NULL))
      }
      prior <- DBI::dbGetQuery(
        con,
        "SELECT 1 FROM attempt_outcomes WHERE attempt_id = ?",
        params = list(attempt_id)
      )
      if (nrow(prior)) {
        cli::cli_abort("An attempt can have only one terminal outcome")
      }
      attempt_exists <- DBI::dbGetQuery(
        con,
        "SELECT 1 FROM attempts WHERE attempt_id = ?",
        params = list(attempt_id)
      )
      if (!nrow(attempt_exists)) {
        cli::cli_abort("Execution attempt was not found")
      }
      DBI::dbExecute(
        con,
        "INSERT INTO attempt_outcomes VALUES (?, ?, ?, ?)",
        params = list(
          attempt_id, outcome, .utc_timestamp(), idempotency_key
        )
      )
    })
    invisible(attempt_id)
  }
  record_evidence <- function(
    evidence_id,
    revision_id,
    evidence_type,
    outcome,
    idempotency_key,
    details = list()
  ) {
    if (!checkmate::test_list(details, names = "unique")) {
      cli::cli_abort("Evidence details must be a named list")
    }
    write_transaction(function(con) {
      command <- list(
        evidence_id = evidence_id,
        revision_id = revision_id,
        evidence_type = evidence_type,
        outcome = outcome,
        details = details
      )
      if (!.register_command(con, idempotency_key, command)) {
        return(invisible(NULL))
      }
      .current_revision(con, revision_id)
      details_json <- canonical_serialize(details)
      DBI::dbExecute(
        con,
        "INSERT INTO evidence_entries VALUES (?, ?, ?, ?, ?, ?, ?, ?)",
        params = list(
          evidence_id, revision_id, evidence_type, outcome, details_json,
          canonical_hash(details), .utc_timestamp(), idempotency_key
        )
      )
    })
    invisible(evidence_id)
  }
  list_evidence <- function(revision_id) {
    .with_evidence_connection(database_path, \(con) {
      DBI::dbGetQuery(
        con,
        paste(
          "SELECT * FROM evidence_entries WHERE revision_id = ?",
          "ORDER BY created_at, evidence_id"
        ),
        params = list(revision_id)
      )
    })
  }
  accept_artifact_bundle <- function(
    bundle_id,
    revision_id,
    code_hash,
    image_hash,
    analytical_hash,
    idempotency_key
  ) {
    write_transaction(function(con) {
      command <- list(
        bundle_id = bundle_id,
        revision_id = revision_id,
        code_hash = code_hash,
        image_hash = image_hash,
        analytical_hash = analytical_hash
      )
      if (!.register_command(con, idempotency_key, command)) {
        return(invisible(NULL))
      }
      revision <- .current_revision(con, revision_id)
      if (is.na(revision$image_hash) && is.na(revision$analytical_hash)) {
        if (!is.null(artifact_store)) {
          artifact_store$verify(code_hash)
          artifact_store$verify(image_hash)
        }
        DBI::dbExecute(
          con,
          paste(
            "UPDATE revisions SET image_hash = ?, analytical_hash = ?",
            paste(
              "WHERE revision_id = ? AND image_hash IS NULL",
              "AND analytical_hash IS NULL"
            )
          ),
          params = list(image_hash, analytical_hash, revision_id)
        )
        revision$image_hash <- image_hash
        revision$analytical_hash <- analytical_hash
      }
      expected_hashes <- unlist(
        revision[c("code_hash", "image_hash", "analytical_hash")]
      )
      supplied_hashes <- c(
        code_hash = code_hash,
        image_hash = image_hash,
        analytical_hash = analytical_hash
      )
      if (!identical(supplied_hashes, expected_hashes)) {
        cli::cli_abort(
          "Artifact bundle hashes do not match the immutable revision"
        )
      }
      if (!is.null(artifact_store)) {
        artifact_store$verify(code_hash)
        artifact_store$verify(image_hash)
      }
      prior <- DBI::dbGetQuery(
        con,
        "SELECT 1 FROM artifact_bundles WHERE revision_id = ?",
        params = list(revision_id)
      )
      if (nrow(prior)) {
        cli::cli_abort("A revision can have only one accepted artifact bundle")
      }
      DBI::dbExecute(
        con,
        "INSERT INTO artifact_bundles VALUES (?, ?, ?, ?, ?, ?, ?)",
        params = list(
          bundle_id, revision_id, code_hash, image_hash, analytical_hash,
          .utc_timestamp(), idempotency_key
        )
      )
    })
    invisible(bundle_id)
  }

  get_artifact_bundle <- function(revision_id) {
    .with_evidence_connection(database_path, function(con) {
      .current_revision(con, revision_id)
      result <- DBI::dbGetQuery(
        con,
        paste(
          "SELECT * FROM artifact_bundles WHERE revision_id = ?",
          "ORDER BY accepted_at DESC LIMIT 1"
        ),
        params = list(revision_id)
      )
      if (!nrow(result)) {
        cli::cli_abort(
          "Revision {.val {revision_id}} has no accepted artifact bundle"
        )
      }
      as.list(result[1, , drop = FALSE]) |>
        lapply(\(value) value[[1]])
    })
  }

  mark_verified <- function(revision_id, expected_version, idempotency_key) {
    command <- list(
      revision_id = revision_id,
      expected_version = expected_version,
      action = "mark_verified"
    )
    transact(idempotency_key, command, function(con) {
      if (!.register_command(con, idempotency_key, command)) {
        existing <- .current_revision(con, revision_id)
        return(.chain_tip(con, existing$plot_id))
      }
      revision <- .current_revision(con, revision_id)
      if (!identical(
        as.integer(revision$version), as.integer(expected_version)
      )) {
        cli::cli_abort("The revision token is stale")
      }
      if (!identical(revision$status, "Draft")) {
        cli::cli_abort(
          "Only a Draft revision can become Verified"
        )
      }
      passing_execution <- DBI::dbGetQuery(
        con,
        paste(
          "SELECT 1 FROM attempts a",
          "JOIN attempt_outcomes o USING(attempt_id)",
          "JOIN evidence_entries e ON e.revision_id = a.revision_id",
          "JOIN artifact_bundles b ON b.revision_id = a.revision_id",
          "WHERE a.revision_id = ? AND o.outcome = 'succeeded'",
          "AND e.evidence_type = 'execution_verification'",
          "AND e.outcome = 'passed'",
          paste0(
            "AND json_extract(e.details_json, '$.attempt_id') = ",
            "a.attempt_id LIMIT 1"
          )
        ),
        params = list(revision_id)
      )
      if (!nrow(passing_execution)) {
        cli::cli_abort(
          "A revision requires passing execution evidence before verification"
        )
      }
      DBI::dbExecute(
        con,
        paste(
          "UPDATE revision_projection SET status = ?, version = version + 1,",
          "updated_at = ? WHERE revision_id = ?"
        ),
        params = list("Verified", .utc_timestamp(), revision_id)
      )
      .append_lifecycle_event(
        con,
        revision,
        "revision_verified",
        list(from = "Draft", to = "Verified"),
        idempotency_key
      )
    })
  }

  record_review_decision <- function(
    revision_id,
    actor,
    decision,
    expected_version,
    idempotency_key,
    hashes,
    comment = NULL,
    role = NULL
  ) {
    command <- list(
      revision_id = revision_id,
      actor = actor,
      decision = decision,
      expected_version = expected_version,
      hashes = hashes,
      comment = comment,
      role = role
    )
    transact(idempotency_key, command, function(con) {
      if (!.register_command(con, idempotency_key, command)) {
        existing <- .current_revision(con, revision_id)
        return(.chain_tip(con, existing$plot_id))
      }
      revision <- .current_revision(con, revision_id)
      if (revision$status == "Reviewed") {
        cli::cli_abort("Reviewed revisions are immutable")
      }
      if (!identical(
        as.integer(revision$version), as.integer(expected_version)
      )) {
        cli::cli_abort("The revision token is stale")
      }
      if (!revision$status %in% c("Verified")) {
        cli::cli_abort("Only a Verified revision can be reviewed")
      }
      expected_hashes <- unlist(
        revision[c("code_hash", "image_hash", "analytical_hash")]
      )
      if (!identical(unlist(hashes[names(expected_hashes)]), expected_hashes)) {
        cli::cli_abort(
          "Review hashes do not match the immutable revision hashes"
        )
      }
      if (identical(actor$id, revision$creator_id)) {
        cli::cli_abort("A revision creator cannot review their own revision")
      }
      if (!isTRUE(actor$active)) {
        cli::cli_abort("The authenticated reviewer must be active")
      }
      eligible <- intersect(
        actor$roles,
        c("statistical_programmer", "biostatistician")
      )
      if (!length(eligible)) {
        cli::cli_abort("The authenticated actor is not an eligible reviewer")
      }
      if (is.null(role) && length(eligible) > 1L) {
        cli::cli_abort(paste0(
          "A reviewer with multiple eligible roles must select ",
          "one role"
        ))
      }
      role <- role %||% eligible[[1]]
      if (!checkmate::test_choice(role, eligible)) {
        cli::cli_abort(paste0(
          "The claimed reviewer role is not authorized for this actor"
        ))
      }
      if (decision == "rejected" &&
        !checkmate::test_string(comment, min.chars = 1)) {
        cli::cli_abort("A rejection rationale is required")
      }
      prior <- DBI::dbGetQuery(
        con,
        "SELECT actor_id FROM review_decisions WHERE revision_id = ?",
        params = list(revision_id)
      )
      if (actor$id %in% prior$actor_id) {
        cli::cli_abort(
          "Review decisions require distinct authenticated identities"
        )
      }
      decision_id <- paste0(
        "decision-",
        substr(canonical_hash(idempotency_key), 1L, 24L)
      )
      created_at <- .utc_timestamp()
      authorization_json <- canonical_serialize(list(
        actor_id = actor$id,
        roles = actor$roles,
        active = actor$active
      ))
      stored_comment <- if (is.null(comment)) NA_character_ else comment
      decision_record <- list(
        decision_id = decision_id,
        revision_id = revision_id,
        actor_id = actor$id,
        role = role,
        decision = decision,
        authorization_json = authorization_json,
        comment = stored_comment,
        code_hash = revision$code_hash,
        image_hash = revision$image_hash,
        analytical_hash = revision$analytical_hash,
        created_at = created_at,
        idempotency_key = idempotency_key
      )
      decision_hash <- .review_decision_hash(decision_record)
      DBI::dbExecute(con, paste(
        "INSERT INTO review_decisions(",
        "decision_id, revision_id, actor_id, role, decision,",
        "authorization_json, comment,",
        paste(
          "code_hash, image_hash, analytical_hash, created_at,",
          "idempotency_key, record_hash)"
        ),
        "VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)"
      ), params = list(
        decision_id, revision_id, actor$id, role, decision,
        authorization_json, stored_comment, revision$code_hash,
        revision$image_hash, revision$analytical_hash, created_at,
        idempotency_key, decision_hash
      ))
      next_status <- revision$status
      if (decision == "rejected") next_status <- "Rejected"
      if (decision == "approved") {
        approvals <- DBI::dbGetQuery(
          con,
          paste(
            "SELECT actor_id, role FROM review_decisions",
            "WHERE revision_id = ? AND decision = 'approved'"
          ),
          params = list(revision_id)
        )
        if (nrow(approvals) >= 2L &&
          length(unique(approvals$actor_id)) >= 2L &&
          all(c(
            "statistical_programmer", "biostatistician"
          ) %in% approvals$role)) {
          next_status <- "Reviewed"
        }
      }
      DBI::dbExecute(
        con,
        paste(
          "UPDATE revision_projection SET status = ?, version = version + 1,",
          "updated_at = ? WHERE revision_id = ?"
        ),
        params = list(next_status, .utc_timestamp(), revision_id)
      )
      .append_lifecycle_event(
        con,
        revision,
        paste0("review_", decision),
        list(
          status = next_status,
          actor_id = actor$id,
          role = role,
          decision_id = decision_id,
          decision_hash = decision_hash
        ),
        idempotency_key
      )
    })
  }

  list_review_decisions <- function(revision_id) {
    .with_evidence_connection(database_path, \(con) {
      DBI::dbGetQuery(
        con,
        paste(
          "SELECT * FROM review_decisions WHERE revision_id = ?",
          "ORDER BY created_at, decision_id"
        ),
        params = list(revision_id)
      )
    })
  }

  record_export_receipt <- function(
    receipt_id,
    revision_id,
    destination_id,
    code_hash,
    image_hash,
    idempotency_key
  ) {
    write_transaction(function(con) {
      command <- list(
        receipt_id = receipt_id,
        revision_id = revision_id,
        destination_id = destination_id,
        code_hash = code_hash,
        image_hash = image_hash
      )
      if (!.register_command(con, idempotency_key, command)) {
        return(invisible(NULL))
      }
      revision <- .current_revision(con, revision_id)
      if (!identical(code_hash, revision$code_hash) ||
        !identical(image_hash, revision$image_hash)) {
        cli::cli_abort(
          "Export receipt hashes do not match the immutable revision"
        )
      }
      DBI::dbExecute(
        con,
        "INSERT INTO export_receipts VALUES (?, ?, ?, ?, ?, ?, ?)",
        params = list(
          receipt_id, revision_id, destination_id, code_hash, image_hash,
          .utc_timestamp(), idempotency_key
        )
      )
    })
    invisible(receipt_id)
  }
  list_export_receipts <- function(revision_id) {
    .with_evidence_connection(database_path, \(con) {
      DBI::dbGetQuery(
        con,
        paste(
          "SELECT * FROM export_receipts WHERE revision_id = ?",
          "ORDER BY created_at, receipt_id"
        ),
        params = list(revision_id)
      )
    })
  }

  rebuild_projections <- function() {
    .with_repository_lock(database_path, function() {
      .with_evidence_connection(database_path, function(con) {
        DBI::dbWithTransaction(con, {
          revisions <- DBI::dbGetQuery(
            con,
            "SELECT revision_id, initial_status, created_at FROM revisions"
          )
          events <- DBI::dbGetQuery(
            con,
            paste(
              "SELECT revision_id, payload_json, created_at",
              "FROM lifecycle_events ORDER BY plot_id, event_sequence"
            )
          )
          projections <- .project_revision_history(revisions, events)
          DBI::dbExecute(con, "DELETE FROM revision_projection")
          if (nrow(projections)) {
            DBI::dbAppendTable(con, "revision_projection", projections)
          }
        })
      })
    })
  }

  verify_integrity_unlocked <- function(require_artifacts = FALSE) {
    .with_evidence_connection(database_path, function(con) {
      foreign_key_violations <- DBI::dbGetQuery(
        con,
        "PRAGMA foreign_key_check"
      )
      if (nrow(foreign_key_violations) > 0L) {
        cli::cli_abort("Foreign-key integrity check failed")
      }
      plots <- DBI::dbGetQuery(con, "SELECT plot_id FROM plots")$plot_id
      events <- DBI::dbGetQuery(
        con,
        "SELECT * FROM lifecycle_events ORDER BY plot_id, event_sequence"
      )
      roots <- .read_chain_roots(chain_root_path)
      root_plot_ids <- names(roots) %||% character()
      if (!identical(sort(root_plot_ids), sort(plots))) {
        cli::cli_abort("External chain roots do not match persisted plots")
      }
      for (plot_id in plots) {
        plot_events <- events[events$plot_id == plot_id, , drop = FALSE]
        previous <- paste(rep("0", 64L), collapse = "")
        for (i in seq_len(nrow(plot_events))) {
          if (plot_events$event_sequence[[i]] != i ||
            !identical(plot_events$previous_hash[[i]], previous)) {
            cli::cli_abort("Lifecycle event chain order is invalid")
          }
          calculated <- canonical_hash(list(
            plot_id = plot_id,
            revision_id = plot_events$revision_id[[i]],
            event_sequence = i,
            event_type = plot_events$event_type[[i]],
            payload_json = plot_events$payload_json[[i]],
            previous_hash = previous,
            created_at = plot_events$created_at[[i]]
          ))
          if (!identical(calculated, plot_events$chain_hash[[i]])) {
            cli::cli_abort("Lifecycle event chain hash is invalid")
          }
          previous <- calculated
        }
        root <- roots[[plot_id]]
        if (is.null(root) || root$sequence != nrow(plot_events) ||
          !identical(root$chain_hash, previous)) {
          cli::cli_abort(
            "External chain root does not match persisted history"
          )
        }
      }
      projections <- DBI::dbGetQuery(
        con,
        "SELECT * FROM revision_projection ORDER BY revision_id"
      )
      revisions <- DBI::dbGetQuery(
        con,
        paste(
          "SELECT revision_id, initial_status, created_at",
          "FROM revisions ORDER BY revision_id"
        )
      )
      expected <- .project_revision_history(revisions, events)
      if (require_artifacts && nrow(revisions) && is.null(artifact_store)) {
        cli::cli_abort(
          "Complete integrity verification requires an artifact store"
        )
      }
      actual <- projections[
        , c("revision_id", "status", "version"),
        drop = FALSE
      ]
      expected <- expected[
        , c("revision_id", "status", "version"),
        drop = FALSE
      ]
      if (!identical(actual, expected)) {
        cli::cli_abort(
          "Revision projection does not match append-only history"
        )
      }
      evidence <- DBI::dbGetQuery(
        con,
        "SELECT evidence_id, details_json, content_hash FROM evidence_entries"
      )
      for (index in seq_len(nrow(evidence))) {
        calculated <- digest::digest(
          evidence$details_json[[index]],
          algo = "sha256",
          serialize = FALSE
        )
        if (!identical(calculated, evidence$content_hash[[index]])) {
          cli::cli_abort(
            paste0(
              "Evidence content hash is invalid for ",
              "{.val {evidence$evidence_id[[index]]}}"
            )
          )
        }
      }
      bundle_mismatches <- DBI::dbGetQuery(con, paste(
        "SELECT COUNT(*) AS n FROM artifact_bundles b",
        "JOIN revisions r USING(revision_id)",
        "WHERE b.code_hash <> r.code_hash",
        "OR b.image_hash <> r.image_hash",
        "OR b.analytical_hash <> r.analytical_hash"
      ))$n[[1]]
      if (bundle_mismatches > 0L) {
        cli::cli_abort(
          "Accepted artifact bundle hashes do not match their revisions"
        )
      }
      review_mismatches <- DBI::dbGetQuery(con, paste(
        "SELECT COUNT(*) AS n FROM review_decisions d",
        "JOIN revisions r USING(revision_id)",
        "WHERE d.code_hash <> r.code_hash",
        "OR d.image_hash <> r.image_hash",
        "OR d.analytical_hash <> r.analytical_hash"
      ))$n[[1]]
      if (review_mismatches > 0L) {
        cli::cli_abort(
          "Reviewer decision hashes do not match their revisions"
        )
      }
      decisions <- DBI::dbGetQuery(
        con,
        "SELECT * FROM review_decisions ORDER BY decision_id"
      )
      decision_events <- events[
        events$event_type %in% c("review_approved", "review_rejected"), ,
        drop = FALSE
      ]
      event_decisions <- lapply(
        decision_events$payload_json,
        jsonlite::fromJSON,
        simplifyVector = TRUE
      )
      event_ids <- vapply(event_decisions, `[[`, character(1), "decision_id")
      if (!identical(sort(decisions$decision_id), sort(event_ids))) {
        cli::cli_abort("Reviewer decisions do not match lifecycle history")
      }
      for (index in seq_len(nrow(decisions))) {
        record <- as.list(decisions[index, , drop = FALSE]) |>
          lapply(\(value) value[[1]])
        calculated <- .review_decision_hash(record)
        event_index <- match(record$decision_id, event_ids)
        if (!identical(calculated, record$record_hash) ||
          !identical(
            calculated,
            event_decisions[[event_index]]$decision_hash
          )) {
          cli::cli_abort("Reviewer decision integrity check failed")
        }
      }
      receipt_mismatches <- DBI::dbGetQuery(con, paste(
        "SELECT COUNT(*) AS n FROM export_receipts e",
        "JOIN revisions r USING(revision_id)",
        "WHERE e.code_hash <> r.code_hash",
        "OR e.image_hash <> r.image_hash"
      ))$n[[1]]
      if (receipt_mismatches > 0L) {
        cli::cli_abort(
          "Export receipt hashes do not match their revisions"
        )
      }
      if (!is.null(artifact_store)) {
        hashes <- DBI::dbGetQuery(
          con,
          "SELECT code_hash, image_hash FROM revisions"
        )
        for (hash in unique(unlist(hashes))) artifact_store$verify(hash)
      }
      TRUE
    })
  }

  verify_integrity <- function(require_artifacts = FALSE) {
    checkmate::assert_flag(require_artifacts)
    .with_repository_lock(
      database_path,
      \() verify_integrity_unlocked(require_artifacts)
    )
  }

  foreign_keys_enabled <- function() {
    .with_evidence_connection(database_path, \(con) {
      identical(DBI::dbGetQuery(con, "PRAGMA foreign_keys")[[1]][[1]], 1L)
    })
  }

  cleanup_orphan_artifacts <- function(minimum_age_seconds = 3600) {
    checkmate::assert_number(
      minimum_age_seconds,
      lower = 0,
      finite = TRUE
    )
    if (is.null(artifact_store)) {
      cli::cli_abort("Artifact cleanup requires an artifact store")
    }
    .with_repository_lock(database_path, function() {
      referenced_hashes <- .with_evidence_connection(
        database_path,
        function(con) {
          hashes <- DBI::dbGetQuery(
            con,
            "SELECT code_hash, image_hash FROM revisions"
          )
          unique(unlist(hashes, use.names = FALSE))
        }
      )
      artifact_store$.cleanup_orphans(
        referenced_hashes,
        minimum_age_seconds
      )
    })
  }

  backup <- function(destination) {
    .with_repository_lock(database_path, function() {
      if (fs::dir_exists(destination) &&
        length(fs::dir_ls(destination, fail = FALSE))) {
        cli::cli_abort("Backup destination must be empty")
      }
      verify_integrity_unlocked(require_artifacts = TRUE)
      parent <- fs::path_dir(destination)
      fs::dir_create(parent, recurse = TRUE)
      staging <- fs::file_temp(tmp_dir = parent, pattern = "evidence-backup-")
      fs::dir_create(staging)
      completed <- FALSE
      on.exit(
        {
          if (!completed && fs::dir_exists(staging)) fs::dir_delete(staging)
        },
        add = TRUE
      )
      source <- .sqlite_connect(database_path)
      target <- .sqlite_connect(fs::path(staging, "evidence.sqlite"))
      on.exit(
        {
          if (DBI::dbIsValid(source)) DBI::dbDisconnect(source)
        },
        add = TRUE
      )
      on.exit(
        {
          if (DBI::dbIsValid(target)) DBI::dbDisconnect(target)
        },
        add = TRUE
      )
      RSQLite::sqliteCopyDatabase(source, target)
      DBI::dbDisconnect(target)
      DBI::dbDisconnect(source)
      staged_chain_root <- fs::path(staging, "chain-root.json")
      if (fs::file_exists(chain_root_path)) {
        fs::file_copy(chain_root_path, staged_chain_root)
      } else {
        writeLines(
          canonical_serialize(list()),
          staged_chain_root,
          useBytes = TRUE
        )
      }
      if (!is.null(artifact_store)) {
        fs::dir_copy(
          artifact_store$root,
          fs::path(staging, "artifacts")
        )
      }
      copied_store <- if (fs::dir_exists(fs::path(staging, "artifacts"))) {
        local_artifact_store(fs::path(staging, "artifacts"))
      } else {
        NULL
      }
      copied <- sqlite_evidence_repository(
        fs::path(staging, "evidence.sqlite"),
        fs::path(staging, "chain-root.json"),
        copied_store
      )
      copied$verify_integrity()
      manifest <- list(
        database_hash = digest::digest(
          file = fs::path(staging, "evidence.sqlite"),
          algo = "sha256"
        ),
        chain_root_hash = digest::digest(
          file = fs::path(staging, "chain-root.json"),
          algo = "sha256"
        ),
        table_counts = .database_table_counts(
          fs::path(staging, "evidence.sqlite")
        ),
        completed_at = .utc_timestamp()
      )
      writeLines(
        canonical_serialize(manifest),
        fs::path(staging, "backup-manifest.json"),
        useBytes = TRUE
      )
      if (fs::dir_exists(destination)) fs::dir_delete(destination)
      fs::file_move(staging, destination)
      completed <- TRUE
      invisible(destination)
    })
  }

  structure(
    list(
      database_path = fs::path_abs(database_path),
      chain_root_path = fs::path_abs(chain_root_path),
      artifact_store = artifact_store,
      create_revision = create_revision,
      list_revisions = list_revisions,
      get_revision = get_revision,
      list_events = list_events,
      record_attempt = record_attempt,
      list_attempts = list_attempts,
      complete_attempt = complete_attempt,
      record_evidence = record_evidence,
      list_evidence = list_evidence,
      accept_artifact_bundle = accept_artifact_bundle,
      get_artifact_bundle = get_artifact_bundle,
      mark_verified = mark_verified,
      record_review_decision = record_review_decision,
      list_review_decisions = list_review_decisions,
      record_export_receipt = record_export_receipt,
      list_export_receipts = list_export_receipts,
      rebuild_projections = rebuild_projections,
      verify_integrity = verify_integrity,
      foreign_keys_enabled = foreign_keys_enabled,
      cleanup_orphan_artifacts = cleanup_orphan_artifacts,
      backup = backup,
      update_revision = function(...) {
        cli::cli_abort("Updating historical revisions is not available")
      },
      delete_revision = function(...) {
        cli::cli_abort("Deleting historical revisions is not available")
      }
    ),
    class = "sqlite_evidence_repository"
  )
}

restore_evidence_repository <- function(backup_path, destination) {
  checkmate::assert_directory_exists(backup_path)
  .verify_backup_manifest(backup_path)
  if (fs::dir_exists(destination) &&
    length(fs::dir_ls(destination, fail = FALSE))) {
    cli::cli_abort("Restore destination must be empty")
  }
  parent <- fs::path_dir(destination)
  fs::dir_create(parent, recurse = TRUE)
  staging <- fs::file_temp(tmp_dir = parent, pattern = "evidence-restore-")
  fs::dir_create(staging)
  completed <- FALSE
  on.exit(
    {
      if (!completed && fs::dir_exists(staging)) fs::dir_delete(staging)
    },
    add = TRUE
  )
  fs::file_copy(
    fs::path(backup_path, "evidence.sqlite"),
    fs::path(staging, "evidence.sqlite")
  )
  fs::file_copy(
    fs::path(backup_path, "chain-root.json"),
    fs::path(staging, "chain-root.json")
  )
  store <- NULL
  if (fs::dir_exists(fs::path(backup_path, "artifacts"))) {
    fs::dir_copy(
      fs::path(backup_path, "artifacts"),
      fs::path(staging, "artifacts")
    )
    store <- local_artifact_store(fs::path(staging, "artifacts"))
  }
  repo <- sqlite_evidence_repository(
    fs::path(staging, "evidence.sqlite"),
    fs::path(staging, "chain-root.json"),
    store
  )
  repo$verify_integrity()
  if (fs::dir_exists(destination)) fs::dir_delete(destination)
  fs::file_move(staging, destination)
  completed <- TRUE
  restored_store <- if (fs::dir_exists(fs::path(destination, "artifacts"))) {
    local_artifact_store(fs::path(destination, "artifacts"))
  } else {
    NULL
  }
  sqlite_evidence_repository(
    fs::path(destination, "evidence.sqlite"),
    fs::path(destination, "chain-root.json"),
    restored_store
  )
}

#' The application server-side
#'
#' @param input,output,session Internal parameters for {shiny}.
#'     DO NOT REMOVE.
#' @param runtime_config Injected runtime configuration.
#' @import shiny
#' @noRd
app_server <- function(
  input,
  output,
  session,
  runtime_config = new_runtime_config()
) {
  workspace_root <- fs::path(
    fs::path_temp(),
    "adamviz-submissionsync-workspace",
    runtime_config$workspace
  )
  fs::dir_create(workspace_root, recurse = TRUE)
  workspace_provider <- local_workspace_provider(
    stats::setNames(workspace_root, runtime_config$workspace)
  )
  fs::dir_create(runtime_config$evidence_root, recurse = TRUE)
  current_revision <- shiny::reactiveVal(.empty_assurance_state())

  execute_revision <- function(fields) {
    state <- current_revision()
    if (is.null(state$pending)) {
      cli::cli_abort("Create an inspectable specification before execution")
    }
    current_revision(.execute_assurance_revision(
      snapshot = state$pending$snapshot,
      prompt = state$pending$prompt,
      fields = fields,
      repository_root = runtime_config$evidence_root
    ))
    invisible(current_revision())
  }

  create_correction <- function(fields, rationale, provenance) {
    current_revision(.execute_correction_revision(
      state = current_revision(),
      fields = fields,
      rationale = rationale,
      provenance = provenance
    ))
    invisible(current_revision())
  }

  mod_plot_generation_server(
    "plot_generation",
    current_revision = current_revision,
    execute_revision = execute_revision,
    create_correction = create_correction,
    workspace_provider = workspace_provider
  )
}

.empty_assurance_state <- function() {
  list(
    pending = NULL,
    plot_id = NULL,
    repository = NULL,
    identity_provider = NULL,
    review_service = NULL,
    revision = NULL,
    spec = NULL,
    snapshot = NULL,
    prompt = NULL,
    choices = NULL,
    profile = NULL,
    script = NULL,
    artifact = NULL,
    verification = NULL
  )
}

.create_assurance_candidate <- function(provider, dataset_id, prompt) {
  if (!checkmate::test_string(dataset_id, min.chars = 1L)) {
    cli::cli_abort("Select one authorized BDS dataset")
  }
  snapshot <- pin_study_snapshot(provider, dataset_id)
  if (!is.null(provider$source_metadata)) {
    snapshot$source_metadata <- provider$source_metadata
  }
  context <- build_prompt_context(snapshot)
  interpretation <- interpret_prompt(prompt, context, mock_prompt_interpreter())
  spec <- interpretation$candidate %||% new_plot_spec(dataset_id = dataset_id)
  choices <- .spec_choices_from_context(context)
  list(
    pending = list(
      snapshot = snapshot,
      prompt = prompt,
      choices = choices
    ),
    plot_id = NULL,
    repository = NULL,
    identity_provider = NULL,
    review_service = NULL,
    revision = NULL,
    spec = spec,
    snapshot = snapshot,
    prompt = prompt,
    choices = choices,
    profile = NULL,
    script = NULL,
    artifact = NULL,
    verification = NULL
  )
}

.spec_choices_from_context <- function(context) {
  profile <- context$aggregate_profile
  list(
    parameters = names(profile$parameters),
    units = lapply(profile$parameters, `[[`, "units"),
    y_variables = profile$y_variables,
    treatment_variables = profile$treatment_variables,
    treatment_levels = profile$treatment_levels,
    visits = vapply(profile$visits, `[[`, "", "label"),
    scale_modes = profile$scale_modes
  )
}

.execute_assurance_revision <- function(
  snapshot,
  prompt,
  fields,
  repository_root = NULL
) {
  spec <- .confirmed_spec_from_fields(snapshot$dataset_id, fields)
  profile <- validate_bds_profile(
    snapshot,
    spec$fields[setdiff(.plot_spec_fields, c("dataset_id", "scale_mode"))]
  )
  if (profile$blocked) {
    diagnostic <- profile$blocking_diagnostics[[1]]
    cli::cli_abort(c(
      "The selected records are outside the supported BDS profile",
      "x" = paste0(diagnostic$code, ": ", diagnostic$message)
    ))
  }
  .materialize_revision(snapshot, prompt, spec, profile, repository_root)
}

.execute_correction_revision <- function(state, fields, rationale, provenance) {
  if (is.null(state$repository) || is.null(state$revision) ||
    is.null(state$snapshot)) {
    cli::cli_abort("Create a revision before starting a correction")
  }
  parent <- state$repository$get_revision(state$revision$revision_id)
  if (!parent$status %in% c("Rejected", "Reviewed")) {
    cli::cli_abort(
      "Only a Rejected or Reviewed revision can start a correction"
    )
  }
  if (!checkmate::test_string(rationale, min.chars = 1L) ||
    !checkmate::test_string(provenance, min.chars = 1L)) {
    cli::cli_abort("Correction rationale and provenance are required")
  }
  spec <- .confirmed_spec_from_fields(state$snapshot$dataset_id, fields)
  profile <- validate_bds_profile(
    state$snapshot,
    spec$fields[setdiff(.plot_spec_fields, c("dataset_id", "scale_mode"))]
  )
  if (profile$blocked) {
    diagnostic <- profile$blocking_diagnostics[[1]]
    cli::cli_abort(c(
      "The selected records are outside the supported BDS profile",
      "x" = paste0(diagnostic$code, ": ", diagnostic$message)
    ))
  }

  .materialize_correction(
    state,
    spec,
    profile,
    rationale,
    provenance
  )
}

.create_assurance_revision <- function(
  provider,
  dataset_id,
  prompt,
  confirm_free_scale
) {
  snapshot <- pin_study_snapshot(provider, dataset_id)
  context <- build_prompt_context(snapshot)
  interpretation <- interpret_prompt(
    prompt,
    context,
    mock_prompt_interpreter(),
    snapshot = NULL
  )
  if (is.null(interpretation$candidate)) {
    cli::cli_abort("The prompt could not create an executable candidate")
  }
  fields <- interpretation$candidate$fields
  if (identical(fields$scale_mode, "free") && !isTRUE(confirm_free_scale)) {
    cli::cli_abort(
      paste0(
        "Free Y scales require confirmation because they create an ",
        "Experimental/Draft revision"
      )
    )
  }
  .execute_assurance_revision(snapshot, prompt, fields)
}

.confirmed_spec_from_fields <- function(dataset_id, fields) {
  if (!checkmate::test_string(fields$paramcd, min.chars = 1L) ||
    !checkmate::test_choice(fields$y_variable, c("AVAL", "CHG", "PCHG")) ||
    !checkmate::test_string(fields$unit, min.chars = 1L) ||
    !checkmate::test_string(fields$treatment_variable, min.chars = 1L) ||
    !checkmate::test_character(
      fields$treatment_levels,
      min.len = 1L,
      any.missing = FALSE,
      unique = TRUE
    ) ||
    !checkmate::test_character(
      fields$visits,
      min.len = 1L,
      any.missing = FALSE,
      unique = TRUE
    )) {
    cli::cli_abort(paste0(
      "Confirm one parameter, one Y variable, one unit, one treatment facet, ",
      "and at least one treatment level and visit"
    ))
  }
  provenance <- as.list(stats::setNames(
    rep("user_confirmed", length(.plot_spec_fields)),
    .plot_spec_fields
  ))
  provenance$dataset_id <- "metadata"
  spec <- new_plot_spec(
    dataset_id = dataset_id,
    paramcd = fields$paramcd,
    y_variable = fields$y_variable,
    unit = fields$unit,
    treatment_variable = fields$treatment_variable,
    treatment_levels = fields$treatment_levels,
    visits = fields$visits,
    scale_mode = fields$scale_mode %||% "fixed",
    provenance = as.list(provenance),
    state = "candidate"
  )
  confirm_plot_spec(spec)
}

.materialize_revision <- function(
  snapshot,
  prompt,
  spec,
  profile,
  repository_root = NULL
) {
  script <- compile_boxplot_script(spec, profile$low_n_policy)
  request <- new_execution_request(
    spec = spec,
    script_hash = .execution_hash_text(script),
    snapshot_id = profile$snapshot_id,
    snapshot_hash = canonical_hash(profile$analysis_data),
    harness_version = "execution-harness-v1"
  )
  root <- repository_root %||% fs::file_temp(pattern = "assurance-session-")
  artifact_store <- local_artifact_store(fs::path(root, "artifacts"))
  repository <- sqlite_evidence_repository(
    fs::path(root, "evidence.sqlite"),
    fs::path(root, "chain-root.json"),
    artifact_store
  )
  revision_suffix <- substr(
    canonical_hash(list(spec$hash, Sys.time(), tempfile("revision-"))),
    1L,
    12L
  )
  revision_id <- paste0("rev-", revision_suffix)
  plot_id <- paste0("plot-", revision_suffix)
  initial_status <- if (identical(spec$fields$scale_mode, "free")) {
    "Experimental/Draft"
  } else {
    "Draft"
  }

  code_hash <- artifact_store$put(.execution_text_bytes(script))
  repository$create_revision(
    plot_id = plot_id,
    revision_id = revision_id,
    revision_number = 1L,
    creator_id = "creator",
    spec_hash = spec$hash,
    code_hash = code_hash,
    image_hash = NULL,
    analytical_hash = NULL,
    idempotency_key = paste0("create:", revision_id),
    initial_status = initial_status
  )

  verification <- NULL
  if (identical(initial_status, "Draft")) {
    execution_service <- new_execution_service(
      repository,
      artifact_store = artifact_store
    )
    execution <- execution_service$submit(
      revision_id = revision_id,
      request = request,
      script = script,
      analysis_data = profile$analysis_data,
      idempotency_key = paste0("execute:", revision_id)
    )
    verification <- execution$verification
    runner_result <- execution$runner_result
  }

  identities <- local_identity_provider(list(
    new_actor("creator", "clinical_scientist"),
    new_actor("stat-programmer", "statistical_programmer"),
    new_actor("biostatistician", "biostatistician")
  ))
  analysis <- calculate_boxplot_statistics(
    profile$display_data,
    treatment_variable = spec$fields$treatment_variable,
    y_variable = spec$fields$y_variable,
    facet_levels = profile$facet_levels,
    visit_levels = profile$visit_levels,
    low_n_policy = profile$low_n_policy
  )
  artifact <- assemble_boxplot(
    analysis,
    scale_mode = spec$fields$scale_mode,
    unit = spec$fields$unit
  )
  context <- build_prompt_context(snapshot)

  state <- list(
    pending = NULL,
    plot_id = plot_id,
    repository = repository,
    identity_provider = identities,
    review_service = new_review_service(repository, identities),
    revision = repository$get_revision(revision_id),
    spec = spec,
    snapshot = snapshot,
    prompt = prompt,
    choices = .spec_choices_from_context(context),
    profile = profile,
    script = script,
    artifact = artifact,
    verification = verification
  )
  if (!is.null(verification)) {
    .record_revision_context( # nolint: object_usage_linter.
      state,
      request = request,
      runner_result = runner_result
    )
  }
  state
}

.materialize_correction <- function(
  state,
  spec,
  profile,
  rationale,
  provenance
) {
  script <- compile_boxplot_script(spec, profile$low_n_policy)
  request <- new_execution_request(
    spec = spec,
    script_hash = .execution_hash_text(script),
    snapshot_id = profile$snapshot_id,
    snapshot_hash = canonical_hash(profile$analysis_data),
    harness_version = "execution-harness-v1"
  )
  artifact_store <- state$repository$artifact_store
  if (is.null(artifact_store)) {
    cli::cli_abort("Correction revisions require an artifact store")
  }
  parent <- state$repository$get_revision(state$revision$revision_id)
  revisions <- state$repository$list_revisions(parent$plot_id)
  revision_number <- max(revisions$revision_number) + 1L
  revision_id <- paste0("rev-", substr(canonical_hash(list(
    parent$revision_id,
    spec$hash,
    revision_number,
    Sys.time()
  )), 1L, 12L))
  code_hash <- artifact_store$put(.execution_text_bytes(script))
  lifecycle <- new_lifecycle_service(state$repository)
  lifecycle$create_correction(
    parent_revision_id = parent$revision_id,
    revision_id = revision_id,
    creator_id = "creator",
    spec_hash = spec$hash,
    code_hash = code_hash,
    image_hash = NULL,
    analytical_hash = NULL,
    rationale = rationale,
    provenance = provenance,
    idempotency_key = paste0("correct:", revision_id),
    initial_status = .initial_revision_status(spec$fields$scale_mode)
  )

  verification <- NULL
  if (identical(spec$fields$scale_mode, "fixed")) {
    execution <- new_execution_service(
      state$repository,
      artifact_store = artifact_store
    )$submit(
      revision_id = revision_id,
      request = request,
      script = script,
      analysis_data = profile$analysis_data,
      idempotency_key = paste0("execute:", revision_id)
    )
    verification <- execution$verification
    runner_result <- execution$runner_result
  }

  analysis <- calculate_boxplot_statistics(
    profile$display_data,
    treatment_variable = spec$fields$treatment_variable,
    y_variable = spec$fields$y_variable,
    facet_levels = profile$facet_levels,
    visit_levels = profile$visit_levels,
    low_n_policy = profile$low_n_policy
  )
  artifact <- assemble_boxplot(
    analysis,
    scale_mode = spec$fields$scale_mode,
    unit = spec$fields$unit
  )

  state$pending <- NULL
  state$revision <- state$repository$get_revision(revision_id)
  state$spec <- spec
  state$profile <- profile
  state$script <- script
  state$artifact <- artifact
  state$verification <- verification
  if (!is.null(verification)) {
    .record_revision_context( # nolint: object_usage_linter.
      state,
      request = request,
      runner_result = runner_result
    )
  }
  state
}

.latest_revision_context <- function(repository, revision_id) {
  evidence <- repository$list_evidence(revision_id)
  evidence <- evidence[
    evidence$evidence_type == "revision_context", ,
    drop = FALSE
  ]
  if (!nrow(evidence)) {
    cli::cli_abort(
      "Revision {.val {revision_id}} has no revision context evidence"
    )
  }
  jsonlite::fromJSON(
    evidence$details_json[[nrow(evidence)]],
    simplifyVector = FALSE
  )
}

.evidence_selected_data <- function(details) {
  columns <- lapply(details$input_data$selected_data, function(column) {
    if (is.list(column)) unlist(column, use.names = FALSE) else column
  })
  column_order <- unlist(
    details$input_data$selected_data_columns %||% names(columns),
    use.names = FALSE
  )
  columns <- columns[column_order]
  columns <- lapply(columns, function(column) {
    column[column == "NA"] <- NA
    column
  })
  classes <- unlist(
    details$input_data$selected_data_classes %||% list(),
    use.names = TRUE
  )
  if (!is.null(names(classes))) {
    names(classes) <- sub("^.*[.]", "", names(classes))
  }
  if (!length(names(classes)) && identical(length(classes), length(columns))) {
    names(classes) <- column_order
  }
  for (name in intersect(names(columns), names(classes))) {
    if (classes[[name]] %in% c("numeric", "integer")) {
      columns[[name]] <- as.numeric(columns[[name]])
    }
    if (identical(classes[[name]], "integer")) {
      columns[[name]] <- as.integer(columns[[name]])
    }
  }
  data <- as.data.frame(columns, stringsAsFactors = FALSE)
  data
}

.evidence_execution_request <- function(details) {
  structure(details$request, class = "execution_request")
}

new_reproducibility_service <- function(
  repository,
  artifact_store,
  runner = new_execution_runner(),
  verification_service = new_verification_service()
) {
  .validate_evidence_repository(
    repository,
    c("get_revision", "list_evidence", "record_evidence")
  )
  if (!is.list(artifact_store) ||
    !is.function(artifact_store$get) ||
    !is.function(artifact_store$verify)) {
    cli::cli_abort("Reproducibility service requires a readable artifact store")
  }
  if (!is.function(runner$run)) {
    cli::cli_abort("Reproducibility runner must provide {.fn run}")
  }
  if (!is.function(verification_service$verify)) {
    cli::cli_abort("Verification service must provide {.fn verify}")
  }

  reproduce_revision <- function(revision_id, idempotency_key = NULL) {
    .validate_identifier(revision_id, "revision_id")
    if (!is.null(idempotency_key)) {
      .validate_identifier(idempotency_key, "idempotency_key")
    }
    revision <- repository$get_revision(revision_id)
    details <- .latest_revision_context(repository, revision_id)
    request <- .evidence_execution_request(details)
    script <- rawToChar(artifact_store$get(revision$code_hash))
    analysis_data <- .evidence_selected_data(details)
    runner_result <- runner$run(
      request = request,
      script = script,
      analysis_data = analysis_data,
      data_classification = details$input_data$classification %||% "synthetic"
    )
    verification <- verification_service$verify(
      request = request,
      script = script,
      analysis_data = analysis_data,
      runner_result = runner_result
    )
    environment_match <- identical(
      runner_result$result$environment_fingerprint,
      details$environment$fingerprint
    )
    checks <- list(
      specification = identical(request$spec_hash, revision$spec_hash),
      generated_r_code = identical(
        .execution_hash_text(script), revision$code_hash
      ),
      analytical_result = identical(
        runner_result$result$analytical_hash,
        revision$analytical_hash
      ),
      environment = environment_match,
      image_bytes = if (environment_match) {
        identical(runner_result$result$image_hash, revision$image_hash)
      } else {
        NA
      }
    )
    failed <- names(checks)[vapply(checks, identical, logical(1), FALSE)]
    status <- if (length(failed)) "failed" else "passed"
    result <- structure(
      list(
        reproducibility_version = "revision-reproducibility-v1",
        status = status,
        checks = checks,
        failed_checks = failed,
        verification = unclass(verification)
      ),
      class = "revision_reproducibility_result"
    )
    if (!is.null(idempotency_key)) {
      repository$record_evidence(
        evidence_id = .revision_evidence_id(revision_id, idempotency_key),
        revision_id = revision_id,
        evidence_type = "reproducibility_rerun",
        outcome = status,
        idempotency_key = idempotency_key,
        details = unclass(result)
      )
    }
    result
  }

  structure(
    list(reproduce_revision = reproduce_revision),
    class = "reproducibility_service"
  )
}

.validate_boxplot_design <- function(facet_levels, visit_levels, low_n_policy) {
  if (!checkmate::test_character(
    facet_levels,
    min.len = 1L,
    any.missing = FALSE,
    unique = TRUE
  ) || !checkmate::test_character(
    visit_levels,
    min.len = 1L,
    any.missing = FALSE,
    unique = TRUE
  )) {
    cli::cli_abort(paste0(
      "Facet and visit levels must be ordered, ",
      "unique character vectors"
    ))
  }
  required_policy <- c("value", "rationale", "authority", "version")
  if (!is.list(low_n_policy) ||
    !setequal(names(low_n_policy), required_policy) ||
    !checkmate::test_number(low_n_policy$value, lower = 1, finite = TRUE) ||
    !all(vapply(
      low_n_policy[setdiff(required_policy, "value")],
      checkmate::test_string,
      logical(1),
      min.chars = 1L
    ))) {
    cli::cli_abort(paste0(
      "{.arg low_n_policy} must retain value, rationale, ",
      "authority, and version"
    ))
  }
  invisible(TRUE)
}

.validate_boxplot_inputs <- function(
  data,
  treatment_variable,
  y_variable,
  facet_levels,
  visit_levels,
  low_n_policy
) {
  required_columns <- c(
    "USUBJID", "AVISIT", "AVISITN", treatment_variable, y_variable
  )
  missing_columns <- setdiff(required_columns, names(data))
  if (!is.data.frame(data) || length(missing_columns)) {
    cli::cli_abort(
      paste0(
        "{.arg data} must contain the governed analytical columns: ",
        "{.field {required_columns}}"
      )
    )
  }
  if (!is.numeric(data[[y_variable]])) {
    cli::cli_abort("The selected Y variable must be numeric")
  }
  .validate_boxplot_design(facet_levels, visit_levels, low_n_policy)
}

.type7_quantile_from_sorted <- function(values, probability) {
  count <- length(values)
  position <- (count - 1) * probability + 1
  lower_index <- floor(position)
  fraction <- position - lower_index
  if (fraction == 0 || lower_index == count) {
    return(values[[lower_index]])
  }
  values[[lower_index]] + fraction * (
    values[[lower_index + 1L]] - values[[lower_index]]
  )
}

.summarize_box <- function(
  rows,
  treatment_variable,
  y_variable,
  low_n_threshold
) {
  values <- rows[[y_variable]]
  sorted_values <- sort(values, method = "radix")
  lower <- .type7_quantile_from_sorted(sorted_values, 0.25)
  middle <- .type7_quantile_from_sorted(sorted_values, 0.5)
  upper <- .type7_quantile_from_sorted(sorted_values, 0.75)
  interquartile_range <- upper - lower
  lower_fence <- lower - 1.5 * interquartile_range
  upper_fence <- upper + 1.5 * interquartile_range
  inside <- values >= lower_fence & values <= upper_fence
  distinct_n <- length(unique(as.character(rows$USUBJID)))

  list(
    box = data.frame(
      treatment = as.character(rows[[treatment_variable]][[1]]),
      visit = as.character(rows$AVISIT[[1]]),
      visit_n = rows$AVISITN[[1]],
      n = as.integer(distinct_n),
      ymin = min(values[inside]),
      lower = lower,
      middle = middle,
      upper = upper,
      ymax = max(values[inside]),
      low_n = distinct_n < low_n_threshold,
      stringsAsFactors = FALSE
    ),
    outliers = data.frame(
      treatment = as.character(rows[[treatment_variable]][!inside]),
      visit = as.character(rows$AVISIT[!inside]),
      visit_n = rows$AVISITN[!inside],
      USUBJID = as.character(rows$USUBJID[!inside]),
      value = values[!inside],
      stringsAsFactors = FALSE
    )
  )
}

.summarize_box_indices <- function(
  index,
  data,
  treatment_variable,
  y_variable,
  low_n_threshold
) {
  .summarize_box(
    data[index, , drop = FALSE],
    treatment_variable,
    y_variable,
    low_n_threshold
  )
}

.empty_outlier_data <- function() {
  data.frame(
    treatment = character(),
    visit = character(),
    visit_n = numeric(),
    USUBJID = character(),
    value = numeric(),
    stringsAsFactors = FALSE
  )
}

#' Calculate governed longitudinal boxplot statistics
#'
#' Calculates type-7 hinges, 1.5-IQR whiskers, visible outlier membership,
#' distinct-subject counts, low-N flags, and median-line rows from the selected
#' analytical data. Missing selected Y values do not contribute.
#'
#' @param data Selected records from a validated visit-based BDS profile.
#' @param treatment_variable Name of the selected treatment variable.
#' @param y_variable Name of the selected numeric Y variable.
#' @param facet_levels Ordered included treatment values.
#' @param visit_levels Ordered included visit labels.
#' @param low_n_policy Retained policy with `value`, `rationale`, `authority`,
#'   and `version`.
#'
#' @return A deterministic `boxplot_analysis` object.
#' @export
calculate_boxplot_statistics <- function(
  data,
  treatment_variable,
  y_variable,
  facet_levels,
  visit_levels,
  low_n_policy
) {
  .validate_boxplot_inputs(
    data,
    treatment_variable,
    y_variable,
    facet_levels,
    visit_levels,
    low_n_policy
  )
  low_n_policy$value <- as.numeric(low_n_policy$value)
  display <- data[
    !is.na(data[[y_variable]]) &
      !is.na(data[[treatment_variable]]) &
      data[[treatment_variable]] %in% facet_levels &
      !is.na(data$AVISIT) &
      data$AVISIT %in% visit_levels, ,
    drop = FALSE
  ]
  if (any(!is.finite(display[[y_variable]]))) {
    cli::cli_abort("The selected Y variable must contain only finite values")
  }
  if (nrow(display)) {
    treatment_order <- match(
      as.character(display[[treatment_variable]]),
      facet_levels
    )
    visit_order <- match(as.character(display$AVISIT), visit_levels)
    ordering <- order(
      treatment_order,
      visit_order,
      as.character(display$USUBJID),
      method = "radix"
    )
    display <- display[ordering, , drop = FALSE]
    row.names(display) <- NULL
    group_start <- c(
      TRUE,
      as.character(display[[treatment_variable]][-1L]) !=
        as.character(display[[treatment_variable]][-nrow(display)]) |
        as.character(display$AVISIT[-1L]) !=
          as.character(display$AVISIT[-nrow(display)])
    )
    group_id <- cumsum(group_start)
    summaries <- lapply(
      split(seq_len(nrow(display)), group_id),
      .summarize_box_indices,
      data = display,
      treatment_variable = treatment_variable,
      y_variable = y_variable,
      low_n_threshold = low_n_policy$value
    )
    boxes <- do.call(rbind, lapply(summaries, `[[`, "box"))
    outlier_rows <- lapply(summaries, `[[`, "outliers")
    outliers <- if (sum(vapply(outlier_rows, nrow, integer(1))) > 0L) {
      do.call(rbind, outlier_rows)
    } else {
      .empty_outlier_data()
    }
    box_order <- order(
      match(boxes$treatment, facet_levels),
      match(boxes$visit, visit_levels),
      method = "radix"
    )
    boxes <- boxes[box_order, , drop = FALSE]
    row.names(boxes) <- NULL
    if (nrow(outliers)) {
      outlier_order <- order(
        match(outliers$treatment, facet_levels),
        match(outliers$visit, visit_levels),
        outliers$value,
        outliers$USUBJID,
        method = "radix"
      )
      outliers <- outliers[outlier_order, , drop = FALSE]
      row.names(outliers) <- NULL
    }
  } else {
    boxes <- data.frame(
      treatment = character(), visit = character(), visit_n = numeric(),
      n = integer(), ymin = numeric(), lower = numeric(), middle = numeric(),
      upper = numeric(), ymax = numeric(), low_n = logical(),
      stringsAsFactors = FALSE
    )
    outliers <- .empty_outlier_data()
  }
  medians <- boxes[c("treatment", "visit", "visit_n", "middle")]
  names(medians)[[4]] <- "median"
  n_strip <- boxes[c("treatment", "visit", "visit_n", "n", "low_n")]
  n_strip$label <- ifelse(
    n_strip$low_n,
    paste0("N = ", n_strip$n, " - Low N"),
    paste0("N = ", n_strip$n)
  )

  structure(
    list(
      analysis_version = "boxplot-analysis-v1",
      treatment_variable = treatment_variable,
      y_variable = y_variable,
      facet_levels = facet_levels,
      visit_levels = visit_levels,
      low_n_policy = low_n_policy,
      boxes = boxes,
      outliers = outliers,
      medians = medians,
      n_strip = n_strip
    ),
    class = "boxplot_analysis"
  )
}

reconcile_execution_attempts <- function(repository, revision_ids) {
  .validate_evidence_repository(
    repository,
    c("list_attempts", "complete_attempt")
  )
  if (!checkmate::test_character(
    revision_ids,
    any.missing = FALSE,
    unique = TRUE
  )) {
    cli::cli_abort(
      "{.arg revision_ids} must contain unique revision identifiers"
    )
  }
  reconciled <- list()
  for (revision_id in revision_ids) {
    attempts <- repository$list_attempts(revision_id)
    active <- attempts[is.na(attempts$outcome), , drop = FALSE]
    if (!nrow(active)) next
    for (index in seq_len(nrow(active))) {
      attempt_id <- active$attempt_id[[index]]
      repository$complete_attempt(
        attempt_id,
        "failed",
        paste0("reconcile:", attempt_id)
      )
      reconciled[[attempt_id]] <- "failed"
    }
  }
  structure(
    list(
      reconciliation_version = "attempt-reconciliation-v1",
      reconciled = reconciled
    ),
    class = "attempt_reconciliation"
  )
}

mod_export_ui <- function(id) {
  ns <- shiny::NS(id)
  bslib::card(
    class = "assurance-panel",
    bslib::card_header("Controlled export"),
    bslib::card_body(
      shiny::uiOutput(ns("controls")),
      shiny::verbatimTextOutput(ns("message")),
      shiny::tableOutput(ns("receipts"))
    )
  )
}

mod_export_server <- function(id, current_revision, workspace_provider) {
  shiny::moduleServer(id, function(input, output, session) {
    message <- shiny::reactiveVal("No export attempted.")
    receipt_refresh <- shiny::reactiveVal(0L)

    export_ready <- shiny::reactive({
      identical(current_revision()$revision$status, "Reviewed")
    })

    output$controls <- shiny::renderUI({
      shiny::tags$fieldset(
        disabled = if (!export_ready()) NA else NULL,
        shiny::selectInput(
          session$ns("actor_id"),
          "Actor",
          choices = c(
            "Creator" = "creator",
            "Statistical programmer" = "stat-programmer",
            "Biostatistician" = "biostatistician"
          )
        ),
        shiny::textInput(
          session$ns("destination_id"), "Destination",
          value = "local"
        ),
        shiny::downloadButton(
          session$ns("download_zip"), "Export and download ZIP",
          enabled = export_ready()
        )
      )
    })

    output$message <- shiny::renderText(message())
    output$download_zip <- shiny::downloadHandler(
      filename = function() {
        state <- current_revision()
        if (is.null(state$revision)) {
          return("image-code.zip")
        }
        paste0(state$revision$revision_id, "-image-code.zip")
      },
      content = function(file) {
        shiny::req(export_ready())
        state <- current_revision()
        succeeded <- tryCatch(
          {
            if (is.null(state$revision) || is.null(state$repository)) {
              cli::cli_abort("Create a revision before export")
            }
            if (is.null(state$identity_provider)) {
              cli::cli_abort("Export requires an identity provider")
            }
            service <- new_export_service(
              state$repository,
              state$repository$artifact_store,
              workspace_provider,
              state$identity_provider
            )
            receipt <- service$export_revision(
              revision_id = state$revision$revision_id,
              actor_id = input$actor_id,
              destination_id = input$destination_id,
              expected_version = as.integer(state$revision$version),
              idempotency_key = paste(
                "app-export",
                state$revision$revision_id,
                input$actor_id,
                input$destination_id,
                sep = ":"
              )
            )
            receipt_refresh(receipt_refresh() + 1L)
            .write_export_zip(receipt, file, state$revision$revision_id)
            message(paste("Exported", receipt$receipt_id, receipt$revision_id))
            TRUE
          },
          error = function(error) {
            message(conditionMessage(error))
            FALSE
          }
        )
        shiny::req(succeeded)
      },
      contentType = "application/zip"
    )
    output$receipts <- shiny::renderTable(
      {
        receipt_refresh()
        state <- current_revision()
        if (is.null(state$revision) || is.null(state$repository)) {
          return(data.frame())
        }
        state$repository$list_export_receipts(state$revision$revision_id)
      },
      striped = TRUE,
      spacing = "s"
    )
  })
}

.write_export_zip <- function(export, file, revision_id) {
  if (is.null(export)) {
    cli::cli_abort("Export the revision before download")
  }
  if (!identical(export$revision_id, revision_id)) {
    cli::cli_abort("Export the current revision before download")
  }

  root <- fs::dir_create(fs::file_temp("revision-download-"))
  fs::file_copy(export$code_path, fs::path(root, "script.R"))
  fs::file_copy(export$image_path, fs::path(root, "plot.png"))

  file <- fs::path_abs(file)
  old <- getwd()
  on.exit(
    {
      setwd(old)
      fs::dir_delete(root)
    },
    add = TRUE
  )
  setwd(root)
  status <- utils::zip(file, c("script.R", "plot.png"), flags = "-q")
  if (!identical(status, 0L) || !fs::file_exists(file)) {
    cli::cli_abort("Could not create ZIP download")
  }
  invisible(file)
}

.execution_request_fingerprint <- function(request, script, analysis_data) {
  canonical_hash(list(
    request = unclass(request),
    script_hash = .execution_hash_text(script),
    snapshot_hash = canonical_hash(analysis_data)
  ))
}

.execution_attempt_id <- function(idempotency_key) {
  paste0("attempt-", substr(canonical_hash(idempotency_key), 1L, 24L))
}

.execution_id <- function(prefix, attempt_id, suffix) {
  paste(
    prefix,
    substr(canonical_hash(list(attempt_id, suffix)), 1L, 24L),
    sep = "-"
  )
}

new_execution_service <- function(
  repository,
  runner = new_callr_execution_runner(),
  verification_service = new_verification_service(),
  artifact_store = NULL
) {
  .validate_evidence_repository(
    repository,
    c(
      "record_attempt", "list_attempts", "complete_attempt",
      "record_evidence", "accept_artifact_bundle", "mark_verified",
      "get_revision"
    )
  )
  if (!is.function(runner$run)) {
    cli::cli_abort("Execution runner must provide {.fn run}")
  }
  if (!is.function(verification_service$verify)) {
    cli::cli_abort("Verification service must provide {.fn verify}")
  }

  start <- function(
    revision_id,
    request,
    script,
    analysis_data,
    idempotency_key
  ) {
    revision <- repository$get_revision(revision_id)
    if (!identical(revision$status, "Draft")) {
      cli::cli_abort("Only Draft revisions can be submitted for verification")
    }
    attempts <- repository$list_attempts(revision_id)
    active <- attempts[is.na(attempts$outcome), , drop = FALSE]
    attempt_id <- .execution_attempt_id(idempotency_key)
    fingerprint <- .execution_request_fingerprint(
      request,
      script,
      analysis_data
    )
    if (nrow(active) && !attempt_id %in% active$attempt_id) {
      cli::cli_abort("A revision can have only one active execution attempt")
    }
    repository$record_attempt(attempt_id, revision_id, fingerprint)
    invisible(list(
      revision_id = revision_id,
      revision_version = as.integer(revision$version),
      attempt_id = attempt_id,
      idempotency_key = idempotency_key,
      request = request,
      script = script,
      analysis_data = analysis_data,
      work_dir = fs::file_temp(pattern = paste0(attempt_id, "-"))
    ))
  }

  complete <- function(attempt, runner_result) {
    verification <- verification_service$verify(
      request = attempt$request,
      script = attempt$script,
      analysis_data = attempt$analysis_data,
      runner_result = runner_result
    )
    evidence_id <- .execution_id("evidence", attempt$attempt_id, "verification")
    repository$record_evidence(
      evidence_id = evidence_id,
      revision_id = attempt$revision_id,
      evidence_type = "execution_verification",
      outcome = verification$status,
      idempotency_key = paste0(attempt$idempotency_key, ":evidence"),
      details = list(
        attempt_id = attempt$attempt_id,
        verification = unclass(verification),
        execution_result = unclass(runner_result$result %||% list()),
        environment = runner_result$environment %||% list(
          fingerprint = runner_result$result$environment_fingerprint %||%
            NA_character_
        ),
        diagnostics = runner_result$diagnostics
      )
    )
    if (!identical(verification$status, "passed")) {
      repository$complete_attempt(
        attempt$attempt_id,
        "failed",
        paste0(attempt$idempotency_key, ":terminal")
      )
      return(invisible(list(
        attempt_id = attempt$attempt_id,
        status = "failed",
        verification = verification,
        runner_result = runner_result
      )))
    }
    if (!is.null(artifact_store)) {
      artifact_store$put(.execution_text_bytes(attempt$script))
      artifact_store$put(readBin(
        runner_result$image_path,
        what = "raw",
        n = fs::file_size(runner_result$image_path)
      ))
    }
    repository$accept_artifact_bundle(
      bundle_id = .execution_id("bundle", attempt$attempt_id, "accepted"),
      revision_id = attempt$revision_id,
      code_hash = attempt$request$script_hash,
      image_hash = runner_result$result$image_hash,
      analytical_hash = runner_result$result$analytical_hash,
      idempotency_key = paste0(attempt$idempotency_key, ":bundle")
    )
    repository$complete_attempt(
      attempt$attempt_id,
      "succeeded",
      paste0(attempt$idempotency_key, ":terminal")
    )
    repository$mark_verified(
      attempt$revision_id,
      attempt$revision_version,
      paste0(attempt$idempotency_key, ":verified")
    )
    invisible(list(
      attempt_id = attempt$attempt_id,
      status = "verified",
      verification = verification,
      result = runner_result$result,
      runner_result = runner_result
    ))
  }

  submit <- function(
    revision_id,
    request,
    script,
    analysis_data,
    idempotency_key,
    data_classification = "synthetic"
  ) {
    attempt <- start(
      revision_id,
      request,
      script,
      analysis_data,
      idempotency_key
    )
    runner_result <- tryCatch(
      runner$run(
        request = request,
        script = script,
        analysis_data = analysis_data,
        data_classification = data_classification,
        work_dir = attempt$work_dir
      ),
      error = \(error) {
        structure(
          list(
            status = "failed",
            manifest_version = "execution-runner-result-v1",
            diagnostics = list(stdout = "", stderr = conditionMessage(error))
          ),
          class = "execution_runner_result"
        )
      }
    )
    complete(attempt, runner_result)
  }

  structure(
    list(submit = submit, start = start, complete = complete),
    class = "execution_service"
  )
}

mod_specification_ui <- function(id) {
  ns <- shiny::NS(id)
  bslib::card(
    class = "assurance-panel",
    bslib::card_header("Confirm plot choices"),
    bslib::card_body(
      tags$details(
        class = "f001-panel",
        open = NA,
        tags$summary("Plot type"),
        tags$div(
          class = "f001-panel-body",
          tags$p("Longitudinal numeric BDS boxplot"),
          tags$p(
            class = "text-body-secondary",
            "This is the plot pattern supported by the current POC."
          )
        )
      ),
      tags$details(
        class = "f001-panel",
        open = NA,
        tags$summary("Variables and settings"),
        tags$div(
          class = "f001-panel-body",
          shiny::uiOutput(ns("summary")),
          shiny::tableOutput(ns("fields")),
          shiny::uiOutput(ns("controls")),
          shiny::uiOutput(ns("message"))
        )
      )
    )
  )
}

mod_specification_server <- function(
  id,
  current_revision,
  execute_revision = NULL,
  create_correction = NULL
) {
  shiny::moduleServer(id, function(input, output, session) {
    message <- shiny::reactiveVal(NULL)

    output$summary <- shiny::renderUI({
      state <- current_revision()
      if (is.null(state$spec)) {
        return(div(
          class = "text-body-secondary", "No confirmed specification yet."
        ))
      }
      if (!is.null(state$pending)) {
        return(div(
          class = "assurance-summary",
          tags$strong("Specification pending confirmation")
        ))
      }
      div(
        class = "assurance-summary",
        tags$strong("Specification hash"),
        tags$code(state$spec$hash)
      )
    })

    output$fields <- shiny::renderTable(
      {
        state <- current_revision()
        if (is.null(state$spec)) {
          return(data.frame())
        }
        fields <- state$spec$fields
        data.frame(
          field = names(fields),
          value = vapply(fields, .display_value, character(1)),
          provenance = vapply(names(fields), function(name) {
            state$spec$provenance[[name]] %||% ""
          }, character(1)),
          stringsAsFactors = FALSE
        )
      },
      striped = TRUE,
      bordered = FALSE,
      spacing = "s"
    )

    output$controls <- shiny::renderUI({
      state <- current_revision()
      read_only <- is.null(state$pending) && !.can_create_correction(state)
      choices <- .specification_choices(state)
      fields <- state$spec$fields
      treatment_variable <- input$treatment_variable %||%
        fields$treatment_variable %||% choices$treatment_variables[[1]]
      paramcd <- input$paramcd %||% fields$paramcd %||% choices$parameters[[1]]
      units <- choices$units[[paramcd]] %||% character()
      current_unit <- input$unit %||% fields$unit
      selected_unit <- if (
        length(current_unit) == 1L && current_unit %in% units
      ) {
        current_unit
      } else if (length(units) == 1L) {
        units[[1]]
      } else {
        character()
      }
      treatment_levels <- choices$treatment_levels[[treatment_variable]]
      current_treatment_levels <- input$treatment_levels %||%
        fields$treatment_levels
      selected_treatment_levels <- if (
        length(current_treatment_levels) &&
          all(current_treatment_levels %in% treatment_levels)
      ) {
        current_treatment_levels
      } else {
        treatment_levels
      }
      current_visits <- input$visits %||% fields$visits
      selected_visits <- if (
        length(current_visits) && all(current_visits %in% choices$visits)
      ) {
        current_visits
      } else {
        choices$visits
      }

      settings <- tagList(
        shiny::selectInput(
          session$ns("paramcd"), "Parameter", choices$parameters,
          selected = paramcd
        ),
        shiny::selectInput(
          session$ns("y_variable"),
          "Y variable",
          choices$y_variables,
          selected = fields$y_variable %||% choices$y_variables[[1]]
        ),
        shiny::selectInput(
          session$ns("unit"), "Unit", units,
          selected = selected_unit
        ),
        shiny::selectInput(
          session$ns("treatment_variable"),
          "Treatment facet",
          choices$treatment_variables,
          selected = treatment_variable
        ),
        shiny::checkboxGroupInput(
          session$ns("treatment_levels"),
          "Included treatment levels",
          treatment_levels,
          selected = selected_treatment_levels
        ),
        shiny::checkboxGroupInput(
          session$ns("visits"),
          "Included visits",
          choices$visits,
          selected = selected_visits
        ),
        shiny::radioButtons(
          session$ns("scale_mode"),
          "Y scales",
          choices = c("Fixed" = "fixed", "Free" = "free"),
          selected = fields$scale_mode %||% "fixed",
          inline = TRUE
        ),
        shiny::checkboxInput(
          session$ns("confirm_free_scale"),
          "I understand free Y scales create an Experimental/Draft revision",
          value = FALSE
        )
      )

      if (read_only) {
        return(tags$fieldset(
          disabled = TRUE,
          class = "specification-controls",
          tags$legend(class = "visually-hidden", "Confirmed plot settings"),
          settings
        ))
      }

      tags$div(
        class = "specification-controls",
        settings,
        if (.can_create_correction(state)) {
          tagList(
            shiny::textAreaInput(
              session$ns("correction_rationale"),
              "Correction rationale",
              rows = 2
            ),
            shiny::textInput(
              session$ns("correction_provenance"),
              "Correction provenance"
            ),
            .assurance_task_button(
              session$ns("correct"),
              "Create correction revision",
              class = "btn-primary"
            )
          )
        } else {
          .assurance_task_button(
            session$ns("execute"),
            "Confirm and generate",
            class = "btn-primary"
          )
        }
      )
    })

    output$message <- shiny::renderUI({
      text <- message()
      if (is.null(text)) {
        return(NULL)
      }
      div(class = "assurance-message", role = "status", text)
    })

    shiny::observeEvent(input$execute,
      {
        message(NULL)
        if (!is.function(execute_revision)) {
          message("Execution is unavailable in this context.")
          return()
        }
        if (
          identical(input$scale_mode, "free") &&
            !isTRUE(input$confirm_free_scale)
        ) {
          message("Free Y scales require confirmation before execution.")
          return()
        }
        tryCatch(
          execute_revision(
            .current_spec_input_fields(input, current_revision())
          ),
          error = function(error) {
            message(conditionMessage(error))
          }
        )
      },
      ignoreInit = TRUE
    )

    shiny::observeEvent(input$correct,
      {
        message(NULL)
        if (!is.function(create_correction)) {
          message("Correction is unavailable in this context.")
          return()
        }
        if (
          !checkmate::test_string(input$correction_rationale, min.chars = 1L) ||
            !checkmate::test_string(
              input$correction_provenance,
              min.chars = 1L
            )
        ) {
          message(
            "Enter the correction rationale and provenance before continuing."
          )
          return()
        }
        if (
          identical(input$scale_mode, "free") &&
            !isTRUE(input$confirm_free_scale)
        ) {
          message("Free Y scales require confirmation before correction.")
          return()
        }
        tryCatch(
          create_correction(
            .current_spec_input_fields(input, current_revision()),
            input$correction_rationale,
            input$correction_provenance
          ),
          error = function(error) {
            message(conditionMessage(error))
          }
        )
      },
      ignoreInit = TRUE
    )
  })
}

.current_spec_input_fields <- function(input, state) {
  choices <- .specification_choices(state)
  fields <- state$spec$fields
  treatment_variable <- input$treatment_variable %||%
    fields$treatment_variable %||% choices$treatment_variables[[1]]
  paramcd <- input$paramcd %||% fields$paramcd %||% choices$parameters[[1]]
  units <- choices$units[[paramcd]] %||% character()
  unit <- input$unit %||% fields$unit %||% if (length(units) == 1L) {
    units[[1]]
  } else {
    NULL
  }
  treatment_levels <- input$treatment_levels %||%
    fields$treatment_levels %||% choices$treatment_levels[[treatment_variable]]
  visits <- input$visits %||% fields$visits %||% choices$visits

  list(
    paramcd = paramcd,
    y_variable = input$y_variable %||% fields$y_variable %||%
      choices$y_variables[[1]],
    unit = unit,
    treatment_variable = treatment_variable,
    treatment_levels = treatment_levels,
    visits = visits,
    scale_mode = input$scale_mode %||% fields$scale_mode %||% "fixed"
  )
}

.specification_choices <- function(state) {
  choices <- state$pending$choices %||% state$choices
  if (is.null(choices)) {
    cli::cli_abort("Specification choices are unavailable")
  }
  choices
}

.can_create_correction <- function(state) {
  !is.null(state$revision) &&
    state$revision$status %in% c("Rejected", "Reviewed") &&
    !is.null(state$choices)
}

.display_value <- function(value) {
  if (is.null(value)) {
    return("")
  }
  paste(as.character(value), collapse = ", ")
}

new_actor <- function(id, roles, active = TRUE) {
  if (!checkmate::test_string(id, min.chars = 1) ||
    !checkmate::test_character(
      roles,
      min.len = 1L,
      any.missing = FALSE
    ) ||
    !checkmate::test_flag(active)) {
    cli::cli_abort(paste0(
      "An actor requires an identifier, at least one role, ",
      "and an active flag"
    ))
  }
  structure(
    list(id = id, roles = unique(roles), active = active),
    class = "submission_sync_actor"
  )
}

authorize_revision_action <- function(actor, revision, action) {
  if (!inherits(actor, "submission_sync_actor") ||
    !inherits(revision, "plot_revision")) {
    cli::cli_abort("Authorization requires an actor and plot revision")
  }
  if (!actor$active) {
    cli::cli_abort("The current actor is not active")
  }
  if (action %in% c("approve", "reject") &&
    identical(actor$id, revision$creator_id)) {
    cli::cli_abort("A revision creator cannot review their own revision")
  }
  if (action == "approve" &&
    !any(actor$roles %in% c("statistical_programmer", "biostatistician"))) {
    cli::cli_abort("The current actor is not eligible to approve a revision")
  }
  invisible(TRUE)
}

#' Calculate a stable content hash for study data
#'
#' The hash is independent of row order while preserving column names, types,
#' missing values, and stored values.
#'
#' @param data A data frame containing a study-data snapshot.
#'
#' @return A SHA-256 content hash.
#' @export
study_data_content_hash <- function(data) {
  if (!checkmate::test_data_frame(data, min.rows = 1L, min.cols = 1L)) {
    cli::cli_abort("{.arg data} must be a non-empty data frame")
  }

  normalized <- .normalize_study_data(data)
  payload <- lapply(normalized, function(column) {
    list(type = typeof(column), class = class(column), values = unname(column))
  })
  canonical_hash(list(columns = names(normalized), data = payload))
}

.normalize_study_data <- function(data) {
  data <- data[, sort(names(data), method = "radix"), drop = FALSE]
  row_keys <- do.call(
    paste,
    c(lapply(data, .stable_column_text), sep = "\u001f")
  )
  result <- data[
    order(row_keys, method = "radix", na.last = TRUE), ,
    drop = FALSE
  ]
  row.names(result) <- NULL
  result
}

.stable_column_text <- function(x) {
  if (inherits(x, "POSIXt")) {
    value <- format(x, "%Y-%m-%dT%H:%M:%OS6Z", tz = "UTC")
  } else if (inherits(x, "Date")) {
    value <- format(x, "%Y-%m-%d")
  } else if (is.numeric(x)) {
    value <- ifelse(is.na(x), NA_character_, sprintf("%.17g", x))
  } else {
    value <- enc2utf8(as.character(x))
  }
  paste0(typeof(x), ":", ifelse(is.na(value), "<NA>", value))
}

.validate_study_data_provider <- function(provider) {
  if (!inherits(provider, "study_data_provider")) {
    cli::cli_abort("{.arg provider} must be a {.cls study_data_provider}")
  }
  invisible(provider)
}

#' List datasets authorized by a study-data provider
#'
#' @param provider A study-data provider.
#'
#' @return A deterministic data frame of authorized, non-patient metadata.
#' @export
list_study_catalog <- function(provider) {
  .validate_study_data_provider(provider)
  scenarios <- provider$manifest$scenarios
  catalog <- data.frame(
    dataset_id = vapply(scenarios, `[[`, "", "dataset_id"),
    classification = vapply(
      scenarios,
      function(scenario) scenario$classification %||% NA_character_,
      ""
    ),
    adam_designation = vapply(scenarios, `[[`, "", "adam_designation"),
    metadata_version = vapply(scenarios, `[[`, "", "metadata_version"),
    content_hash = vapply(scenarios, `[[`, "", "content_hash"),
    snapshot_id = vapply(scenarios, `[[`, "", "snapshot_id"),
    scenario_id = vapply(scenarios, `[[`, "", "scenario_id"),
    purpose = vapply(scenarios, `[[`, "", "purpose"),
    expected_behavior = vapply(scenarios, `[[`, "", "expected_behavior"),
    stringsAsFactors = FALSE
  )
  catalog$declared_keys <- I(lapply(scenarios, `[[`, "declared_keys"))
  catalog$permitted_treatment_variables <- I(lapply(
    scenarios,
    `[[`,
    "permitted_treatment_variables"
  ))
  catalog <- catalog[, c(
    "dataset_id", "classification", "adam_designation", "declared_keys",
    "metadata_version", "content_hash", "permitted_treatment_variables",
    "snapshot_id", "scenario_id", "purpose", "expected_behavior"
  )]
  catalog <- catalog[
    order(catalog$dataset_id, method = "radix"), ,
    drop = FALSE
  ]
  row.names(catalog) <- NULL
  catalog
}

#' Pin an authorized immutable study-data snapshot
#'
#' @param provider A study-data provider.
#' @param dataset_id One opaque dataset identifier from the authorized catalog.
#'
#' @return A hash-verified `study_data_snapshot`.
#' @export
pin_study_snapshot <- function(provider, dataset_id) {
  .validate_study_data_provider(provider)
  if (!checkmate::test_string(dataset_id, min.chars = 1L)) {
    cli::cli_abort("{.arg dataset_id} must be one non-empty identifier")
  }

  matches <- which(vapply(
    provider$manifest$scenarios,
    function(x) identical(x$dataset_id, dataset_id),
    logical(1)
  ))
  if (length(matches) != 1L) {
    cli::cli_abort(
      "{.val {dataset_id}} is not present in the authorized catalog"
    )
  }
  metadata <- provider$manifest$scenarios[[matches]]
  data <- provider$read_data(metadata)
  observed_hash <- study_data_content_hash(data)
  if (!identical(observed_hash, metadata$content_hash)) {
    cli::cli_abort(
      "The authorized snapshot content hash does not match its catalog entry"
    )
  }

  snapshot <- list(
    snapshot_contract_version = "study-snapshot-v1",
    snapshot_id = metadata$snapshot_id,
    dataset_id = metadata$dataset_id,
    adam_designation = metadata$adam_designation,
    declared_keys = unlist(metadata$declared_keys, use.names = FALSE),
    metadata_version = metadata$metadata_version,
    content_hash = metadata$content_hash,
    permitted_treatment_variables = unlist(
      metadata$permitted_treatment_variables,
      use.names = FALSE
    ),
    data = .normalize_study_data(data)
  )
  if (!is.null(metadata$classification)) {
    snapshot$classification <- metadata$classification
  }
  structure(snapshot, class = "study_data_snapshot")
}

.base_synthetic_bds <- function() {
  data.frame(
    STUDYID = "SYNTH001",
    USUBJID = rep(sprintf("SYNTH001-%03d", 1:6), each = 3L),
    PARAMCD = "ALT",
    PARAM = "Alanine aminotransferase",
    AVISIT = rep(c("Baseline", "Week 4", "Week 8"), times = 6L),
    AVISITN = rep(c(0, 4, 8), times = 6L),
    AVAL = c(
      20, 24, 26, 22, 25, 28, 24, 27, 30,
      26, 29, 32, 28, NA, 34, 30, NA, 36
    ),
    CHG = c(
      0, 4, 6, 0, 3, 6, 0, 3, 6,
      0, 3, 6, 0, NA, 6, 0, NA, 6
    ),
    PCHG = c(
      0, 20, 30, 0, 13.6363636364, 27.2727272727,
      0, 12.5, 25, 0, 11.5384615385, 23.0769230769,
      0, NA, 21.4285714286, 0, NA, 20
    ),
    AVALU = "U/L",
    TRT01A = rep(c("Placebo", "Active"), each = 9L),
    ANL01FL = rep(c("Y", "N"), 9L),
    stringsAsFactors = FALSE
  )
}

.synthetic_scenario_data <- function() {
  standard <- .base_synthetic_bds()

  multiple_units <- standard
  multiple_units$AVALU[multiple_units$USUBJID == "SYNTH001-006"] <- "ukat/L"

  duplicate_keys <- standard
  duplicate_keys <- rbind(
    duplicate_keys,
    transform(
      duplicate_keys[
        duplicate_keys$USUBJID == "SYNTH001-001" &
          duplicate_keys$AVISIT == "Week 4",
      ],
      AVAL = 999
    )
  )

  sparse_missing <- standard
  sparse_missing$AVAL[
    sparse_missing$AVISIT == "Week 4" &
      sparse_missing$USUBJID %in% c("SYNTH001-005", "SYNTH001-006")
  ] <- NA_real_

  empty_combination <- standard
  empty_combination$AVAL[
    empty_combination$TRT01A == "Active" & empty_combination$AVISIT == "Week 4"
  ] <- NA_real_

  bad_visit_mapping <- standard
  bad_visit_mapping$AVISITN[
    bad_visit_mapping$USUBJID == "SYNTH001-001" &
      bad_visit_mapping$AVISIT == "Week 4"
  ] <- 5

  empty_treatment <- standard
  empty_treatment$AVAL[empty_treatment$TRT01A == "Placebo"] <- NA_real_

  extra_timepoint_keys <- standard
  extra_timepoint_keys$ATPTN <- 1L
  repeated <- extra_timepoint_keys[
    extra_timepoint_keys$USUBJID == "SYNTH001-001" &
      extra_timepoint_keys$AVISIT == "Week 4",
  ]
  repeated$ATPTN <- 2L
  extra_timepoint_keys <- rbind(extra_timepoint_keys, repeated)

  identifier_canary <- standard
  canary <- identifier_canary[
    identifier_canary$USUBJID == "SYNTH001-001" &
      identifier_canary$AVISIT == "Week 4",
  ]
  canary$USUBJID <- "SYNTH-CANARY-DO-NOT-RETAIN"
  identifier_canary <- rbind(
    identifier_canary, canary, transform(canary, AVAL = 999)
  )

  exclusions <- standard
  exclusions <- rbind(
    exclusions,
    exclusions[
      exclusions$USUBJID == "SYNTH001-001" & exclusions$AVISIT == "Week 8",
    ]
  )

  list(
    standard = standard,
    `multiple-units` = multiple_units,
    `duplicate-keys` = duplicate_keys,
    `sparse-missing` = sparse_missing,
    `empty-combination` = empty_combination,
    `bad-visit-mapping` = bad_visit_mapping,
    `empty-treatment` = empty_treatment,
    `extra-timepoint-keys` = extra_timepoint_keys,
    `identifier-canary` = identifier_canary,
    exclusions = exclusions
  )
}

.synthetic_scenario_purpose <- c(
  standard = "Passing visit-based numeric BDS profile",
  `multiple-units` = "Unresolved multiple-unit selection",
  `duplicate-keys` = "Unsupported duplicate subject-parameter-visit key",
  `sparse-missing` = "Six source subjects and four non-missing selected values",
  `empty-combination` = "No display data for one treatment-visit combination",
  `bad-visit-mapping` = "Conflicting AVISIT to AVISITN mapping",
  `empty-treatment` = paste(
    "Included treatment level with all selected", "Y values missing"
  ),
  `extra-timepoint-keys` = paste(
    "Legitimate additional timepoint key outside", "the cell profile"
  ),
  `identifier-canary` = "Authorization-scoped duplicate identifier canary",
  exclusions = "Explicit selections remove an otherwise blocking duplicate"
)

.synthetic_expected_behavior <- c(
  standard = "passes",
  `multiple-units` = "blocks:unit_selection_required",
  `duplicate-keys` = "blocks:unsupported_duplicate_visit_key",
  `sparse-missing` = "warns:low_sample_size",
  `empty-combination` = "warns:empty_treatment_visit",
  `bad-visit-mapping` = "blocks:invalid_visit_mapping",
  `empty-treatment` = "warns:empty_treatment_level",
  `extra-timepoint-keys` = "blocks:unsupported_additional_timepoint_keys",
  `identifier-canary` = "blocks:unsupported_duplicate_visit_key",
  exclusions = "passes:explicit_exclusions_precede_key_check"
)

.synthetic_declared_keys <- function(scenario_id) {
  keys <- c("STUDYID", "USUBJID", "PARAMCD", "AVISITN")
  if (identical(scenario_id, "extra-timepoint-keys")) c(keys, "ATPTN") else keys
}

.build_synthetic_manifest <- function(scenarios) {
  entries <- lapply(names(scenarios), function(scenario_id) {
    list(
      scenario_id = scenario_id,
      dataset_id = paste0("adlb-", scenario_id),
      snapshot_id = paste0("synthetic-adlb-", scenario_id, "-v1"),
      file = paste0("adlb-", scenario_id, ".rds"),
      purpose = unname(.synthetic_scenario_purpose[[scenario_id]]),
      expected_behavior = unname(.synthetic_expected_behavior[[scenario_id]]),
      generator_version = "synthetic-bds-generator-v1",
      seed = 20260906,
      classification = "synthetic",
      adam_designation = "BDS",
      declared_keys = .synthetic_declared_keys(scenario_id),
      metadata_version = "synthetic-adlb-metadata-v1",
      permitted_treatment_variables = "TRT01A",
      content_hash = study_data_content_hash(scenarios[[scenario_id]])
    )
  })
  list(
    manifest_version = "synthetic-bds-manifest-v1",
    generator_version = "synthetic-bds-generator-v1",
    classification = "synthetic",
    clinical_evidence_use = FALSE,
    scenarios = entries
  )
}

.validate_synthetic_manifest <- function(manifest) {
  required_top <- c(
    "manifest_version", "generator_version", "classification",
    "clinical_evidence_use", "scenarios"
  )
  required_scenario <- c(
    "scenario_id", "dataset_id", "snapshot_id", "file", "purpose",
    "expected_behavior", "generator_version", "seed", "classification",
    "adam_designation", "declared_keys", "metadata_version",
    "permitted_treatment_variables", "content_hash"
  )
  valid <- is.list(manifest) && all(required_top %in% names(manifest)) &&
    identical(manifest$manifest_version, "synthetic-bds-manifest-v1") &&
    identical(manifest$classification, "synthetic") &&
    identical(manifest$clinical_evidence_use, FALSE) &&
    is.list(manifest$scenarios) && length(manifest$scenarios) > 0L &&
    all(vapply(manifest$scenarios, function(x) {
      all(required_scenario %in% names(x)) &&
        identical(x$classification, "synthetic") &&
        identical(x$adam_designation, "BDS") &&
        identical(x$generator_version, manifest$generator_version) &&
        all(vapply(
          x[c(
            "scenario_id", "dataset_id", "snapshot_id", "file", "purpose",
            "expected_behavior", "metadata_version", "content_hash"
          )],
          checkmate::test_string,
          logical(1),
          min.chars = 1L
        )) &&
        checkmate::test_string(x$file, pattern = "^adlb-[a-z0-9-]+\\.rds$") &&
        checkmate::test_string(x$content_hash, pattern = "^[a-f0-9]{64}$") &&
        checkmate::test_number(x$seed, finite = TRUE) &&
        checkmate::test_character(
          unlist(x$declared_keys, use.names = FALSE),
          min.len = 3L,
          any.missing = FALSE,
          unique = TRUE
        ) &&
        all(c("USUBJID", "PARAMCD", "AVISITN") %in%
          unlist(x$declared_keys, use.names = FALSE)) &&
        checkmate::test_character(
          unlist(x$permitted_treatment_variables, use.names = FALSE),
          min.len = 1L,
          any.missing = FALSE,
          unique = TRUE
        )
    }, logical(1)))
  if (valid) {
    identifiers <- lapply(
      c("scenario_id", "dataset_id", "snapshot_id", "file"),
      function(field) vapply(manifest$scenarios, `[[`, "", field)
    )
    valid <- all(vapply(identifiers, function(x) !anyDuplicated(x), logical(1)))
  }
  if (!valid) {
    cli::cli_abort("The governed synthetic scenario manifest is invalid")
  }
  invisible(manifest)
}

#' Read the governed synthetic scenario manifest
#'
#' @param root Governed synthetic-data directory.
#'
#' @return The validated versioned manifest.
#' @export
synthetic_scenario_manifest <- function(root = .synthetic_data_root()) {
  manifest <- jsonlite::read_json(
    file.path(root, "scenario-manifest.json"),
    simplifyVector = FALSE
  )
  .validate_synthetic_manifest(manifest)
  manifest
}

#' Load a governed synthetic BDS scenario
#'
#' @param scenario_id Scenario identifier from [synthetic_scenario_manifest()].
#' @param root Governed synthetic-data directory.
#'
#' @return A hash-verified synthetic BDS data frame.
#' @export
load_synthetic_scenario <- function(
  scenario_id, root = .synthetic_data_root()
) {
  if (!checkmate::test_string(scenario_id, min.chars = 1L)) {
    cli::cli_abort("{.arg scenario_id} must be one non-empty identifier")
  }
  manifest <- synthetic_scenario_manifest(root)
  matches <- which(vapply(
    manifest$scenarios,
    function(x) identical(x$scenario_id, scenario_id),
    logical(1)
  ))
  if (length(matches) != 1L) {
    cli::cli_abort("{.val {scenario_id}} is not a governed synthetic scenario")
  }
  metadata <- manifest$scenarios[[matches]]
  data <- readRDS(file.path(root, metadata$file))
  if (!identical(study_data_content_hash(data), metadata$content_hash)) {
    cli::cli_abort(
      "The synthetic scenario content hash does not match its manifest"
    )
  }
  data
}

.write_synthetic_scenarios <- function(root = .synthetic_data_root()) {
  dir.create(root, recursive = TRUE, showWarnings = FALSE)
  scenarios <- .synthetic_scenario_data()
  manifest <- .build_synthetic_manifest(scenarios)
  for (scenario in manifest$scenarios) {
    saveRDS(
      scenarios[[scenario$scenario_id]],
      file.path(root, scenario$file),
      version = 3,
      compress = "xz"
    )
  }
  jsonlite::write_json(
    manifest,
    file.path(root, "scenario-manifest.json"),
    auto_unbox = TRUE,
    pretty = TRUE,
    null = "null",
    digits = NA
  )
  invisible(manifest)
}

.prompt_context_blocked_terms <- c(
  "USUBJID", "patient", "secret", "credential", "workspace", "path", "url",
  "file", "directory", "comment", "diagnostic"
)

new_prompt_context <- function(
  dataset_id, labels = list(), aggregate_profile = list()
) {
  if (!checkmate::test_string(dataset_id, min.chars = 1) ||
    !checkmate::test_list(labels) ||
    !checkmate::test_list(aggregate_profile)) {
    cli::cli_abort(
      "Prompt context requires an opaque dataset identifier and list inputs"
    )
  }
  if (!.assert_prompt_context_content(list(
    labels = labels, aggregate_profile = aggregate_profile
  ))) {
    cli::cli_abort("Prompt context contains prohibited content")
  }
  payload <- list(
    version = "prompt-context-v1",
    dataset_id = dataset_id,
    labels = labels,
    aggregate_profile = aggregate_profile
  )
  payload$hash <- canonical_hash(payload)
  structure(payload, class = "prompt_context")
}

.assert_prompt_context_content <- function(value) {
  content <- paste(unlist(value, use.names = TRUE), collapse = " ")
  pattern <- paste(
    c(.prompt_context_blocked_terms, "https?://"),
    collapse = "|"
  )
  if (grepl(pattern, content, ignore.case = TRUE)) {
    return(FALSE)
  }
  TRUE
}

.validate_prompt_context <- function(context) {
  if (!inherits(context, "prompt_context")) {
    cli::cli_abort("{.arg context} must be a {.cls prompt_context}")
  }
  invisible(context)
}

.validate_prompt_interpreter <- function(interpreter) {
  if (!inherits(interpreter, "prompt_interpreter")) {
    cli::cli_abort("{.arg interpreter} must be a {.cls prompt_interpreter}")
  }
  invisible(interpreter)
}

#' Interpret a prompt through a provider-neutral adapter
#'
#' @param prompt One natural-language request.
#' @param context A `prompt_context`.
#' @param interpreter A prompt interpreter, such as `mock_prompt_interpreter()`.
#' @param snapshot Optional pinned snapshot used for U3 semantic validation.
#'
#' @return A `prompt_interpretation` with status, candidate, choices, and
#'   provider metadata. It never includes executable code.
#' @export
interpret_prompt <- function(prompt, context, interpreter, snapshot = NULL) {
  if (!checkmate::test_string(prompt, min.chars = 1L)) {
    cli::cli_abort("{.arg prompt} must be one non-empty string")
  }
  .validate_prompt_context(context)
  .validate_prompt_interpreter(interpreter)

  blocked <- .detect_blocked_prompt(prompt)
  if (!is.null(blocked)) {
    return(.prompt_interpretation(
      status = "manual_selection",
      candidate = NULL,
      clarifications = list(reason = blocked),
      metadata = list(provider = interpreter$provider, provider_called = FALSE)
    ))
  }

  raw <- interpreter$interpret(prompt = prompt, context = context)
  result <- .normalize_provider_result(raw, context, interpreter)
  if (identical(result$status, "candidate") && !is.null(snapshot)) {
    .validate_prompt_candidate(result$candidate, snapshot)
  }
  result
}

.detect_blocked_prompt <- function(prompt) {
  checks <- c(
    arbitrary_r_deferred = paste(
      "\\b(run|write|execute|compile)\\b.*\\b(r|code|script)\\b",
      paste0(
        "\\b(log[- ]?transform|transform|derive|calculate|compute|mutate|",
        "normaliz\\w*|standardiz\\w*)\\b"
      ),
      "\\b(AVAL|CHG|PCHG)\\b\\s*[-+*/^]",
      "[-+*/^]\\s*\\b(AVAL|CHG|PCHG)\\b",
      "library\\s*\\(|ggplot\\s*\\(|system\\s*\\(",
      sep = "|"
    ),
    prompt_injection = paste(
      "ignore (all )?(previous|system)|developer message|tool instruction"
    ),
    path_or_url = "https?://|[A-Za-z]:[\\\\/]|\\\\\\\\|\\.rds\\b|\\.csv\\b",
    sensitive_content = "USUBJID|patient|secret|credential|workspace"
  )
  matched <- names(checks)[vapply(
    checks, grepl, logical(1),
    x = prompt, ignore.case = TRUE
  )]
  if (length(matched)) matched[[1]] else NULL
}

.normalize_provider_result <- function(raw, context, interpreter) {
  allowed <- c(
    "status", "fields", "clarifications", "required_confirmations", "metadata"
  )
  extras <- setdiff(names(raw), allowed)
  if (length(extras)) {
    return(.prompt_interpretation(
      status = "manual_selection",
      candidate = NULL,
      clarifications = list(reason = "extra_provider_fields"),
      metadata = list(provider = interpreter$provider, provider_called = TRUE)
    ))
  }
  if (!checkmate::test_choice(
    raw$status, c("candidate", "clarification", "manual_selection")
  )) {
    return(.prompt_interpretation(
      status = "manual_selection",
      candidate = NULL,
      clarifications = list(reason = "malformed_provider_response"),
      metadata = list(provider = interpreter$provider, provider_called = TRUE)
    ))
  }
  if (!identical(raw$status, "candidate")) {
    return(.prompt_interpretation(
      status = raw$status,
      candidate = NULL,
      clarifications = raw$clarifications %||% list(reason = raw$status),
      metadata = c(
        list(provider = interpreter$provider, provider_called = TRUE),
        raw$metadata %||% list()
      )
    ))
  }

  fields <- raw$fields
  field_extras <- setdiff(names(fields), .plot_spec_fields)
  if (length(field_extras)) {
    return(.prompt_interpretation(
      status = "manual_selection",
      candidate = NULL,
      clarifications = list(reason = "extra_candidate_fields"),
      metadata = list(provider = interpreter$provider, provider_called = TRUE)
    ))
  }
  candidate <- new_plot_spec(
    dataset_id = context$dataset_id,
    paramcd = fields$paramcd %||% NULL,
    y_variable = fields$y_variable %||% NULL,
    unit = fields$unit %||% NULL,
    treatment_variable = fields$treatment_variable %||% NULL,
    treatment_levels = fields$treatment_levels %||% NULL,
    visits = fields$visits %||% NULL,
    scale_mode = fields$scale_mode %||% "fixed",
    provenance = .candidate_provenance(fields),
    state = "candidate"
  )
  clarifications <- plot_spec_clarifications(candidate)
  status <- if (
    length(clarifications) || length(raw$required_confirmations %||% list())
  ) {
    "clarification"
  } else {
    "candidate"
  }
  .prompt_interpretation(
    status = status,
    candidate = candidate,
    clarifications = list(
      missing_fields = clarifications,
      required_confirmations = raw$required_confirmations %||% list()
    ),
    metadata = c(
      list(
        provider = interpreter$provider,
        model = interpreter$model,
        provider_called = TRUE,
        interpreter_version = "prompt-interpreter-v1",
        schema_version = "plot-spec-v1",
        response_retention = "none"
      ),
      raw$metadata %||% list()
    )
  )
}

.candidate_provenance <- function(fields) {
  provenance <- rep("prompt", length(fields))
  names(provenance) <- names(fields)
  provenance <- as.list(provenance)
  provenance$dataset_id <- "metadata"
  if (is.null(fields$scale_mode)) provenance$scale_mode <- "default"
  provenance
}

.validate_prompt_candidate <- function(candidate, snapshot) {
  selections <- candidate$fields[
    setdiff(.plot_spec_fields, c("dataset_id", "scale_mode"))
  ]
  result <- validate_bds_profile(snapshot, selections)
  if (result$blocked) {
    cli::cli_abort(
      "The interpreted candidate does not satisfy the supported BDS profile"
    )
  }
  invisible(candidate)
}

.prompt_interpretation <- function(
  status, candidate, clarifications, metadata
) {
  structure(
    list(
      version = "prompt-interpretation-v1",
      status = status,
      candidate = candidate,
      clarifications = clarifications,
      metadata = metadata,
      executable_code = NULL
    ),
    class = "prompt_interpretation"
  )
}

`%||%` <- function(x, y) {
  if (is.null(x)) y else x
}

#' Create a deterministic prompt interpreter for tests and local development
#'
#' @return A provider-neutral `prompt_interpreter`.
#' @export
mock_prompt_interpreter <- function() {
  structure(
    list(
      port = new_provider_port(
        "prompt_interpreter", c("structured_candidate", "clarification")
      ),
      provider = "deterministic-mock",
      model = "mock-rule-set-v1",
      interpret = .mock_interpret_prompt
    ),
    class = "prompt_interpreter"
  )
}

.mock_interpret_prompt <- function(prompt, context) {
  profile <- context$aggregate_profile
  parameters <- profile$parameters
  paramcd <- .mock_match_parameter(prompt, parameters)
  if (is.null(paramcd)) {
    return(list(
      status = "clarification",
      clarifications = list(field = "paramcd", choices = names(parameters))
    ))
  }
  units <- parameters[[paramcd]]$units
  unit <- .mock_match_value(prompt, units)
  if (is.null(unit) && length(units) == 1L) unit <- units[[1]]

  treatment_variable <- profile$treatment_variables[[1]]
  treatment_levels <- profile$treatment_levels[[treatment_variable]]
  included_treatment_levels <- .mock_exclude_values(prompt, treatment_levels)
  visits <- vapply(profile$visits, `[[`, "", "label")
  included_visits <- .mock_exclude_values(prompt, visits)
  scale_mode <- if (grepl(
    "free[- ]?scale|free y|separate scale", prompt,
    ignore.case = TRUE
  )) {
    "free"
  } else {
    "fixed"
  }
  required_confirmations <- if (identical(scale_mode, "free")) {
    list(scale_mode = "Free scales create an Experimental/Draft candidate")
  } else {
    list()
  }
  clarifications <- if (length(units) > 1L && is.null(unit)) {
    list(field = "unit", choices = units)
  } else {
    list()
  }

  list(
    status = "candidate",
    fields = list(
      paramcd = paramcd,
      y_variable = .mock_y_variable(prompt, profile$y_variables),
      unit = unit,
      treatment_variable = treatment_variable,
      treatment_levels = included_treatment_levels,
      visits = included_visits,
      scale_mode = scale_mode
    ),
    clarifications = clarifications,
    required_confirmations = required_confirmations,
    metadata = list(prompt_template = "mock-prompt-template-v1")
  )
}

.mock_match_parameter <- function(prompt, parameters) {
  matches <- names(parameters)[vapply(names(parameters), function(paramcd) {
    grepl(paste0("\\b", paramcd, "\\b"), prompt, ignore.case = TRUE) ||
      grepl(tolower(parameters[[paramcd]]$label), tolower(prompt), fixed = TRUE)
  }, logical(1))]
  if (length(matches) == 1L) matches[[1]] else NULL
}

.mock_match_value <- function(prompt, values) {
  matches <- values[vapply(
    tolower(values), grepl, logical(1),
    x = tolower(prompt), fixed = TRUE
  )]
  if (length(matches) == 1L) matches[[1]] else NULL
}

.mock_y_variable <- function(prompt, choices) {
  if ("PCHG" %in% choices && grepl(
    "percent|percentage|pct|PCHG", prompt,
    ignore.case = TRUE
  )) {
    return("PCHG")
  }
  if ("CHG" %in% choices && grepl("change|CHG", prompt, ignore.case = TRUE)) {
    return("CHG")
  }
  "AVAL"
}

.mock_exclude_values <- function(prompt, values) {
  kept <- values
  for (value in values) {
    pattern <- paste0(
      "\\b(exclude|without|omit)\\b[^.]*\\b",
      gsub(" ", "\\\\s+", value), "\\b"
    )
    if (grepl(pattern, prompt, ignore.case = TRUE)) {
      kept <- setdiff(kept, value)
    }
  }
  kept
}

mod_plot_generation_ui <- function(id) {
  ns <- shiny::NS(id)
  tags <- shiny::tags

  tags$div(
    tags$style(shiny::HTML(paste(c(
      ".f001-screen { position: relative; min-width: 0;",
      "min-height: 385px; border: 1px solid #aebbc5;",
      "border-radius: .5rem; background: white; overflow: hidden; }",
      ".f001-appbar { height: 45px; padding: .5rem .75rem;",
      "border-bottom: 1px solid #c7d1d9; display: flex;",
      "align-items: center; justify-content: space-between;",
      "background: white; }",
      ".f001-brand { font-weight: 700; }",
      ".f001-stepmark { color: #344754; font-size: .78rem; }",
      ".f001-step-status { color: #344754; font-size: .78rem; }",
      ".f001-workbench { position: relative; padding: 12px 14px 13px 40px; }",
      ".f001-steps { display: grid; grid-template-columns: repeat(5, 1fr);",
      "gap: 5px; margin-bottom: 11px; }",
      ".f001-stepmark { padding: 6px 5px; border: 1px solid #c7d1d9;",
      "border-radius: 4px; background: #f7f9fa; text-align: center;",
      "color: #52616d; font-size: .75rem; }",
      ".f001-stepmark.current { border-color: #7492a6;",
      "background: #edf4f8; color: #173f59; font-weight: 700; }",
      ".f001-stepmark.done { color: #245b46; }",
      ".f001-data-drawer { position: static; }",
      ".f001-data-drawer > summary { position: absolute; z-index: 5;",
      "top: 57px; left: 0; display: flex; flex-direction: column;",
      "width: 28px; height: 148px; padding: 9px 5px;",
      "align-items: center; justify-content: space-between;",
      "border: 1px solid #8fa2b0; border-left: 0;",
      "border-radius: 0 6px 6px 0; background: white; color: #1c4259;",
      "cursor: pointer; list-style: none; box-shadow: 1px 2px 5px #18293612; }",
      ".f001-data-drawer > summary::-webkit-details-marker,",
      ".f001-panel > summary::-webkit-details-marker { display: none; }",
      ".f001-trigger-label { writing-mode: vertical-rl;",
      "transform: rotate(180deg); font-size: .75rem; font-weight: 650;",
      "white-space: nowrap; }",
      ".f001-drawer-grip { color: #688091; font-size: 1rem; line-height: 1;",
      "letter-spacing: -2px; }",
      ".f001-data-drawer[open] > summary { left: 250px;",
      "border-left: 1px solid #8fa2b0; border-radius: 6px 0 0 6px;",
      "background: #edf3f6; box-shadow: none; }",
      ".f001-drawer-body { position: absolute; z-index: 4; top: 45px;",
      "bottom: 0; left: 0; width: 250px; padding: 15px 14px;",
      "border-right: 1px solid #8fa2b0; background: white;",
      "box-shadow: 4px 0 14px #18293616; }",
      ".f001-drawer-body h3 { margin: 0 0 3px; font-size: 1rem; }",
      ".f001-drawer-body p { margin: 0 0 12px; color: #52616d;",
      "font-size: .82rem; }",
      ".f001-drawer-section { padding: 10px 0;",
      "border-top: 1px solid #e0e6ea; }",
      ".f001-drawer-section b { display: block; }",
      ".f001-drawer-tag { display: inline-block; padding: 2px 7px;",
      "border: 1px solid #a6b6c0; border-radius: 12px;",
      "background: #f4f7f8; color: #334b5a; font-size: .72rem; }",
      ".f001-screen h2 { margin: 0; font-size: 1.05rem; }",
      ".f001-panel { margin-bottom: 8px; border: 1px solid #c7d1d9;",
      "border-radius: 5px; background: white; }",
      ".f001-panel > summary { display: flex; align-items: center;",
      "justify-content: space-between; padding: .5rem .65rem;",
      "cursor: pointer; font-weight: 650; list-style: none; }",
      ".f001-panel > summary::after { content: '+'; color: #31556b;",
      "font-weight: 500; }",
      ".f001-panel[open] > summary::after { content: '\\2212'; }",
      ".f001-panel-body { padding: 0 .65rem .65rem; }",
      ".f001-caption { margin-top: .75rem; color: #52616d;",
      "font-size: .9rem; }",
      ".f001-page-title { display: flex; align-items: center;",
      "justify-content: space-between; gap: .75rem; margin: 0 0 8px; }",
      ".f001-page-title > span { color: #52616d; font-size: .78rem; }",
      ".f001-required { display: inline-block; margin-left: 5px;",
      "padding: 1px 5px; border: 1px solid #e1c38a; border-radius: 3px;",
      "background: #fff4df; color: #6d4400; font-size: .7rem;",
      "font-weight: 700; }",
      ".f001-drop { margin-top: 8px; padding: 13px 10px;",
      "border: 1px dashed #91a1ac; border-radius: 4px;",
      "background: #fbfcfd; }",
      ".f001-drop .shiny-input-container { width: 100%; margin: 0; }",
      ".f001-drop .form-group { margin: 0; }",
      ".f001-drop input[type=file] { width: 100%; }",
      ".f001-drop-caption { color: #52616d; font-size: .8rem; }",
      ".f001-upload-status { margin-top: .5rem; font-size: .82rem; }",
      ".f001-footer-action { display: flex; align-items: center;",
      "justify-content: space-between; gap: .75rem; margin-top: 9px; }",
      ".f001-footer-action > span { font-size: .8rem; }",
      ".f001-footer-action .btn { margin: 0; }",
      ".f001-review-info { width: 1.5rem; height: 1.5rem;",
      "margin-left: .35rem; border: 1px solid #96a8b3; border-radius: 50%;",
      "background: white; color: #23485f; }",
      ".f001-result-content { position: relative; }",
      ".f001-screen-caption { padding: 7px 12px 8px 40px;",
      "border-top: 1px solid #e3e8eb; background: #fafbfc;",
      "color: #50606a; font-size: .78rem; }",
      "@media (max-width: 575.98px) {",
      ".f001-workbench { padding-right: 10px; }",
      ".f001-stepmark { padding: .35rem .1rem; font-size: .75rem; }",
      "}"
    ), collapse = "\n"))),
    tags$div(
      class = "f001-screen",
      tags$div(
        class = "f001-appbar",
        tags$span(class = "f001-brand", "Create plot"),
        shiny::uiOutput(ns("step_mark"))
      ),
      tags$div(
        style = "display: none;",
        shiny::textInput(ns("step_signal"), NULL, value = "data")
      ),
      tags$details(
        id = ns("data_drawer"),
        class = "f001-data-drawer",
        tags$summary(
          tags$span(class = "f001-trigger-label", "Data & profile"),
          tags$span(class = "f001-drawer-grip", "\u2022\u2022\u2022"),
          `aria-label` = "Open active data and profile drawer"
        ),
        tags$div(
          class = "f001-drawer-body", shiny::uiOutput(ns("data_profile"))
        )
      ),
      tags$div(
        class = "f001-workbench",
        shiny::uiOutput(ns("stepper")),
        shiny::conditionalPanel(
          sprintf("input['%s'] === 'data'", ns("step_signal")),
          tags$section(
            `aria-labelledby` = ns("data-heading"),
            tags$div(
              class = "f001-page-title",
              tags$h2(id = ns("data-heading"), "Start with your data"),
              tags$span("Upload is required to continue")
            ),
            tags$details(
              class = "f001-panel",
              open = NA,
              tags$summary(
                "Upload a dataset ",
                tags$span(class = "f001-required", "Required")
              ),
              tags$div(
                class = "f001-panel-body",
                tags$div(
                  class = "f001-drop-caption",
                  "Choose a supported CSV or Excel file."
                ),
                tags$div(
                  class = "f001-drop",
                  shiny::fileInput(
                    ns("data_file"),
                    NULL,
                    accept = c(".csv", ".xls", ".xlsx"),
                    multiple = FALSE,
                    buttonLabel = "Choose file",
                    placeholder = "or drag and drop it here"
                  ),
                  tags$div(class = "f001-drop-caption", "CSV or Excel")
                ),
                tags$div(
                  class = "f001-upload-status",
                  shiny::uiOutput(ns("upload_status"))
                )
              )
            ),
            tags$div(
              class = "f001-footer-action",
              tags$span(
                class = "text-body-secondary",
                "Next: describe the visualization question"
              ),
              shiny::uiOutput(ns("continue_data"))
            )
          )
        ),
        shiny::conditionalPanel(
          sprintf("input['%s'] === 'ask'", ns("step_signal")),
          tags$section(
            `aria-labelledby` = ns("ask-heading"),
            tags$h2(id = ns("ask-heading"), "What would you like to see?"),
            tags$p("Describe one visualization question in your words."),
            tags$details(
              class = "f001-panel",
              open = NA,
              tags$summary("Your visualization question \u00b7 Required"),
              tags$div(
                class = "f001-panel-body",
                shiny::textAreaInput(
                  ns("question"),
                  "Question",
                  value = paste(
                    "Create a boxplot of ALT AVAL by visit,",
                    "split by treatment.",
                    "Include all visits and treatment groups, show the number",
                    "of subjects below each box, and connect the medians."
                  ),
                  width = "100%",
                  rows = 3
                ),
                shiny::uiOutput(ns("question_validation"))
              )
            ),
            tags$div(
              class = "d-flex justify-content-between",
              shiny::actionButton(
                ns("back_to_data"), "Back to data",
                class = "btn-outline-secondary"
              ),
              shiny::actionButton(
                ns("to_confirm"), "Continue to review choices",
                class = "btn-primary"
              )
            )
          )
        ),
        shiny::conditionalPanel(
          sprintf("input['%s'] === 'confirm'", ns("step_signal")),
          tags$section(
            `aria-labelledby` = ns("confirm-heading"),
            tags$h2(id = ns("confirm-heading"), "Review the proposed plot"),
            shiny::uiOutput(ns("confirm_guidance")),
            mod_specification_ui(ns("specification")),
            tags$div(
              class = "d-flex justify-content-between",
              tags$div(
                class = "d-flex gap-2",
                shiny::uiOutput(ns("back_to_ask_ui")),
                shiny::uiOutput(ns("back_to_result_from_confirm_ui"))
              ),
              shiny::uiOutput(ns("confirm_message"))
            ),
            tags$p(
              class = "f001-caption",
              paste(
                "The selected BDS records are validated before",
                "the deterministic",
                "R script is generated or executed."
              )
            )
          )
        ),
        shiny::conditionalPanel(
          sprintf("input['%s'] === 'result'", ns("step_signal")),
          tags$section(
            `aria-labelledby` = ns("result-heading"),
            tags$div(
              class = "f001-page-title",
              tags$h2(id = ns("result-heading"), "Plot result"),
              tags$div(shiny::uiOutput(ns("review_status")))
            ),
            tags$div(
              id = ns("result-body"),
              class = "f001-result-content",
              mod_run_status_ui(ns("run_status")),
              mod_plot_preview_ui(ns("plot_preview")),
              tags$details(
                class = "f001-panel",
                tags$summary("Optional: view automated checks"),
                tags$div(
                  class = "f001-panel-body", mod_evidence_ui(ns("evidence"))
                )
              )
            ),
            tags$div(
              class = "d-flex justify-content-between",
              shiny::actionButton(
                ns("back_to_confirm"), "Back to confirm",
                class = "btn-outline-secondary"
              ),
              shiny::actionButton(
                ns("to_export"), "Continue to export",
                class = "btn-primary"
              )
            )
          )
        ),
        shiny::conditionalPanel(
          sprintf("input['%s'] === 'export'", ns("step_signal")),
          tags$section(
            `aria-labelledby` = ns("export-heading"),
            tags$h2(id = ns("export-heading"), "Export"),
            tags$details(
              class = "f001-panel",
              open = NA,
              tags$summary("Traceability, review, and export"),
              tags$div(
                class = "f001-panel-body",
                mod_revision_history_ui(ns("revision_history")),
                mod_review_ui(ns("review")),
                mod_export_ui(ns("export"))
              )
            ),
            tags$div(
              class = "d-flex justify-content-start",
              shiny::actionButton(
                ns("back_to_result"), "Back to result",
                class = "btn-outline-secondary"
              )
            ),
            tags$p(
              class = "f001-caption",
              paste(
                "Review decisions are pending until both independent reviewers",
                "approve. The exact R script and check evidence remain linked",
                "to this revision."
              )
            )
          )
        ),
        shiny::conditionalPanel(
          sprintf("input['%s'] === 'data'", ns("step_signal")),
          tags$div(
            class = "f001-screen-caption",
            paste(
              "Data comes first. Continue becomes available when a permitted",
              "CSV or Excel file is ready."
            )
          )
        )
      ),
      tags$script(shiny::HTML(sprintf("\
      (() => {
        const drawer = document.getElementById('%s');
        const handle = drawer && drawer.querySelector('summary');
        if (!handle) return;
        let startX = 0;
        let dragged = false;
        handle.addEventListener('pointerdown', (event) => {
          startX = event.clientX;
          dragged = false;
          handle.setPointerCapture(event.pointerId);
        });
        handle.addEventListener('pointermove', (event) => {
          if (event.buttons && event.clientX - startX > 48) {
            drawer.open = true;
            dragged = true;
          }
        });
        handle.addEventListener('click', (event) => {
          if (dragged) {
            event.preventDefault();
            dragged = false;
          }
        });
      })();\n", ns("data_drawer"))))
    )
  )
}

mod_plot_generation_server <- function(
  id,
  current_revision,
  execute_revision,
  create_correction,
  workspace_provider
) {
  tags <- shiny::tags
  shiny::moduleServer(id, function(input, output, session) {
    step_ids <- c("data", "ask", "confirm", "result", "export")
    step_labels <- c("Data", "Ask", "Confirm", "Result", "Export")
    active_step <- shiny::reactiveVal("data")
    loaded_file <- shiny::reactiveVal(NULL)
    upload_error <- shiny::reactiveVal(NULL)
    question_attempted <- shiny::reactiveVal(FALSE)
    confirm_message <- shiny::reactiveVal(NULL)

    question_is_valid <- function() {
      is.character(input$question) && length(input$question) == 1L &&
        !is.na(input$question) && nzchar(trimws(input$question))
    }

    upload_inputs_valid <- function() {
      file <- input$data_file
      is.data.frame(file) && nrow(file) == 1L &&
        all(c("name", "datapath") %in% names(file)) &&
        checkmate::test_string(file$name[[1]], min.chars = 1L) &&
        tolower(tools::file_ext(file$name[[1]])) %in% c("csv", "xls", "xlsx") &&
        checkmate::test_file_exists(file$datapath[[1]], access = "r")
    }

    is_current_upload <- shiny::reactive({
      loaded <- loaded_file()
      file <- input$data_file
      !is.null(loaded) && is.data.frame(file) && nrow(file) == 1L &&
        identical(loaded$path, file$datapath[[1]])
    })

    output$stepper <- shiny::renderUI({
      current <- active_step()
      current_index <- match(current, step_ids)
      tags$div(
        class = "f001-steps",
        lapply(seq_along(step_ids), function(index) {
          class <- if (index == current_index) {
            "f001-stepmark current"
          } else if (index < current_index) {
            "f001-stepmark done"
          } else {
            "f001-stepmark"
          }
          label <- if (index < current_index) {
            paste("\u2713", "\u00b7", step_labels[[index]])
          } else {
            paste(index, "\u00b7", step_labels[[index]])
          }
          tags$div(class = class, label)
        })
      )
    })
    output$step_mark <- shiny::renderUI({
      tags$span(
        class = "f001-step-status",
        paste("Step", match(active_step(), step_ids), "of", length(step_ids))
      )
    })

    output$data_profile <- shiny::renderUI({
      loaded <- loaded_file()
      tags$div(
        tags$h3("Active data"),
        tags$p(
          if (is.null(loaded)) "No dataset uploaded" else loaded$file_name,
          if (!is.null(loaded)) tags$span(class = "f001-drawer-tag", "Ready")
        ),
        tags$div(
          class = "f001-drawer-section",
          tags$b("Data profile"),
          tags$span(
            class = "text-body-secondary",
            if (is.null(loaded)) {
              "Available after upload"
            } else {
              paste(loaded$rows, "rows \u00d7", loaded$columns, "columns")
            }
          )
        ),
        tags$div(
          class = "f001-drawer-section",
          tags$b("File check"),
          tags$span(
            class = "f001-drawer-tag",
            if (!is.null(loaded)) {
              "Passed"
            } else if (!is.null(upload_error())) {
              "Needs attention"
            } else {
              "Waiting for file"
            }
          )
        ),
        if (is.null(loaded)) {
          tags$p(
            class = "text-body-secondary",
            "Drawer starts closed. Click the tab or drag it to open."
          )
        }
      )
    })

    output$upload_status <- shiny::renderUI({
      if (!is.null(upload_error())) {
        return(tags$div(class = "text-danger", role = "alert", upload_error()))
      }
      if (is_current_upload()) {
        return(tags$div(class = "text-success", role = "status", "File ready"))
      }
      NULL
    })

    output$continue_data <- shiny::renderUI({
      shiny::actionButton(
        session$ns("to_ask"),
        "Continue",
        class = "btn-primary",
        disabled = !is_current_upload()
      )
    })

    output$question_validation <- shiny::renderUI({
      if (!question_attempted()) {
        return(NULL)
      }
      shiny::validate(
        shiny::need(
          question_is_valid(),
          "Enter a visualization question before continuing."
        )
      )
      NULL
    })

    output$confirm_guidance <- shiny::renderUI({
      state <- current_revision()
      if (!is.null(state$revision) && is.null(state$pending)) {
        return(tags$p(
          class = "text-body-secondary",
          paste(
            "This generated revision is immutable. Its specification is",
            "shown for review."
          )
        ))
      }
      NULL
    })

    output$back_to_ask_ui <- shiny::renderUI({
      state <- current_revision()
      if (!is.null(state$revision) && is.null(state$pending)) {
        return(NULL)
      }
      shiny::actionButton(
        session$ns("back_to_ask"),
        "Back to question",
        class = "btn-outline-secondary"
      )
    })

    output$back_to_result_from_confirm_ui <- shiny::renderUI({
      state <- current_revision()
      if (is.null(state$revision) || !is.null(state$pending)) {
        return(NULL)
      }
      shiny::actionButton(
        session$ns("back_to_result_from_confirm"),
        "Back to result",
        class = "btn-outline-secondary"
      )
    })

    output$confirm_message <- shiny::renderUI({
      message <- confirm_message()
      if (is.null(message)) {
        return(NULL)
      }
      tags$div(class = "alert alert-danger mb-0", role = "alert", message)
    })

    output$review_status <- shiny::renderUI({
      state <- current_revision()
      if (is.null(state$revision)) {
        return(tags$span(class = "status-badge status-draft", "No result yet"))
      }
      revision <- state$revision
      decisions <- state$repository$list_review_decisions(revision$revision_id)
      status <- revision$status
      label <- if (status %in% c("Draft", "Verified") && !nrow(decisions)) {
        paste(status, "\u00b7 not reviewed")
      } else if (status %in% c("Draft", "Verified")) {
        paste(status, "\u00b7 review pending")
      } else {
        status
      }
      tags$span(
        tags$span(class = paste("status-badge", .status_class(status)), label),
        tags$button(
          type = "button",
          class = "f001-review-info",
          title = paste(
            "Both independent approvals are required for",
            "post-approval export eligibility."
          ),
          `aria-label` = paste(
            "Review status: both independent approvals are required for",
            "post-approval export eligibility."
          ),
          "i"
        )
      )
    })

    set_step <- function(next_step) {
      if (identical(active_step(), next_step)) {
        return(invisible(next_step))
      }
      active_step(next_step)
      shiny::updateTextInput(session, "step_signal", value = next_step)
      invisible(next_step)
    }

    shiny::observeEvent(input$data_file,
      {
        upload_error(NULL)
        loaded_file(NULL)
        if (!upload_inputs_valid()) {
          if (!is.null(input$data_file)) {
            upload_error("Choose one readable CSV or Excel file.")
          }
          return()
        }
        file <- input$data_file
        loaded <- tryCatch(
          {
            provider <- .uploaded_study_data_provider(file)
            snapshot <- pin_study_snapshot(
              provider, provider$manifest$scenarios[[1]]$dataset_id
            )
            snapshot$source_metadata <- provider$source_metadata
            data <- snapshot$data
            list(
              path = file$datapath[[1]],
              file_name = provider$source_metadata$file_name,
              rows = nrow(data),
              columns = ncol(data),
              provider = provider,
              snapshot = snapshot
            )
          },
          error = function(error) {
            upload_error(trimws(cli::ansi_strip(conditionMessage(error))))
            NULL
          }
        )
        if (is.null(loaded)) {
          return()
        }
        loaded_file(loaded)
        current_revision(.empty_assurance_state())
      },
      ignoreInit = TRUE
    )

    shiny::observeEvent(input$to_ask,
      {
        if (!is_current_upload()) {
          return()
        }
        set_step("ask")
      },
      ignoreInit = TRUE
    )

    shiny::observeEvent(input$to_confirm,
      {
        if (!is_current_upload()) {
          return()
        }
        question_attempted(TRUE)
        if (!question_is_valid()) {
          return()
        }
        state <- current_revision()
        if (
          is.null(state$pending) || !identical(state$prompt, input$question)
        ) {
          loaded <- loaded_file()
          state <- .create_assurance_candidate(
            provider = loaded$provider,
            dataset_id = loaded$snapshot$dataset_id,
            prompt = input$question
          )
          current_revision(state)
        }
        set_step("confirm")
      },
      ignoreInit = TRUE
    )

    shiny::observeEvent(input$back_to_data, set_step("data"), ignoreInit = TRUE)
    shiny::observeEvent(input$back_to_ask, set_step("ask"), ignoreInit = TRUE)
    shiny::observeEvent(
      input$back_to_result_from_confirm, set_step("result"),
      ignoreInit = TRUE
    )
    shiny::observeEvent(
      input$back_to_confirm, set_step("confirm"),
      ignoreInit = TRUE
    )
    shiny::observeEvent(input$to_export, set_step("export"), ignoreInit = TRUE)
    shiny::observeEvent(
      input$back_to_result, set_step("result"),
      ignoreInit = TRUE
    )

    run_revision <- function(fields, correction = FALSE, rationale = NULL, provenance = NULL) {
      state <- current_revision()
      snapshot <- if (isTRUE(correction)) {
        state$snapshot
      } else {
        state$pending$snapshot
      }
      can_run <- if (isTRUE(correction)) {
        .can_create_correction(state)
      } else {
        !is.null(state$pending)
      }
      if (!can_run || is.null(snapshot)) {
        confirm_message(paste(
          "Create a new question and confirm its plot choices",
          "before execution."
        ))
        return(invisible(NULL))
      }
      spec <- tryCatch(
        .confirmed_spec_from_fields(snapshot$dataset_id, fields),
        error = function(error) {
          confirm_message(conditionMessage(error))
          NULL
        }
      )
      if (is.null(spec)) {
        return(invisible(NULL))
      }
      profile <- validate_bds_profile(
        snapshot,
        spec$fields[setdiff(.plot_spec_fields, c("dataset_id", "scale_mode"))]
      )
      if (profile$blocked) {
        diagnostic <- profile$blocking_diagnostics[[1]]
        confirm_message(paste(diagnostic$code, diagnostic$message, sep = ": "))
        return(invisible(NULL))
      }
      confirm_message(NULL)
      set_step("result")
      tryCatch(
        if (isTRUE(correction)) {
          create_correction(fields, rationale, provenance)
        } else {
          execute_revision(fields)
        },
        error = function(error) {
          set_step("confirm")
          confirm_message(conditionMessage(error))
        }
      )
    }

    execute_current <- function(fields) run_revision(fields)
    correct_current <- function(fields, rationale, provenance) {
      run_revision(
        fields,
        correction = TRUE,
        rationale = rationale,
        provenance = provenance
      )
    }

    mod_specification_server(
      "specification",
      current_revision,
      execute_current,
      correct_current
    )
    mod_run_status_server("run_status", current_revision)
    mod_plot_preview_server("plot_preview", current_revision)
    mod_evidence_server("evidence", current_revision)
    mod_revision_history_server("revision_history", current_revision)
    mod_export_server("export", current_revision, workspace_provider)
    mod_review_server("review", current_revision, current_revision)
  })
}

.uploaded_study_data_provider <- function(file) {
  if (!checkmate::test_data_frame(file, min.rows = 1L) || nrow(file) != 1L ||
    !checkmate::test_string(file$name[[1]], min.chars = 1L) ||
    !checkmate::test_file_exists(file$datapath[[1]], access = "r")) {
    cli::cli_abort("Choose one readable CSV or Excel file")
  }

  file_name <- basename(file$name[[1]])
  file_type <- tolower(tools::file_ext(file_name))
  sheet_name <- NULL
  data <- if (identical(file_type, "csv")) {
    utils::read.csv(
      file$datapath[[1]],
      check.names = FALSE, stringsAsFactors = FALSE
    )
  } else if (file_type %in% c("xls", "xlsx")) {
    sheets <- readxl::excel_sheets(file$datapath[[1]])
    if (!length(sheets)) {
      cli::cli_abort("The Excel workbook contains no worksheet")
    }
    sheet_name <- sheets[[1]]
    as.data.frame(
      readxl::read_excel(
        file$datapath[[1]],
        sheet = sheet_name, .name_repair = "minimal"
      ),
      optional = TRUE
    )
  } else {
    cli::cli_abort("Choose a CSV or Excel file")
  }

  if (
    !checkmate::test_data_frame(data, min.rows = 1L, min.cols = 1L) ||
      anyNA(names(data)) || any(!nzchar(trimws(names(data)))) ||
      anyDuplicated(names(data))
  ) {
    cli::cli_abort(
      paste(
        "The selected file must contain records and",
        "unique, non-empty column names"
      )
    )
  }
  required <- c(
    "USUBJID", "PARAMCD", "PARAM", "AVISIT", "AVISITN", "AVAL", "AVALU"
  )
  missing <- setdiff(required, names(data))
  if (length(missing)) {
    cli::cli_abort(paste(
      "This file does not match the supported upload format. Upload",
      "long-format clinical data",
      "with one row per subject and visit.",
      "Missing columns:", paste0(paste(missing, collapse = ", "), "."),
      "If visits are separate columns (for example, Baseline, Week 4, and",
      "Week 8), reshape them into rows, with visit labels in AVISIT, numeric",
      "visit order in AVISITN, and measurements in AVAL. Include PARAMCD",
      "(parameter code), PARAM (name),",
      "and AVALU (unit) as columns too."
    ))
  }
  treatment_variables <- grep(
    "^TRT(A|P|[0-9]+[AP])$", names(data),
    value = TRUE
  )
  if (!length(treatment_variables)) {
    cli::cli_abort(
      paste(
        "The selected worksheet needs a supported planned or actual",
        "treatment variable"
      )
    )
  }
  if (!is.numeric(data$AVAL) || !is.numeric(data$AVISITN)) {
    cli::cli_abort("AVAL and AVISITN must be numeric in the selected worksheet")
  }
  if (!any(!is.na(data$PARAMCD) & nzchar(as.character(data$PARAMCD))) ||
    !any(!is.na(data$PARAM) & nzchar(as.character(data$PARAM))) ||
    !any(!is.na(data$AVALU) & nzchar(as.character(data$AVALU))) ||
    !any(
      !is.na(data$AVISIT) & nzchar(as.character(data$AVISIT)) &
        is.finite(data$AVISITN)
    ) ||
    !any(vapply(treatment_variables, function(variable) {
      any(!is.na(data[[variable]]) & nzchar(as.character(data[[variable]])))
    }, logical(1)))) {
    cli::cli_abort(
      paste(
        "The selected worksheet must contain selectable parameters, units,",
        "visits, and treatment levels"
      )
    )
  }

  content_hash <- study_data_content_hash(data)
  source_hash <- digest::digest(file = file$datapath[[1]], algo = "sha256")
  snapshot_key <- canonical_hash(list(
    content_hash = content_hash,
    source_file_hash = source_hash
  ))
  source_metadata <- list(
    source = "direct_upload",
    file_name = file_name,
    file_type = file_type,
    sheet_name = sheet_name,
    source_file_hash = source_hash
  )
  dataset_id <- paste0("upload-", substr(snapshot_key, 1L, 16L))
  metadata <- list(
    dataset_id = dataset_id,
    adam_designation = "BDS",
    declared_keys = as.list(c("USUBJID", "PARAMCD", "AVISIT")),
    metadata_version = "uploaded-bds-v1",
    content_hash = content_hash,
    snapshot_id = paste0("snapshot-", substr(snapshot_key, 1L, 16L)),
    permitted_treatment_variables = as.list(treatment_variables)
  )
  structure(
    list(
      manifest = list(scenarios = list(metadata)),
      read_data = \(metadata) data,
      source_metadata = source_metadata
    ),
    class = "study_data_provider"
  )
}

.standalone_boxplot_stats <- function(
  data,
  treatment_variable,
  y_variable,
  facet_levels,
  visit_levels,
  low_n_policy
) {
  required_columns <- c(
    "USUBJID", "AVISIT", "AVISITN", treatment_variable, y_variable
  )
  if (!is.data.frame(data) || length(setdiff(required_columns, names(data)))) {
    cli::cli_abort(paste0(
      "analysis_data must contain USUBJID, AVISIT, AVISITN, ",
      "treatment, and Y columns"
    ))
  }
  if (!is.numeric(data[[y_variable]])) {
    cli::cli_abort("The selected Y variable must be numeric")
  }
  if (!is.character(facet_levels) || !length(facet_levels) ||
    anyDuplicated(facet_levels) ||
    !is.character(visit_levels) || !length(visit_levels) ||
    anyDuplicated(visit_levels)) {
    cli::cli_abort(paste0(
      "Facet and visit levels must be ordered, ",
      "unique character vectors"
    ))
  }
  if (!is.list(low_n_policy) ||
    !identical(
      sort(names(low_n_policy)),
      sort(c("value", "rationale", "authority", "version"))
    ) ||
    !is.numeric(low_n_policy$value) || length(low_n_policy$value) != 1L ||
    !is.finite(low_n_policy$value) || low_n_policy$value < 1) {
    cli::cli_abort(paste0(
      "low_n_policy must retain value, rationale, ",
      "authority, and version"
    ))
  }
  if (!all(vapply(
    low_n_policy[c("rationale", "authority", "version")],
    function(value) {
      is.character(value) && length(value) == 1L && nzchar(value)
    },
    logical(1)
  ))) {
    cli::cli_abort("low_n_policy text fields must be non-empty strings")
  }
  type7_quantile <- function(values, probability) {
    position <- (length(values) - 1) * probability + 1
    lower_index <- floor(position)
    fraction <- position - lower_index
    if (fraction == 0 || lower_index == length(values)) {
      return(values[[lower_index]])
    }
    values[[lower_index]] + fraction * (
      values[[lower_index + 1L]] - values[[lower_index]]
    )
  }
  summarize_box <- function(rows) {
    values <- rows[[y_variable]]
    sorted_values <- sort(values, method = "radix")
    lower <- type7_quantile(sorted_values, 0.25)
    middle <- type7_quantile(sorted_values, 0.5)
    upper <- type7_quantile(sorted_values, 0.75)
    interquartile_range <- upper - lower
    inside <- values >= lower - 1.5 * interquartile_range &
      values <= upper + 1.5 * interquartile_range
    distinct_n <- length(unique(as.character(rows$USUBJID)))
    list(
      box = data.frame(
        treatment = as.character(rows[[treatment_variable]][[1]]),
        visit = as.character(rows$AVISIT[[1]]),
        visit_n = rows$AVISITN[[1]],
        n = as.integer(distinct_n),
        ymin = min(values[inside]),
        lower = lower,
        middle = middle,
        upper = upper,
        ymax = max(values[inside]),
        low_n = distinct_n < low_n_policy$value,
        stringsAsFactors = FALSE
      ),
      outliers = data.frame(
        treatment = as.character(rows[[treatment_variable]][!inside]),
        visit = as.character(rows$AVISIT[!inside]),
        visit_n = rows$AVISITN[!inside],
        USUBJID = as.character(rows$USUBJID[!inside]),
        value = values[!inside],
        stringsAsFactors = FALSE
      )
    )
  }
  empty_outliers <- function() {
    data.frame(
      treatment = character(), visit = character(), visit_n = numeric(),
      USUBJID = character(), value = numeric(), stringsAsFactors = FALSE
    )
  }
  low_n_policy$value <- as.numeric(low_n_policy$value)
  display <- data[
    !is.na(data[[y_variable]]) &
      !is.na(data[[treatment_variable]]) &
      data[[treatment_variable]] %in% facet_levels &
      !is.na(data$AVISIT) & data$AVISIT %in% visit_levels, ,
    drop = FALSE
  ]
  if (any(!is.finite(display[[y_variable]]))) {
    cli::cli_abort("The selected Y variable must contain only finite values")
  }
  if (nrow(display)) {
    ordering <- order(
      match(as.character(display[[treatment_variable]]), facet_levels),
      match(as.character(display$AVISIT), visit_levels),
      as.character(display$USUBJID),
      method = "radix"
    )
    display <- display[ordering, , drop = FALSE]
    row.names(display) <- NULL
    group_start <- c(
      TRUE,
      as.character(display[[treatment_variable]][-1L]) !=
        as.character(display[[treatment_variable]][-nrow(display)]) |
        as.character(display$AVISIT[-1L]) !=
          as.character(display$AVISIT[-nrow(display)])
    )
    summaries <- lapply(
      split(seq_len(nrow(display)), cumsum(group_start)),
      function(index) {
        summarize_box(display[index, , drop = FALSE])
      }
    )
    boxes <- do.call(rbind, lapply(summaries, `[[`, "box"))
    outlier_rows <- lapply(summaries, `[[`, "outliers")
    outliers <- if (sum(vapply(outlier_rows, nrow, integer(1))) > 0L) {
      do.call(rbind, outlier_rows)
    } else {
      empty_outliers()
    }
    box_order <- order(
      match(boxes$treatment, facet_levels),
      match(boxes$visit, visit_levels),
      method = "radix"
    )
    boxes <- boxes[box_order, , drop = FALSE]
    row.names(boxes) <- NULL
    if (nrow(outliers)) {
      outlier_order <- order(
        match(outliers$treatment, facet_levels),
        match(outliers$visit, visit_levels),
        outliers$value,
        outliers$USUBJID,
        method = "radix"
      )
      outliers <- outliers[outlier_order, , drop = FALSE]
      row.names(outliers) <- NULL
    }
  } else {
    boxes <- data.frame(
      treatment = character(), visit = character(), visit_n = numeric(),
      n = integer(), ymin = numeric(), lower = numeric(), middle = numeric(),
      upper = numeric(), ymax = numeric(), low_n = logical(),
      stringsAsFactors = FALSE
    )
    outliers <- empty_outliers()
  }
  medians <- boxes[c("treatment", "visit", "visit_n", "middle")]
  names(medians)[[4]] <- "median"
  n_strip <- boxes[c("treatment", "visit", "visit_n", "n", "low_n")]
  n_strip$label <- ifelse(
    n_strip$low_n,
    paste0("N = ", n_strip$n, " - Low N"),
    paste0("N = ", n_strip$n)
  )
  structure(
    list(
      analysis_version = "boxplot-analysis-v1",
      treatment_variable = treatment_variable,
      y_variable = y_variable,
      facet_levels = facet_levels,
      visit_levels = visit_levels,
      low_n_policy = low_n_policy,
      boxes = boxes,
      outliers = outliers,
      medians = medians,
      n_strip = n_strip
    ),
    class = "boxplot_analysis"
  )
}

.standalone_assemble_boxplot <- function(
  analysis,
  scale_mode = c("fixed", "free"),
  unit = NULL
) {
  if (!inherits(analysis, "boxplot_analysis")) {
    cli::cli_abort("analysis must be a boxplot_analysis object")
  }
  scale_mode <- match.arg(scale_mode)
  plot_data <- analysis[c("boxes", "outliers", "medians", "n_strip")]
  plot_data <- lapply(plot_data, function(data) {
    data$treatment <- factor(data$treatment, levels = analysis$facet_levels)
    data$visit <- factor(data$visit, levels = analysis$visit_levels)
    data
  })
  y_label <- if (is.null(unit) || !nzchar(unit)) {
    analysis$y_variable
  } else {
    paste0(analysis$y_variable, " (", unit, ")")
  }
  facet_scales <- if (identical(scale_mode, "free")) "free_y" else "fixed"
  plot_theme <- ggplot2::theme_bw(base_size = 12) +
    ggplot2::theme(
      panel.border = ggplot2::element_rect(
        color = "black", fill = NA, linewidth = 1
      ),
      panel.grid.major = ggplot2::element_line(
        color = "grey90", linewidth = 0.3
      ),
      panel.grid.minor = ggplot2::element_blank(),
      text = ggplot2::element_text(face = "bold"),
      axis.text = ggplot2::element_text(face = "bold", color = "black"),
      axis.text.x = ggplot2::element_blank(),
      axis.ticks.x = ggplot2::element_blank(),
      strip.background = ggplot2::element_rect(
        fill = "grey85", color = "black", linewidth = 1
      ),
      strip.text = ggplot2::element_text(face = "bold", color = "black")
    )
  plot <- ggplot2::ggplot(
    plot_data$boxes,
    ggplot2::aes(
      x = visit, ymin = ymin, lower = lower, middle = middle,
      upper = upper, ymax = ymax
    )
  ) +
    ggplot2::geom_boxplot(
      stat = "identity", outlier.shape = NA, fill = "white",
      color = "black", linewidth = 0.6
    ) +
    ggplot2::geom_line(
      data = plot_data$medians,
      mapping = ggplot2::aes(x = visit, y = median, group = treatment),
      inherit.aes = FALSE,
      linewidth = 0.8,
      color = "black"
    ) +
    ggplot2::geom_point(
      data = plot_data$medians,
      mapping = ggplot2::aes(x = visit, y = median),
      inherit.aes = FALSE,
      shape = 21,
      size = 3,
      fill = "white",
      color = "black",
      stroke = 1.2
    ) +
    ggplot2::geom_point(
      data = plot_data$outliers,
      mapping = ggplot2::aes(x = visit, y = value),
      inherit.aes = FALSE,
      shape = 1,
      size = 2.5,
      color = "black",
      stroke = 1
    ) +
    ggplot2::facet_wrap(
      ggplot2::vars(treatment),
      scales = facet_scales, drop = FALSE
    ) +
    ggplot2::scale_x_discrete(drop = FALSE, limits = analysis$visit_levels) +
    ggplot2::labs(x = NULL, y = y_label) +
    plot_theme
  n_strip <- ggplot2::ggplot(
    plot_data$n_strip,
    ggplot2::aes(x = visit, y = 1, label = label)
  ) +
    ggplot2::geom_text(
      na.rm = TRUE, size = 4, color = "black", fontface = "bold"
    ) +
    ggplot2::facet_wrap(ggplot2::vars(treatment), drop = FALSE) +
    ggplot2::scale_x_discrete(drop = FALSE, limits = analysis$visit_levels) +
    ggplot2::scale_y_continuous(limits = c(0.5, 1.5)) +
    ggplot2::labs(x = "Analysis Visit", y = NULL) +
    ggplot2::theme_bw(base_size = 12) +
    ggplot2::theme(
      panel.border = ggplot2::element_rect(
        color = "black", fill = NA, linewidth = 1
      ),
      text = ggplot2::element_text(face = "bold"),
      axis.text = ggplot2::element_text(face = "bold", color = "black"),
      axis.text.y = ggplot2::element_blank(),
      axis.ticks.y = ggplot2::element_blank(),
      panel.grid = ggplot2::element_blank(),
      strip.text = ggplot2::element_blank(),
      strip.background = ggplot2::element_rect(
        fill = "grey85", color = "black", linewidth = 1
      )
    )
  combined <- patchwork::wrap_plots(
    plot,
    n_strip,
    ncol = 1L,
    heights = c(4, 1)
  )
  structure(
    list(
      artifact_version = "boxplot-artifact-v1",
      status = if (identical(scale_mode, "free")) {
        "Experimental/Draft"
      } else {
        "Draft"
      },
      warning = if (identical(scale_mode, "free")) {
        "Free Y scales weaken cross-facet visual comparison."
      } else {
        NULL
      },
      scale_mode = scale_mode,
      analysis = analysis,
      plot_data = plot_data,
      plot = plot,
      n_strip = n_strip,
      combined = combined
    ),
    class = "boxplot_artifact"
  )
}

.standalone_function_text <- function(name, fn) {
  paste0(name, " <- ", paste(deparse(fn), collapse = "\n"))
}

new_lifecycle_service <- function(repository) {
  .validate_evidence_repository(
    repository,
    c("get_revision", "list_revisions", "create_revision")
  )

  create_correction <- function(
    parent_revision_id, revision_id, creator_id, spec_hash,
    code_hash, image_hash, analytical_hash, rationale,
    provenance, idempotency_key, initial_status = "Draft"
  ) {
    if (!checkmate::test_string(rationale, min.chars = 1)) {
      cli::cli_abort("Correction rationale is required")
    }
    if (!checkmate::test_string(provenance, min.chars = 1)) {
      cli::cli_abort("Correction provenance is required")
    }
    parent <- repository$get_revision(parent_revision_id)
    if (!parent$status %in% c("Rejected", "Reviewed")) {
      cli::cli_abort("Only a closed revision can have a correction successor")
    }
    revisions <- repository$list_revisions(parent$plot_id)
    repository$create_revision(
      parent$plot_id, revision_id, max(revisions$revision_number) + 1L,
      creator_id, spec_hash, code_hash, image_hash, analytical_hash,
      idempotency_key,
      parent_revision_id = parent_revision_id, correction_rationale = rationale,
      correction_provenance = provenance, initial_status = initial_status
    )
    invisible(repository$get_revision(revision_id))
  }
  structure(
    list(
      create_correction = create_correction
    ),
    class = "lifecycle_service"
  )
}

local_identity_provider <- function(actors) {
  if (!is.list(actors) || !all(vapply(
    actors, inherits, logical(1), "submission_sync_actor"
  ))) {
    cli::cli_abort("Local identities must be submission sync actors")
  }
  ids <- vapply(actors, `[[`, character(1), "id")
  if (anyDuplicated(ids)) {
    cli::cli_abort("Local identity identifiers must be unique")
  }

  get_actor <- function(actor_id) {
    if (!checkmate::test_string(actor_id, min.chars = 1)) {
      cli::cli_abort("Actor identifier is required")
    }
    match <- which(ids == actor_id)
    if (!length(match)) {
      cli::cli_abort("Authenticated actor {.val {actor_id}} was not found")
    }
    actors[[match]]
  }
  structure(list(get_actor = get_actor), class = "local_identity_provider")
}

.verification_checks <- function(
  request, script, analysis_data, runner_result
) {
  result <- runner_result$result
  checks <- list(
    schema = inherits(request, "execution_request"),
    script_hash = identical(.execution_hash_text(script), request$script_hash),
    snapshot_hash = identical(
      canonical_hash(analysis_data), request$snapshot_hash
    ),
    runner_success = identical(runner_result$status, "succeeded"),
    runner_manifest = identical(
      runner_result$manifest_version,
      "execution-runner-result-v1"
    ),
    result_manifest = inherits(result, "execution_result") &&
      identical(result$manifest_version, "execution-result-v1"),
    request_binding = FALSE,
    analytical_hash = FALSE,
    image_hash = FALSE,
    environment_fingerprint = FALSE
  )
  if (isTRUE(checks$result_manifest)) {
    request_fields <- setdiff(names(unclass(request)), "manifest_version")
    checks$request_binding <- identical(
      unclass(result)[request_fields],
      unclass(request)[request_fields]
    )
    checks$analytical_hash <- identical(
      result$analytical_hash,
      canonical_hash(runner_result$analytical_output)
    )
    image_exists <- checkmate::test_string(
      runner_result$image_path,
      min.chars = 1L
    ) && fs::file_exists(runner_result$image_path) &&
      fs::file_size(runner_result$image_path) > 0
    checks$image_hash <- image_exists &&
      checkmate::test_string(result$image_hash, pattern = "^[0-9a-f]{64}$") &&
      identical(
        .execution_hash_file(runner_result$image_path),
        result$image_hash
      )
    checks$environment_fingerprint <- checkmate::test_string(
      result$environment_fingerprint,
      pattern = "^[0-9a-f]{64}$"
    )
  }
  checks
}

verify_execution_result <- function(
  request, script, analysis_data, runner_result
) {
  checks <- .verification_checks(request, script, analysis_data, runner_result)
  failed <- names(checks)[!unlist(checks, use.names = FALSE)]
  structure(
    list(
      verification_version = "execution-verification-v1",
      status = if (length(failed)) "failed" else "passed",
      checks = checks,
      failed_checks = failed
    ),
    class = "execution_verification"
  )
}

new_verification_service <- function() {
  structure(
    list(verify = verify_execution_result),
    class = "verification_service"
  )
}

#' Run the Shiny Application
#'
#' @param ... arguments to pass to golem_opts.
#' See `?golem::get_golem_options` for more details.
#' @param runtime_config Injected runtime configuration.
#' @inheritParams shiny::shinyApp
#'
#' @export
#' @importFrom shiny shinyApp
#' @importFrom golem with_golem_options
run_app <- function(
  onStart = NULL, # nolint: object_name_linter
  options = list(),
  enableBookmarking = NULL, # nolint: object_name_linter
  uiPattern = "/", # nolint: object_name_linter
  runtime_config = new_runtime_config(),
  ...
) {
  with_golem_options(
    app = shinyApp(
      ui = function(request) app_ui(request, runtime_config = runtime_config),
      server = function(input, output, session) {
        app_server(input, output, session, runtime_config = runtime_config)
      },
      onStart = onStart,
      options = options,
      enableBookmarking = enableBookmarking,
      uiPattern = uiPattern
    ),
    golem_opts = list(...)
  )
}

mod_review_ui <- function(id) {
  ns <- shiny::NS(id)
  bslib::card(
    class = "assurance-panel",
    bslib::card_header("Two-Person Review"),
    bslib::card_body(
      shiny::selectInput(
        ns("actor_id"),
        "Reviewer identity",
        choices = c(
          "Statistical programmer" = "stat-programmer",
          "Biostatistician" = "biostatistician",
          "Creator" = "creator"
        )
      ),
      shiny::selectInput(
        ns("role"),
        "Review role",
        choices = c(
          "Statistical programmer" = "statistical_programmer",
          "Biostatistician" = "biostatistician"
        )
      ),
      shiny::textAreaInput(
        ns("comment"), "Comment or rejection rationale",
        rows = 3
      ),
      div(
        class = "review-actions",
        shiny::actionButton(ns("approve"), "Approve", class = "btn-success"),
        shiny::actionButton(
          ns("reject"), "Reject",
          class = "btn-outline-danger"
        )
      ),
      shiny::uiOutput(ns("message")),
      shiny::tableOutput(ns("decisions"))
    )
  )
}

mod_review_server <- function(id, current_revision, set_current_revision) {
  shiny::moduleServer(id, function(input, output, session) {
    message <- shiny::reactiveVal(NULL)

    output$message <- shiny::renderUI({
      text <- message()
      if (is.null(text)) {
        return(NULL)
      }
      div(class = "assurance-message", role = "status", text)
    })

    decide <- function(decision) {
      state <- current_revision()
      if (is.null(state$review_service) || is.null(state$revision)) {
        cli::cli_abort("Create and verify a revision before review")
      }
      current <- state$repository$get_revision(state$revision$revision_id)
      key <- paste(
        decision,
        current$revision_id,
        input$actor_id,
        current$version,
        sep = ":"
      )
      if (identical(decision, "approved")) {
        revision <- state$review_service$approve(
          current$revision_id,
          input$actor_id,
          as.integer(current$version),
          key,
          comment = input$comment,
          role = input$role
        )
      } else {
        revision <- state$review_service$reject(
          current$revision_id,
          input$actor_id,
          as.integer(current$version),
          key,
          rationale = input$comment,
          role = input$role
        )
      }
      state$revision <- revision
      set_current_revision(state)
      message(paste("Recorded", decision, "decision."))
    }

    shiny::observeEvent(input$approve,
      {
        tryCatch(
          decide("approved"),
          error = function(error) message(conditionMessage(error))
        )
      },
      ignoreInit = TRUE
    )

    shiny::observeEvent(input$reject,
      {
        tryCatch(
          decide("rejected"),
          error = function(error) message(conditionMessage(error))
        )
      },
      ignoreInit = TRUE
    )

    output$decisions <- shiny::renderTable(
      {
        state <- current_revision()
        if (is.null(state$repository) || is.null(state$revision)) {
          return(data.frame())
        }
        decisions <- state$repository$list_review_decisions(
          state$revision$revision_id
        )
        if (!nrow(decisions)) {
          return(data.frame())
        }
        decisions[, c(
          "actor_id", "role", "decision", "created_at"
        ), drop = FALSE]
      },
      striped = TRUE,
      spacing = "s"
    )
  })
}

.synthetic_data_root <- function() {
  installed <- system.file(
    "extdata", "synthetic",
    package = "ADaMViz.SubmissionSync"
  )
  if (nzchar(installed)) {
    return(installed)
  }
  candidates <- c(
    file.path("inst", "extdata", "synthetic"),
    file.path("..", "..", "inst", "extdata", "synthetic")
  )
  existing <- candidates[dir.exists(candidates)]
  if (length(existing)) {
    normalizePath(existing[[1]], winslash = "/")
  } else {
    candidates[[1]]
  }
}

#' Create the governed local study-data provider
#'
#' @param root Directory containing `scenario-manifest.json` and its pinned RDS
#'   snapshots. The default resolves package installation data and then the
#'   source-tree location.
#'
#' @return A local `study_data_provider`.
#' @export
local_study_data_provider <- function(root = .synthetic_data_root()) {
  if (!checkmate::test_directory_exists(root, access = "r")) {
    cli::cli_abort("The local synthetic study-data directory is unavailable")
  }
  manifest_path <- file.path(root, "scenario-manifest.json")
  if (!checkmate::test_file_exists(manifest_path, access = "r")) {
    cli::cli_abort("The governed synthetic scenario manifest is unavailable")
  }
  manifest <- jsonlite::read_json(manifest_path, simplifyVector = FALSE)
  .validate_synthetic_manifest(manifest)

  structure(
    list(
      port = new_provider_port(
        "study_data", c("list_catalog", "read_snapshot")
      ),
      manifest = manifest,
      read_data = function(metadata) {
        file_name <- metadata$file
        if (!checkmate::test_string(
          file_name,
          pattern = "^adlb-[a-z0-9-]+\\.rds$"
        )) {
          cli::cli_abort(
            "The synthetic manifest contains an invalid snapshot file name"
          )
        }
        readRDS(file.path(root, file_name))
      }
    ),
    class = "study_data_provider"
  )
}

mod_plot_preview_ui <- function(id) {
  ns <- shiny::NS(id)
  bslib::card(
    class = "assurance-panel",
    bslib::card_header("Plot preview"),
    bslib::card_body(
      shiny::uiOutput(ns("plot")),
      tags$details(
        class = "f001-panel",
        tags$summary("Generated R script"),
        tags$div(
          class = "f001-panel-body",
          shiny::verbatimTextOutput(ns("code"), placeholder = TRUE)
        )
      )
    )
  )
}

mod_plot_preview_server <- function(id, current_revision) {
  shiny::moduleServer(id, function(input, output, session) {
    output$plot <- shiny::renderUI({
      state <- current_revision()
      image_hash <- state$revision$image_hash %||% NA_character_
      store <- state$repository$artifact_store
      if (!is.null(store) && checkmate::test_string(
        image_hash,
        pattern = "^[0-9a-f]{64}$"
      )) {
        shiny::imageOutput(session$ns("accepted_plot"), height = "520px")
      } else {
        shiny::plotOutput(session$ns("experimental_plot"), height = "520px")
      }
    })

    output$experimental_plot <- shiny::renderPlot(
      {
        state <- current_revision()
        shiny::validate(shiny::need(
          !is.null(state$artifact), "No plot artifact yet."
        ))
        state$artifact$combined
      },
      alt = function() {
        state <- current_revision()
        if (is.null(state$profile)) {
          return("No governed plot revision has been generated.")
        }
        paste(
          "Longitudinal boxplot for",
          state$spec$fields$paramcd,
          "using",
          state$spec$fields$y_variable,
          "faceted by",
          state$spec$fields$treatment_variable,
          "with N values in an aligned lower strip."
        )
      }
    )

    output$accepted_plot <- shiny::renderImage(
      {
        state <- current_revision()
        image_hash <- state$revision$image_hash %||% NA_character_
        store <- state$repository$artifact_store
        shiny::validate(shiny::need(
          !is.null(store) && checkmate::test_string(
            image_hash,
            pattern = "^[0-9a-f]{64}$"
          ),
          "No accepted plot artifact yet."
        ))
        image_path <- tempfile(fileext = ".png")
        writeBin(store$get(image_hash), image_path)
        list(
          src = image_path,
          contentType = "image/png",
          style = "width: 100%; height: 100%; object-fit: contain;",
          alt = paste(
            "Accepted longitudinal boxplot for",
            state$spec$fields$paramcd
          )
        )
      },
      deleteFile = TRUE
    )

    output$code <- shiny::renderText({
      state <- current_revision()
      code_hash <- state$revision$code_hash %||% NA_character_
      store <- state$repository$artifact_store
      if (!is.null(store) && checkmate::test_string(
        code_hash,
        pattern = "^[0-9a-f]{64}$"
      )) {
        return(rawToChar(store$get(code_hash)))
      }
      shiny::validate(shiny::need(
        !is.null(state$script), "No executed R script yet."
      ))
      state$script
    })
  })
}

.standalone_script_expressions <- function(spec, low_n_policy) {
  calculate_expression <- rlang::call2(
    "<-",
    rlang::sym("calculate_boxplot_statistics"),
    rlang::call2(
      "function",
      formals(.standalone_boxplot_stats), # nolint: object_usage_linter.
      body(.standalone_boxplot_stats) # nolint: object_usage_linter.
    )
  )
  assemble_expression <- rlang::call2(
    "<-",
    rlang::sym("assemble_boxplot"),
    rlang::call2(
      "function",
      formals(.standalone_assemble_boxplot),
      body(.standalone_assemble_boxplot)
    )
  )
  treatment_variable <- spec$fields$treatment_variable
  y_variable <- spec$fields$y_variable
  facet_levels <- spec$fields$treatment_levels
  visit_levels <- spec$fields$visits
  scale_mode <- spec$fields$scale_mode
  unit <- spec$fields$unit
  list(
    calculate_expression,
    assemble_expression,
    rlang::expr(boxplot_analysis <- calculate_boxplot_statistics(
      data = !!rlang::sym("analysis_data"),
      treatment_variable = !!treatment_variable,
      y_variable = !!y_variable,
      facet_levels = !!facet_levels,
      visit_levels = !!visit_levels,
      low_n_policy = list(
        value = !!as.numeric(low_n_policy$value),
        rationale = !!low_n_policy$rationale,
        authority = !!low_n_policy$authority,
        version = !!low_n_policy$version
      )
    )),
    rlang::expr(boxplot_artifact <- assemble_boxplot(
      analysis = boxplot_analysis,
      scale_mode = !!scale_mode,
      unit = !!unit
    )),
    rlang::expr(if (sys.nframe() == 0L) print(boxplot_artifact$combined))
  )
}

#' Compile the deterministic governed boxplot script
#'
#' The controlled runner provides validated selected records as `analysis_data`.
#' The caller must supply `analysis_data`. The script contains resolved
#' literals, inlined helpers, and uses `ggplot2`, `cli`, and `patchwork`.
#'
#' @param spec A confirmed `plot_spec`.
#' @param low_n_policy Retained policy with `value`, `rationale`, `authority`,
#'   and `version`.
#'
#' @return A length-one UTF-8 R script.
#' @export
compile_boxplot_script <- function(spec, low_n_policy) {
  .validate_plot_spec(spec)
  if (!identical(spec$state, "confirmed")) {
    cli::cli_abort("Only a confirmed plot specification can be compiled")
  }
  .validate_boxplot_design(
    spec$fields$treatment_levels,
    spec$fields$visits,
    low_n_policy
  )
  script_expressions <- .standalone_script_expressions(spec, low_n_policy)
  script_text <- vapply(
    script_expressions,
    \(expression) rlang::expr_text(expression, width = 80L),
    character(1)
  )
  lines <- c(
    "# Boxplot Analysis Script",
    "# Required packages: ggplot2, cli, patchwork",
    "# The generated script does not require the source application package.",
    "# Source this script after defining analysis_data.",
    "",
    "library(ggplot2)",
    "library(cli)",
    "library(patchwork)",
    "",
    "# Data loading ----",
    "if (!exists(\"analysis_data\", inherits = FALSE)) {",
    "  stop(\"analysis_data must be supplied\", call. = FALSE)",
    "}",
    "",
    "# Analysis and plotting functions ----",
    script_text[1:2],
    "",
    "# Execute analysis ----",
    script_text[3:5]
  )
  enc2utf8(paste0(paste(lines, collapse = "\n"), "\n"))
}

.plot_spec_fields <- c(
  "dataset_id", "paramcd", "y_variable", "unit", "treatment_variable",
  "treatment_levels", "visits", "scale_mode"
)

new_plot_spec <- function(
  dataset_id,
  paramcd = NULL,
  y_variable = NULL,
  unit = NULL,
  treatment_variable = NULL,
  treatment_levels = NULL,
  visits = NULL,
  scale_mode = "fixed",
  provenance = list(),
  state = c("candidate", "confirmed")
) {
  state <- match.arg(state)
  if (!checkmate::test_string(dataset_id, min.chars = 1)) {
    cli::cli_abort("{.arg dataset_id} must be one non-empty identifier")
  }
  if (!is.null(y_variable) && !checkmate::test_choice(
    y_variable,
    choices = c("AVAL", "CHG", "PCHG")
  )) {
    cli::cli_abort(paste0(
      "{.arg y_variable} must be one of {.val ",
      "{c('AVAL', 'CHG', 'PCHG')}}"
    ))
  }
  if (!checkmate::test_choice(scale_mode, choices = c("fixed", "free"))) {
    cli::cli_abort("{.arg scale_mode} must be {.val fixed} or {.val free}")
  }
  unknown_provenance <- setdiff(names(provenance), .plot_spec_fields)
  if (length(unknown_provenance)) {
    cli::cli_abort(paste0(
      "Unknown provenance field{?s}: {.field {unknown_provenance}}"
    ))
  }
  invalid_sources <- unlist(provenance, use.names = FALSE)
  if (length(invalid_sources) && any(!invalid_sources %in% c(
    "prompt", "metadata", "default", "user_confirmed"
  ))) {
    cli::cli_abort(paste0(
      "Provenance values must be prompt, metadata, default, or user_confirmed"
    ))
  }

  fields <- list(
    dataset_id = dataset_id,
    paramcd = paramcd,
    y_variable = y_variable,
    unit = unit,
    treatment_variable = treatment_variable,
    treatment_levels = treatment_levels,
    visits = visits,
    scale_mode = scale_mode
  )
  structure(
    list(
      schema_version = "plot-spec-v1",
      state = state,
      fields = fields,
      provenance = provenance,
      hash = canonical_hash(list(fields = fields, provenance = provenance))
    ),
    class = "plot_spec"
  )
}

plot_spec_clarifications <- function(spec) {
  .validate_plot_spec(spec)
  required <- .plot_spec_fields[.plot_spec_fields != "scale_mode"]
  required[vapply(spec$fields[required], is.null, logical(1))]
}

confirm_plot_spec <- function(spec) {
  missing_fields <- plot_spec_clarifications(spec)
  if (length(missing_fields)) {
    cli::cli_abort(paste0(
      "The plot specification needs clarification for {.field {missing_fields}}"
    ))
  }
  unconfirmed <- setdiff(.plot_spec_fields, names(spec$provenance))
  if (length(unconfirmed)) {
    cli::cli_abort(paste0(
      "The plot specification lacks provenance for {.field {unconfirmed}}"
    ))
  }
  new_plot_spec(
    dataset_id = spec$fields$dataset_id,
    paramcd = spec$fields$paramcd,
    y_variable = spec$fields$y_variable,
    unit = spec$fields$unit,
    treatment_variable = spec$fields$treatment_variable,
    treatment_levels = spec$fields$treatment_levels,
    visits = spec$fields$visits,
    scale_mode = spec$fields$scale_mode,
    provenance = spec$provenance,
    state = "confirmed"
  )
}

.validate_plot_spec <- function(spec) {
  if (!inherits(spec, "plot_spec")) {
    cli::cli_abort("{.arg spec} must be a {.cls plot_spec}")
  }
  invisible(spec)
}

.export_receipt_id <- function(idempotency_key) {
  paste0("receipt-", substr(canonical_hash(idempotency_key), 1L, 24L))
}

.export_actor_roles <- c(
  "clinical_scientist", "statistical_programmer",
  "biostatistician", "export_publisher"
)

.authorize_export_actor <- function(actor) {
  if (!inherits(actor, "submission_sync_actor")) {
    cli::cli_abort("Export authorization requires an authenticated actor")
  }
  if (!isTRUE(actor$active)) {
    cli::cli_abort("The current actor is not active")
  }
  if (!any(actor$roles %in% .export_actor_roles)) {
    cli::cli_abort("The current actor is not authorized to export revisions")
  }
  invisible(TRUE)
}

.assert_exportable_revision <- function(revision, expected_version) {
  if (!identical(as.integer(revision$version), as.integer(expected_version))) {
    cli::cli_abort("The revision token is stale")
  }
  if (!identical(revision$status, "Reviewed")) {
    cli::cli_abort("Only Reviewed revisions can be exported")
  }
  invisible(revision)
}

new_export_service <- function(
  repository,
  artifact_store,
  workspace_provider,
  identity_provider
) {
  .validate_evidence_repository(
    repository,
    c(
      "get_revision", "get_artifact_bundle", "record_export_receipt",
      "list_export_receipts"
    )
  )
  if (!is.list(artifact_store) ||
    !is.function(artifact_store$get) ||
    !is.function(artifact_store$verify)) {
    cli::cli_abort("Export service requires a readable artifact store")
  }
  .validate_workspace_provider(workspace_provider)
  .validate_identity_provider(identity_provider)

  export_revision <- function(
    revision_id,
    actor_id,
    destination_id,
    expected_version,
    idempotency_key
  ) {
    .validate_identifier(revision_id, "revision_id")
    .validate_workspace_token(destination_id, "destination_id")
    .validate_identifier(idempotency_key, "idempotency_key")

    receipt_id <- .export_receipt_id(idempotency_key)
    actor <- identity_provider$get_actor(actor_id)
    .authorize_export_actor(actor)
    revision <- repository$get_revision(revision_id)
    .assert_exportable_revision(revision, expected_version)
    prior <- repository$list_export_receipts(revision_id)
    prior <- prior[prior$receipt_id == receipt_id, , drop = FALSE]
    if (nrow(prior)) {
      prior <- as.list(prior[1, , drop = FALSE])
      if (!identical(prior$destination_id, destination_id)) {
        cli::cli_abort(
          "The idempotency key was already used for a different destination"
        )
      }
      published <- workspace_provider$inspect_published(
        destination_id, receipt_id
      )
      if (is.null(published)) {
        cli::cli_abort("The previously published export is missing")
      }
      if (!identical(published$code_hash, prior$code_hash) ||
        !identical(published$image_hash, prior$image_hash)) {
        cli::cli_abort("Published export hashes do not match the receipt")
      }
      return(invisible(c(
        list(receipt_id = receipt_id, revision_id = revision_id),
        published
      )))
    }
    bundle <- repository$get_artifact_bundle(revision_id)

    code_bytes <- artifact_store$get(bundle$code_hash)
    image_bytes <- artifact_store$get(bundle$image_hash)
    export_id <- receipt_id

    published <- workspace_provider$inspect_published(destination_id, export_id)
    if (is.null(published)) {
      stage <- workspace_provider$stage_bundle(
        destination_id = destination_id,
        export_id = export_id,
        code_bytes = code_bytes,
        image_bytes = image_bytes
      )

      actor <- identity_provider$get_actor(actor_id)
      .authorize_export_actor(actor)
      current <- repository$get_revision(revision_id)
      .assert_exportable_revision(current, expected_version)
      if (!identical(current$code_hash, bundle$code_hash) ||
        !identical(current$image_hash, bundle$image_hash)) {
        workspace_provider$quarantine_staged(stage, "stale-revision")
        cli::cli_abort(
          "The accepted artifact bundle no longer matches the revision"
        )
      }
      published <- workspace_provider$publish_staged(stage)
    }

    if (!identical(published$code_hash, bundle$code_hash) ||
      !identical(published$image_hash, bundle$image_hash)) {
      cli::cli_abort("Published export hashes do not match the accepted bundle")
    }

    repository$record_export_receipt(
      receipt_id = receipt_id,
      revision_id = revision_id,
      destination_id = destination_id,
      code_hash = bundle$code_hash,
      image_hash = bundle$image_hash,
      idempotency_key = idempotency_key
    )
    invisible(c(
      list(receipt_id = receipt_id, revision_id = revision_id),
      published
    ))
  }

  structure(
    list(export_revision = export_revision),
    class = "export_service"
  )
}

local_workspace_provider <- function(destinations) {
  if (is.character(destinations)) {
    roots <- as.list(destinations)
  } else if (is.list(destinations)) {
    roots <- destinations
  } else {
    cli::cli_abort(
      "{.arg destinations} must be a named character vector or list"
    )
  }
  destination_ids <- names(roots)
  if (!length(destination_ids) ||
    any(!nzchar(destination_ids)) ||
    anyDuplicated(destination_ids)) {
    cli::cli_abort(
      "Workspace destinations must have unique logical identifiers"
    )
  }
  lapply(destination_ids, .validate_workspace_token, name = "destination_id")
  roots <- lapply(roots, function(root) {
    checkmate::assert_string(root, min.chars = 1L)
    if (!fs::dir_exists(root)) {
      cli::cli_abort("Workspace root {.path {root}} must already exist")
    }
    fs::path_abs(normalizePath(root, winslash = "/", mustWork = TRUE))
  })

  destination_root <- function(destination_id) {
    .validate_workspace_token(destination_id, "destination_id")
    root <- roots[[destination_id]]
    if (is.null(root)) {
      cli::cli_abort(
        "Workspace destination {.val {destination_id}} is not registered"
      )
    }
    .validate_workspace_root(root)
    root
  }

  export_paths <- function(destination_id, export_id) {
    root <- destination_root(destination_id)
    .validate_workspace_token(export_id, "export_id")
    list(
      root = root,
      staging = fs::path(root, ".staging", export_id),
      final = fs::path(root, export_id),
      quarantine = fs::path(root, ".quarantine")
    )
  }

  stage_bundle <- function(destination_id, export_id, code_bytes, image_bytes) {
    if (!is.raw(code_bytes) || !is.raw(image_bytes)) {
      cli::cli_abort("Workspace bundles must be supplied as raw vectors")
    }
    paths <- export_paths(destination_id, export_id)
    if (fs::dir_exists(paths$staging) || fs::dir_exists(paths$final)) {
      cli::cli_abort("Workspace export {.val {export_id}} already exists")
    }
    fs::dir_create(paths$staging, recurse = TRUE)
    writeBin(code_bytes, fs::path(paths$staging, "script.R"))
    writeBin(image_bytes, fs::path(paths$staging, "plot.png"))
    hashes <- .workspace_pair_hashes(paths$staging)
    writeLines(
      canonical_serialize(list(
        destination_id = destination_id,
        export_id = export_id,
        code_hash = hashes$code_hash,
        image_hash = hashes$image_hash,
        staged_at = .utc_timestamp()
      )),
      fs::path(paths$staging, "manifest.json"),
      useBytes = TRUE
    )
    structure(
      c(
        paths, hashes,
        list(destination_id = destination_id, export_id = export_id)
      ),
      class = "workspace_staged_export"
    )
  }

  publish_staged <- function(stage) {
    if (!inherits(stage, "workspace_staged_export")) {
      cli::cli_abort("{.arg stage} must be a staged workspace export")
    }
    paths <- export_paths(stage$destination_id, stage$export_id)
    if (!fs::dir_exists(paths$staging)) {
      cli::cli_abort(
        "Staged workspace export {.val {stage$export_id}} is missing"
      )
    }
    if (fs::dir_exists(paths$final)) {
      cli::cli_abort("Workspace export {.val {stage$export_id}} already exists")
    }
    hashes <- .workspace_pair_hashes(paths$staging)
    if (is.null(hashes) ||
      !identical(hashes$code_hash, stage$code_hash) ||
      !identical(hashes$image_hash, stage$image_hash)) {
      quarantine_staged(stage, "hash-mismatch")
      cli::cli_abort(
        "Staged workspace export hashes changed before publication"
      )
    }
    fs::file_delete(fs::path(paths$staging, "manifest.json"))
    fs::file_move(paths$staging, paths$final)
    published <- inspect_published(stage$destination_id, stage$export_id)
    if (is.null(published) ||
      !identical(published$code_hash, stage$code_hash) ||
      !identical(published$image_hash, stage$image_hash)) {
      cli::cli_abort(
        "Published workspace export hashes do not match the staged bundle"
      )
    }
    invisible(published)
  }

  inspect_published <- function(destination_id, export_id) {
    paths <- export_paths(destination_id, export_id)
    hashes <- .workspace_pair_hashes(paths$final)
    if (is.null(hashes)) {
      return(NULL)
    }
    c(
      list(
        destination_id = destination_id,
        export_id = export_id,
        path = paths$final,
        code_path = fs::path(paths$final, "script.R"),
        image_path = fs::path(paths$final, "plot.png")
      ),
      hashes
    )
  }

  quarantine_staged <- function(stage, reason = "orphaned") {
    if (!inherits(stage, "workspace_staged_export")) {
      cli::cli_abort("{.arg stage} must be a staged workspace export")
    }
    paths <- export_paths(stage$destination_id, stage$export_id)
    if (!fs::dir_exists(paths$staging)) {
      return(invisible(NULL))
    }
    fs::dir_create(paths$quarantine, recurse = TRUE)
    target <- fs::path(
      paths$quarantine,
      paste(
        stage$export_id,
        substr(canonical_hash(list(reason, .utc_timestamp())), 1L, 12L),
        sep = "-"
      )
    )
    fs::file_move(paths$staging, target)
    invisible(target)
  }

  reconcile <- function(destination_id) {
    root <- destination_root(destination_id)
    staging_root <- fs::path(root, ".staging")
    if (!fs::dir_exists(staging_root)) {
      return(data.frame(
        destination_id = character(),
        export_id = character(),
        action = character(),
        path = character()
      ))
    }
    staged <- fs::dir_ls(staging_root, type = "directory", fail = FALSE)
    results <- lapply(staged, function(path) {
      export_id <- fs::path_file(path)
      .validate_workspace_token(export_id, "export_id")
      stage <- structure(
        c(
          export_paths(destination_id, export_id),
          .workspace_pair_hashes(path) %||% list(
            code_hash = NA_character_, image_hash = NA_character_
          ),
          list(destination_id = destination_id, export_id = export_id)
        ),
        class = "workspace_staged_export"
      )
      quarantine <- quarantine_staged(stage, "reconciled-orphan")
      data.frame(
        destination_id = destination_id,
        export_id = export_id,
        action = "quarantined",
        path = quarantine,
        stringsAsFactors = FALSE
      )
    })
    if (!length(results)) {
      return(data.frame(
        destination_id = character(),
        export_id = character(),
        action = character(),
        path = character()
      ))
    }
    do.call(rbind, results)
  }

  structure(
    list(
      assurance_class = "development-only",
      destinations = roots,
      list_destinations = function() names(roots),
      stage_bundle = stage_bundle,
      publish_staged = publish_staged,
      inspect_published = inspect_published,
      quarantine_staged = quarantine_staged,
      reconcile = reconcile
    ),
    class = c("development_only_workspace_provider", "local_workspace_provider")
  )
}

.validate_workspace_root <- function(root) {
  if (isTRUE(fs::is_link(root))) {
    cli::cli_abort("Workspace roots cannot be symbolic links or reparse points")
  }
  invisible(root)
}

mod_prompt_ui <- function(id) {
  ns <- shiny::NS(id)
  bslib::card(
    class = "assurance-panel",
    bslib::card_header("Prompt and Dataset"),
    bslib::card_body(
      shiny::selectInput(
        ns("dataset_id"), "Synthetic BDS scenario",
        choices = character()
      ),
      shiny::textAreaInput(
        ns("prompt"),
        "Plot request",
        value = "Create a boxplot of ALT AVAL by treatment over all visits.",
        width = "100%",
        rows = 4
      ),
      shiny::checkboxInput(
        ns("confirm_free_scale"),
        paste(
          "I understand free Y scales create an Experimental/Draft revision"
        ),
        value = FALSE
      ),
      .assurance_task_button(
        ns("submit"), "Create revision",
        class = "btn-primary"
      ),
      shiny::uiOutput(ns("message"))
    )
  )
}

mod_prompt_server <- function(id, catalog, create_revision) {
  shiny::moduleServer(id, function(input, output, session) {
    shiny::observe({
      choices <- stats::setNames(catalog()$dataset_id, catalog()$purpose)
      shiny::updateSelectInput(session, "dataset_id", choices = choices)
    })

    message <- shiny::reactiveVal(NULL)
    output$message <- shiny::renderUI({
      text <- message()
      if (is.null(text)) {
        return(NULL)
      }
      div(class = "assurance-message", role = "status", text)
    })

    shiny::observeEvent(input$submit,
      {
        message(NULL)
        tryCatch(
          create_revision(
            dataset_id = input$dataset_id,
            prompt = input$prompt,
            confirm_free_scale = isTRUE(input$confirm_free_scale)
          ),
          error = function(error) {
            message(conditionMessage(error))
          }
        )
      },
      ignoreInit = TRUE
    )
  })
}

.assurance_task_button <- function(input_id, label, ...) {
  task_button <- get0(
    "input_task_button",
    envir = asNamespace("bslib"),
    inherits = FALSE
  )
  if (is.function(task_button)) {
    return(task_button(input_id, label, ...))
  }
  shiny::actionButton(input_id, label, ...)
}

.validate_workspace_provider <- function(provider) {
  capabilities <- c(
    "list_destinations", "stage_bundle", "publish_staged",
    "inspect_published", "quarantine_staged", "reconcile"
  )
  if (!is.list(provider) || !all(vapply(
    capabilities,
    \(capability) is.function(provider[[capability]]),
    logical(1)
  ))) {
    cli::cli_abort(
      "Workspace provider must implement {.fn {capabilities}}"
    )
  }
  invisible(provider)
}

.validate_workspace_token <- function(value, name = "workspace token") {
  reserved <- c(
    "CON", "PRN", "AUX", "NUL",
    paste0("COM", 1:9), paste0("LPT", 1:9)
  )
  if (!checkmate::test_string(value, min.chars = 1L) ||
    !grepl("^[A-Za-z0-9._-]+$", value) ||
    value %in% c(".", "..") ||
    toupper(tools::file_path_sans_ext(value)) %in% reserved) {
    cli::cli_abort("{.arg {name}} must be a safe logical identifier")
  }
  invisible(value)
}

.workspace_pair_hashes <- function(path) {
  code_path <- fs::path(path, "script.R")
  image_path <- fs::path(path, "plot.png")
  if (!fs::file_exists(code_path) || !fs::file_exists(image_path)) {
    return(NULL)
  }
  list(
    code_hash = digest::digest(file = code_path, algo = "sha256"),
    image_hash = digest::digest(file = image_path, algo = "sha256")
  )
}

local_artifact_store <- function(root) {
  checkmate::assert_string(root, min.chars = 1)
  fs::dir_create(root, recurse = TRUE)
  root <- fs::path_abs(root)

  artifact_path <- function(hash) {
    .validate_artifact_hash(hash)
    fs::path(root, substr(hash, 1L, 2L), hash)
  }

  put <- function(bytes) {
    if (!is.raw(bytes)) {
      cli::cli_abort("Artifact content must be a raw vector")
    }
    hash <- digest::digest(bytes, algo = "sha256", serialize = FALSE)
    path <- artifact_path(hash)
    if (fs::file_exists(path)) {
      verify(hash)
    } else {
      fs::dir_create(fs::path_dir(path), recurse = TRUE)
      temporary <- fs::file_temp(
        tmp_dir = fs::path_dir(path),
        pattern = "artifact-"
      )
      writeBin(bytes, temporary)
      if (!identical(digest::digest(file = temporary, algo = "sha256"), hash)) {
        fs::file_delete(temporary)
        cli::cli_abort("Artifact hash verification failed before publication")
      }
      if (!fs::file_exists(path)) {
        fs::file_move(temporary, path)
      } else {
        fs::file_delete(temporary)
      }
    }
    hash
  }

  get <- function(hash) {
    path <- artifact_path(hash)
    if (!fs::file_exists(path)) {
      cli::cli_abort("Artifact {.val {hash}} does not exist")
    }
    verify(hash)
    readBin(path, what = "raw", n = fs::file_size(path))
  }

  verify <- function(hash) {
    path <- artifact_path(hash)
    if (!fs::file_exists(path) ||
      !identical(digest::digest(file = path, algo = "sha256"), hash)) {
      cli::cli_abort("Artifact hash verification failed for {.val {hash}}")
    }
    TRUE
  }

  exists <- function(hash) unname(fs::file_exists(artifact_path(hash)))

  cleanup_orphans <- function(referenced_hashes, minimum_age_seconds) {
    if (!is.character(referenced_hashes)) {
      cli::cli_abort("Referenced artifact hashes must be a character vector")
    }
    if (length(referenced_hashes)) {
      invisible(lapply(referenced_hashes, .validate_artifact_hash))
    }
    files <- fs::dir_ls(root, recurse = TRUE, type = "file", fail = FALSE)
    relative <- fs::path_rel(files, start = root)
    components <- strsplit(relative, "[/\\\\]")
    is_artifact <- vapply(components, function(parts) {
      length(parts) == 2L &&
        grepl("^[0-9a-f]{2}$", parts[[1]]) &&
        grepl("^[0-9a-f]{64}$", parts[[2]]) &&
        identical(parts[[1]], substr(parts[[2]], 1L, 2L))
    }, logical(1))
    artifact_paths <- files[is_artifact]
    orphan_paths <- artifact_paths[
      !fs::path_file(artifact_paths) %in% referenced_hashes
    ]
    if (length(orphan_paths)) {
      age_seconds <- as.numeric(
        difftime(
          Sys.time(),
          fs::file_info(orphan_paths)$modification_time,
          units = "secs"
        )
      )
      orphan_paths <- orphan_paths[age_seconds >= minimum_age_seconds]
    }
    orphan_hashes <- fs::path_file(orphan_paths)
    if (length(orphan_paths)) fs::file_delete(orphan_paths)
    orphan_hashes
  }

  structure(
    list(
      root = fs::path_abs(root), put = put, get = get, verify = verify,
      exists = exists, path = artifact_path, .cleanup_orphans = cleanup_orphans
    ),
    class = "local_artifact_store"
  )
}

.new_profile_diagnostic <- function(
  code,
  message,
  count = NULL,
  integrity_ref = NULL
) {
  compact <- list(code = code, message = message)
  if (!is.null(count)) compact$count <- as.integer(count)
  if (!is.null(integrity_ref)) compact$integrity_ref <- integrity_ref
  compact
}

.resolve_low_n_policy <- function(low_n_threshold) {
  if (is.numeric(low_n_threshold) && length(low_n_threshold) == 1L &&
    !is.na(low_n_threshold) && identical(as.numeric(low_n_threshold), 5)) {
    return(list(
      value = 5,
      rationale = "Assurance Cell default",
      authority = "plot-pattern-assurance-cell-v1",
      version = "low-n-default-v1"
    ))
  }
  required <- c("value", "rationale", "authority", "version")
  valid <- is.list(low_n_threshold) &&
    identical(sort(names(low_n_threshold)), sort(required)) &&
    checkmate::test_number(low_n_threshold$value, lower = 1, finite = TRUE) &&
    all(vapply(
      low_n_threshold[required[-1]],
      checkmate::test_string,
      logical(1),
      min.chars = 1L
    ))
  if (!valid) {
    cli::cli_abort(
      paste0(
        "A non-default low-N threshold requires sponsor-approved value, ",
        "rationale, authority, and version"
      )
    )
  }
  low_n_threshold$value <- as.numeric(low_n_threshold$value)
  low_n_threshold
}

.profile_result <- function(snapshot, selections, choices, policy) {
  structure(
    list(
      profile_version = "visit-based-numeric-bds-v1",
      snapshot_id = snapshot$snapshot_id,
      snapshot_hash = snapshot$content_hash,
      blocked = FALSE,
      dataset_conformance = "not_assessed",
      selections = selections,
      choices = choices,
      facet_levels = choices$included_treatment_levels,
      visit_levels = choices$included_visits,
      low_n_policy = policy,
      selected_data = data.frame(),
      analysis_data = data.frame(),
      display_data = data.frame(),
      counts = data.frame(),
      blocking_diagnostics = list(),
      warnings = list(),
      authorized_diagnostics = list(),
      durable_diagnostics = list(),
      analytical_input_hash = NULL
    ),
    class = "bds_profile_result"
  )
}

.block_profile <- function(result, diagnostic, authorized = list()) {
  result$blocked <- TRUE
  result$blocking_diagnostics <- list(diagnostic)
  result$durable_diagnostics <- list(diagnostic)
  result$authorized_diagnostics <- authorized
  result
}

.sort_profile_data <- function(data, treatment_variable) {
  columns <- intersect(
    c(treatment_variable, "AVISITN", "AVISIT", "USUBJID", "PARAMCD"),
    names(data)
  )
  ordering <- do.call(
    order,
    c(data[columns], list(method = "radix", na.last = TRUE))
  )
  result <- data[ordering, , drop = FALSE]
  row.names(result) <- NULL
  result
}

.minimize_analysis_data <- function(data, treatment_variable, y_variable) {
  result <- data[
    unique(c(
      "USUBJID", "AVISIT", "AVISITN", treatment_variable, y_variable
    ))
  ]
  subject_ids <- sort(unique(as.character(result$USUBJID)), method = "radix")
  prefix <- "SUBJ"
  repeat {
    pseudonyms <- sprintf("%s-%06d", prefix, seq_along(subject_ids))
    if (!any(pseudonyms %in% subject_ids)) break
    prefix <- paste0("PSEUDO-", prefix)
  }
  names(pseudonyms) <- subject_ids
  result$USUBJID <- unname(pseudonyms[as.character(result$USUBJID)])
  result
}

.validate_profile_inputs <- function(snapshot, selections) {
  if (!inherits(snapshot, "study_data_snapshot")) {
    cli::cli_abort("{.arg snapshot} must be a {.cls study_data_snapshot}")
  }
  required <- c(
    "paramcd", "y_variable", "unit", "treatment_variable",
    "treatment_levels", "visits"
  )
  if (!is.list(selections) || !setequal(names(selections), required)) {
    cli::cli_abort(paste0(
      "{.arg selections} must contain the complete visit-based ",
      "BDS selection fields"
    ))
  }
  if (!checkmate::test_string(selections$paramcd, min.chars = 1L) ||
    !checkmate::test_choice(
      selections$y_variable,
      c("AVAL", "CHG", "PCHG")
    ) ||
    !checkmate::test_string(
      selections$treatment_variable,
      min.chars = 1L
    )) {
    cli::cli_abort(paste0(
      "The parameter, Y variable, and treatment selections must each be ",
      "singular and valid"
    ))
  }
  invisible(TRUE)
}

#' Validate the supported visit-based numeric BDS profile
#'
#' Explicit parameter, unit, treatment, and visit selections are applied before
#' visit-key and selected-Y checks. Blocking diagnostics are separated from
#' nonblocking sparse-data warnings.
#'
#' @param snapshot A pinned `study_data_snapshot`.
#' @param selections A complete list containing `paramcd`, `y_variable`, `unit`,
#'   `treatment_variable`, `treatment_levels`, and `visits`.
#' @param low_n_threshold The default value `5`, or a sponsor-approved list with
#'   `value`, `rationale`, `authority`, and `version`.
#'
#' @return A deterministic `bds_profile_result`.
#' @export
validate_bds_profile <- function(snapshot, selections, low_n_threshold = 5) {
  .validate_profile_inputs(snapshot, selections)
  policy <- .resolve_low_n_policy(low_n_threshold)
  data <- snapshot$data
  treatment <- selections$treatment_variable
  y <- selections$y_variable
  choices <- list(
    parameters = sort(
      unique(stats::na.omit(as.character(data$PARAMCD))),
      method = "radix"
    ),
    y_variables = intersect(c("AVAL", "CHG", "PCHG"), names(data)),
    units = character(),
    treatment_variables = snapshot$permitted_treatment_variables,
    treatment_levels = character(),
    visits = character(),
    included_treatment_levels = character(),
    included_visits = character()
  )
  result <- .profile_result(snapshot, selections, choices, policy)

  classification_allowed <- if (is.null(snapshot$classification)) {
    identical(snapshot$source_metadata$source, "direct_upload")
  } else {
    snapshot$classification %in% c("public", "synthetic", "deidentified")
  }
  if (!classification_allowed ||
    !identical(snapshot$adam_designation, "BDS")) {
    return(.block_profile(result, .new_profile_diagnostic(
      "unsupported_source_metadata",
      paste0(
        "The authorized source is outside the permitted BDS profile ",
        "metadata envelope"
      )
    )))
  }
  required_columns <- unique(c(
    "USUBJID", "PARAMCD", "AVISIT", "AVISITN", y, treatment,
    if ("AVALU" %in% names(data)) "AVALU"
  ))
  missing_columns <- setdiff(required_columns, names(data))
  if (length(missing_columns)) {
    return(.block_profile(result, .new_profile_diagnostic(
      "missing_required_variables",
      paste0(
        "The selected source lacks variables required by the supported ",
        "BDS profile"
      ),
      length(missing_columns),
      canonical_hash(sort(missing_columns, method = "radix"))
    )))
  }
  if (!treatment %in% snapshot$permitted_treatment_variables) {
    return(.block_profile(result, .new_profile_diagnostic(
      "treatment_not_permitted",
      paste0(
        "The selected treatment variable is not permitted by the ",
        "authorized catalog"
      )
    )))
  }
  if (!selections$paramcd %in% choices$parameters) {
    return(.block_profile(result, .new_profile_diagnostic(
      "parameter_not_available",
      "The selected parameter is not present in the authorized snapshot"
    )))
  }
  if (!is.numeric(data[[y]])) {
    return(.block_profile(result, .new_profile_diagnostic(
      "selected_y_not_numeric",
      "The selected Y variable must be numeric for this BDS profile"
    )))
  }

  selected <- data[
    data$PARAMCD == selections$paramcd & !is.na(data$PARAMCD), ,
    drop = FALSE
  ]
  units <- if ("AVALU" %in% names(selected)) {
    sort(unique(stats::na.omit(as.character(selected$AVALU))), method = "radix")
  } else {
    character()
  }
  result$choices$units <- units
  if (length(units) > 1L && is.null(selections$unit)) {
    return(.block_profile(result, .new_profile_diagnostic(
      "unit_selection_required",
      "Multiple non-missing units require one explicit unit selection",
      length(units),
      canonical_hash(units)
    )))
  }
  if (!is.null(selections$unit)) {
    if (!checkmate::test_string(selections$unit, min.chars = 1L) ||
      !selections$unit %in% units) {
      return(.block_profile(result, .new_profile_diagnostic(
        "unit_not_available",
        "The selected unit is not present for the selected parameter"
      )))
    }
    selected <- selected[
      !is.na(selected$AVALU) & selected$AVALU == selections$unit, ,
      drop = FALSE
    ]
  }

  missing_subject <- is.na(selected$USUBJID) |
    !nzchar(as.character(selected$USUBJID))
  if (any(missing_subject)) {
    return(.block_profile(result, .new_profile_diagnostic(
      "missing_profile_key",
      "The selected records contain a missing supported-profile key value",
      sum(missing_subject),
      canonical_hash(list(
        snapshot_id = snapshot$snapshot_id,
        count = sum(missing_subject)
      ))
    )))
  }
  missing_treatment <- is.na(selected[[treatment]]) |
    !nzchar(as.character(selected[[treatment]]))
  if (any(missing_treatment)) {
    return(.block_profile(result, .new_profile_diagnostic(
      "missing_treatment_value",
      paste0(
        "The selected records contain a missing treatment value required ",
        "for faceting"
      ),
      sum(missing_treatment),
      canonical_hash(list(
        snapshot_id = snapshot$snapshot_id,
        count = sum(missing_treatment)
      ))
    )))
  }

  treatment_levels <- sort(
    unique(stats::na.omit(as.character(selected[[treatment]]))),
    method = "radix"
  )
  result$choices$treatment_levels <- treatment_levels
  included_treatments <- selections$treatment_levels
  if (is.null(included_treatments)) included_treatments <- treatment_levels
  if (!checkmate::test_character(
    included_treatments,
    any.missing = FALSE,
    unique = TRUE
  ) ||
    length(setdiff(included_treatments, treatment_levels))) {
    return(.block_profile(result, .new_profile_diagnostic(
      "treatment_level_not_available",
      paste0(
        "Every included treatment level must be present in the ",
        "authorized snapshot"
      )
    )))
  }
  included_treatments <- treatment_levels[
    treatment_levels %in% included_treatments
  ]
  selected <- selected[
    !is.na(selected[[treatment]]) &
      selected[[treatment]] %in% included_treatments, ,
    drop = FALSE
  ]

  available_visits <- unique(data.frame(
    AVISIT = as.character(selected$AVISIT),
    AVISITN = selected$AVISITN,
    stringsAsFactors = FALSE
  ))
  requested_visits <- selections$visits
  if (!is.null(requested_visits)) {
    if (!checkmate::test_character(
      requested_visits,
      any.missing = FALSE,
      unique = TRUE
    )) {
      return(.block_profile(result, .new_profile_diagnostic(
        "visit_not_available",
        "Included visits must be unique non-missing labels"
      )))
    }
    selected <- selected[
      is.na(selected$AVISIT) | selected$AVISIT %in% requested_visits, ,
      drop = FALSE
    ]
    available_visits <- available_visits[
      !is.na(available_visits$AVISIT) &
        available_visits$AVISIT %in% requested_visits, ,
      drop = FALSE
    ]
  }

  mapping_missing <- any(
    is.na(selected$AVISIT) |
      !nzchar(as.character(selected$AVISIT)) |
      is.na(selected$AVISITN)
  )
  label_counts <- tapply(
    selected$AVISITN,
    selected$AVISIT,
    function(x) length(unique(x[!is.na(x)]))
  )
  order_counts <- tapply(
    as.character(selected$AVISIT),
    selected$AVISITN,
    function(x) length(unique(x[!is.na(x)]))
  )
  mapping_conflict <- any(label_counts != 1L) || any(order_counts != 1L)
  if (mapping_missing || mapping_conflict) {
    mapping_ref <- canonical_hash(list(
      missing_count = sum(is.na(selected$AVISIT) | is.na(selected$AVISITN)),
      mappings = .normalize_study_data(available_visits)
    ))
    return(.block_profile(result, .new_profile_diagnostic(
      "invalid_visit_mapping",
      paste0(
        "The selected AVISIT and AVISITN mapping does not provide a ",
        "deterministic visit order"
      ),
      nrow(selected),
      mapping_ref
    )))
  }

  mapping <- unique(selected[c("AVISIT", "AVISITN")])
  mapping <- mapping[
    order(mapping$AVISITN, mapping$AVISIT, method = "radix"), ,
    drop = FALSE
  ]
  available_visit_labels <- as.character(mapping$AVISIT)
  if (!is.null(requested_visits) &&
    length(setdiff(requested_visits, available_visit_labels))) {
    return(.block_profile(result, .new_profile_diagnostic(
      "visit_not_available",
      paste0(
        "Every included visit must be present after explicit parameter, ",
        "unit, and treatment selections"
      )
    )))
  }
  included_visits <- available_visit_labels
  result$choices$visits <- available_visit_labels
  result$choices$included_treatment_levels <- included_treatments
  result$choices$included_visits <- included_visits
  result$facet_levels <- included_treatments
  result$visit_levels <- included_visits

  key_columns <- c("USUBJID", "PARAMCD", "AVISIT")
  duplicate_rows <- duplicated(selected[key_columns]) |
    duplicated(selected[key_columns], fromLast = TRUE)
  if (any(duplicate_rows)) {
    duplicate_keys <- unique(selected[
      duplicate_rows, key_columns,
      drop = FALSE
    ])
    duplicate_keys <- .sort_profile_data(duplicate_keys, "PARAMCD")
    additional_keys <- setdiff(snapshot$declared_keys, c(
      "STUDYID", "USUBJID", "PARAMCD", "AVISIT", "AVISITN"
    ))
    code <- if (length(additional_keys)) {
      "unsupported_additional_timepoint_keys"
    } else {
      "unsupported_duplicate_visit_key"
    }
    message <- if (length(additional_keys)) {
      paste0(
        "The ADaM source declares additional legitimate keys and is ",
        "unsupported by this visit-based cell"
      )
    } else {
      paste0(
        "Duplicate subject-parameter-visit keys are unsupported by this ",
        "visit-based cell"
      )
    }
    diagnostic <- .new_profile_diagnostic(
      code,
      message,
      nrow(duplicate_keys),
      canonical_hash(.normalize_study_data(duplicate_keys))
    )
    return(.block_profile(
      result,
      diagnostic,
      list(duplicate_keys = duplicate_keys, additional_keys = additional_keys)
    ))
  }

  selected <- .sort_profile_data(selected, treatment)
  display <- selected[!is.na(selected[[y]]), , drop = FALSE]
  display <- .sort_profile_data(display, treatment)
  if (nrow(display)) {
    groups <- split(
      seq_len(nrow(display)),
      interaction(
        display[[treatment]], display$AVISIT,
        drop = TRUE, lex.order = TRUE
      )
    )
    count_rows <- lapply(groups, function(index) {
      rows <- display[index, , drop = FALSE]
      source_rows <- selected[
        selected[[treatment]] == rows[[treatment]][1] &
          selected$AVISIT == rows$AVISIT[1], ,
        drop = FALSE
      ]
      data.frame(
        treatment_value = as.character(rows[[treatment]][1]),
        AVISIT = as.character(rows$AVISIT[1]),
        AVISITN = rows$AVISITN[1],
        source_n = length(unique(source_rows$USUBJID)),
        n = length(unique(rows$USUBJID)),
        stringsAsFactors = FALSE
      )
    })
    counts <- do.call(rbind, count_rows)
    names(counts)[1] <- treatment
    counts$source_n <- as.integer(counts$source_n)
    counts$n <- as.integer(counts$n)
    counts$low_n <- counts$n < policy$value
    counts <- counts[
      order(counts[[treatment]], counts$AVISITN, method = "radix"), ,
      drop = FALSE
    ]
    row.names(counts) <- NULL
  } else {
    counts <- data.frame()
  }

  all_combinations <- expand.grid(
    treatment_value = included_treatments,
    AVISIT = included_visits,
    stringsAsFactors = FALSE
  )
  displayed_keys <- if (nrow(counts)) {
    paste(counts[[treatment]], counts$AVISIT, sep = "\u001f")
  } else {
    character()
  }
  empty_combinations <- all_combinations[
    !paste(
      all_combinations$treatment_value,
      all_combinations$AVISIT,
      sep = "\u001f"
    ) %in% displayed_keys, ,
    drop = FALSE
  ]
  warnings <- list()
  if (nrow(counts) && any(counts$low_n)) {
    sparse <- counts[
      counts$low_n, c(treatment, "AVISIT", "AVISITN", "n"),
      drop = FALSE
    ]
    warnings[[length(warnings) + 1L]] <- .new_profile_diagnostic(
      "low_sample_size",
      paste0(
        "One or more displayed treatment-visit boxes are below the ",
        "retained low-N threshold"
      ),
      nrow(sparse),
      canonical_hash(sparse)
    )
  }
  if (nrow(empty_combinations)) {
    warnings[[length(warnings) + 1L]] <- .new_profile_diagnostic(
      "empty_treatment_visit",
      paste0(
        "One or more included treatment-visit combinations have no ",
        "non-missing selected Y value"
      ),
      nrow(empty_combinations),
      canonical_hash(empty_combinations)
    )
  }
  empty_treatments <- setdiff(
    included_treatments,
    unique(as.character(display[[treatment]]))
  )
  if (length(empty_treatments)) {
    warnings[[length(warnings) + 1L]] <- .new_profile_diagnostic(
      "empty_treatment_level",
      "One or more included treatment levels remain as empty facets",
      length(empty_treatments),
      canonical_hash(empty_treatments)
    )
  }

  result$selected_data <- selected
  result$analysis_data <- .minimize_analysis_data(selected, treatment, y)
  result$display_data <- display
  result$counts <- counts
  result$warnings <- warnings
  result$durable_diagnostics <- warnings
  result$analytical_input_hash <- canonical_hash(list(
    data = .normalize_study_data(display),
    selections = selections,
    facet_levels = result$facet_levels,
    visit_levels = result$visit_levels,
    low_n_policy = policy
  ))
  result
}

new_execution_request <- function(
  spec,
  script_hash,
  snapshot_id,
  snapshot_hash,
  harness_version
) {
  .validate_plot_spec(spec)
  values <- list(script_hash, snapshot_id, snapshot_hash, harness_version)
  if (!all(vapply(values, checkmate::test_string, logical(1), min.chars = 1))) {
    cli::cli_abort(paste0(
      "Execution requests require non-empty script, snapshot, ",
      "and harness identifiers"
    ))
  }
  structure(
    list(
      manifest_version = "execution-request-v1",
      spec_hash = spec$hash,
      script_hash = script_hash,
      snapshot_id = snapshot_id,
      snapshot_hash = snapshot_hash,
      harness_version = harness_version
    ),
    class = "execution_request"
  )
}

new_execution_result <- function(
  request,
  analytical_hash,
  image_hash,
  environment_fingerprint
) {
  if (!inherits(request, "execution_request")) {
    cli::cli_abort("{.arg request} must be an {.cls execution_request}")
  }
  values <- list(analytical_hash, image_hash, environment_fingerprint)
  if (!all(vapply(values, checkmate::test_string, logical(1), min.chars = 1))) {
    cli::cli_abort(paste0(
      "Execution results require analytical, image, ",
      "and environment identifiers"
    ))
  }
  manifest <- unclass(request)
  manifest$manifest_version <- "execution-result-v1"
  structure(
    c(manifest, list(
      analytical_hash = analytical_hash,
      image_hash = image_hash,
      environment_fingerprint = environment_fingerprint
    )),
    class = "execution_result"
  )
}

.execution_hash_text <- function(value) {
  digest::digest(
    .execution_text_bytes(value),
    algo = "sha256",
    serialize = FALSE
  )
}

.execution_text_bytes <- function(value) {
  charToRaw(enc2utf8(paste(value, collapse = "\n")))
}

.execution_hash_file <- function(path) {
  digest::digest(file = path, algo = "sha256")
}

.bounded_text <- function(value, limit = 4000L) {
  value <- paste(value, collapse = "\n")
  if (nchar(value, type = "bytes") <= limit) {
    return(value)
  }
  paste0(substr(value, 1L, limit), "\n[truncated]")
}

.execution_environment_details <- function() {
  packages <- c(
    ADaMViz.SubmissionSync = utils::packageVersion("ADaMViz.SubmissionSync"),
    ggplot2 = utils::packageVersion("ggplot2"),
    patchwork = utils::packageVersion("patchwork")
  )
  list(
    version = "execution-environment-details-v1",
    r_version = as.character(getRversion()),
    platform = R.version$platform,
    os = Sys.info()[["sysname"]],
    release = Sys.info()[["release"]],
    packages = lapply(packages, as.character),
    graphics_device = "png",
    image_width = NA_integer_,
    image_height = NA_integer_
  )
}

.environment_fingerprint <- function() {
  canonical_hash(.execution_environment_details()) # nolint: object_usage_linter.
}

.validate_execution_input <- function(
  request,
  script,
  analysis_data,
  data_classification
) {
  if (!inherits(request, "execution_request")) {
    cli::cli_abort("{.arg request} must be an {.cls execution_request}")
  }
  if (!checkmate::test_string(script, min.chars = 1L)) {
    cli::cli_abort("{.arg script} must be a non-empty R script")
  }
  if (!is.data.frame(analysis_data)) {
    cli::cli_abort("{.arg analysis_data} must be a data frame")
  }
  if (!data_classification %in% c("synthetic", "deidentified")) {
    cli::cli_abort(paste0(
      "The local POC runner accepts only synthetic or de-identified data"
    ))
  }
  script_hash <- .execution_hash_text(script)
  if (!identical(script_hash, request$script_hash)) {
    cli::cli_abort("Execution script hash does not match the immutable request")
  }
  snapshot_hash <- canonical_hash(analysis_data) # nolint: object_usage_linter.
  if (!identical(snapshot_hash, request$snapshot_hash)) {
    cli::cli_abort("Execution data hash does not match the immutable request")
  }
  invisible(TRUE)
}

run_execution_locally <- function(
  request,
  script,
  analysis_data,
  data_classification = "synthetic",
  work_dir = tempfile("execution-run-"),
  image_width = 1200,
  image_height = 840,
  diagnostics_limit = 4000L
) {
  .validate_execution_input(request, script, analysis_data, data_classification)
  checkmate::assert_string(work_dir, min.chars = 1L)
  checkmate::assert_number(image_width, lower = 1, finite = TRUE)
  checkmate::assert_number(image_height, lower = 1, finite = TRUE)
  checkmate::assert_int(diagnostics_limit, lower = 256L)

  fs::dir_create(work_dir, recurse = TRUE)
  env <- new.env(parent = globalenv())
  env$analysis_data <- analysis_data
  script_path <- fs::path(work_dir, "script.R")
  image_path <- fs::path(work_dir, "plot.png")
  writeLines(enc2utf8(script), script_path, useBytes = TRUE)

  stdout <- character()
  result <- tryCatch(
    {
      stdout <- utils::capture.output(
        sys.source(script_path, envir = env, keep.source = FALSE),
        type = "output"
      )
      if (!inherits(env$boxplot_analysis, "boxplot_analysis") ||
        !inherits(env$boxplot_artifact, "boxplot_artifact")) {
        cli::cli_abort(
          "Execution script did not create the governed runtime objects"
        )
      }
      ggplot2::ggsave(
        filename = image_path,
        plot = env$boxplot_artifact$combined,
        device = function(...) {
          grDevices::png(..., units = "in", res = 100, type = "cairo")
        },
        width = image_width / 100,
        height = image_height / 100,
        dpi = 100,
        units = "in"
      )
      if (!fs::file_exists(image_path) || fs::file_size(image_path) <= 0) {
        cli::cli_abort("Execution did not produce a non-empty PNG image")
      }
      list(error = NULL)
    },
    error = function(error) {
      list(error = conditionMessage(error))
    }
  )

  if (!is.null(result$error)) {
    return(structure(
      list(
        status = "failed",
        manifest_version = "execution-runner-result-v1",
        diagnostics = list(
          stdout = .bounded_text(stdout, diagnostics_limit),
          stderr = .bounded_text(result$error, diagnostics_limit)
        )
      ),
      class = "execution_runner_result"
    ))
  }

  analytical_hash <- canonical_hash(env$boxplot_analysis) # nolint: object_usage_linter.
  image_hash <- .execution_hash_file(image_path)
  environment <- .execution_environment_details()
  environment$image_width <- image_width
  environment$image_height <- image_height
  environment_fingerprint <- canonical_hash(environment) # nolint: object_usage_linter.
  manifest <- new_execution_result( # nolint: object_usage_linter.
    request,
    analytical_hash = analytical_hash,
    image_hash = image_hash,
    environment_fingerprint = environment_fingerprint
  )
  structure(
    list(
      status = "succeeded",
      manifest_version = "execution-runner-result-v1",
      result = manifest,
      analytical_output = env$boxplot_analysis,
      image_path = image_path,
      code_hash = request$script_hash,
      environment = environment,
      diagnostics = list(
        stdout = .bounded_text(stdout, diagnostics_limit),
        stderr = ""
      )
    ),
    class = "execution_runner_result"
  )
}

new_execution_runner <- function(run = run_execution_locally) {
  if (!is.function(run)) cli::cli_abort("{.arg run} must be a function")
  structure(list(run = run), class = "execution_runner")
}

#' Create the injected runtime configuration provider.
#'
#' Runtime configuration contains provider identifiers and logical references,
#' never secret values. Secret material is resolved only through the injected
#' provider when a domain service explicitly requests it.
#'
#' @param profile Runtime profile: `local`, `test`, or `production`.
#' @param prompt_provider Logical prompt-provider identifier.
#' @param workspace Logical workspace identifier.
#' @param evidence_root Directory containing durable revision evidence and
#'   artifacts.
#' @param secret_provider Function accepting a secret reference and returning
#'   its value, or `NULL` when unavailable.
#' @param required_secret_references Character vector of required references.
#' @return An object of class `submission_sync_runtime_config`.
#' @importFrom cli cli_abort
#' @export
new_runtime_config <- function(
  profile = Sys.getenv("ADAMVIZ_PROFILE", "local"),
  prompt_provider = Sys.getenv("ADAMVIZ_PROMPT_PROVIDER", "mock"),
  workspace = Sys.getenv("ADAMVIZ_WORKSPACE", "local"),
  evidence_root = Sys.getenv(
    "ADAMVIZ_EVIDENCE_ROOT",
    fs::path(
      tools::R_user_dir("ADaMViz.SubmissionSync", which = "data"),
      "evidence"
    )
  ),
  secret_provider = NULL,
  required_secret_references = character()
) {
  profiles <- c("local", "test", "production")
  if (!checkmate::test_choice(profile, choices = profiles)) {
    cli::cli_abort("{.arg profile} must be one of {.val {profiles}}")
  }
  if (!checkmate::test_string(prompt_provider, min.chars = 1)) {
    cli::cli_abort("{.arg prompt_provider} must be one non-empty identifier")
  }
  if (!checkmate::test_string(workspace, min.chars = 1)) {
    cli::cli_abort("{.arg workspace} must be one non-empty identifier")
  }
  if (!checkmate::test_string(evidence_root, min.chars = 1)) {
    cli::cli_abort("{.arg evidence_root} must be one non-empty path")
  }
  if (profile != "production" && identical(prompt_provider, "production")) {
    cli::cli_abort(c(
      "A production provider cannot be selected outside the production profile",
      "i" = "Use {.val mock} for local and test profiles."
    ))
  }
  if (!checkmate::test_null(secret_provider) &&
    !checkmate::test_function(secret_provider)) {
    cli::cli_abort("{.arg secret_provider} must be a function or {.val NULL}")
  }
  if (!checkmate::test_character(
    required_secret_references,
    any.missing = FALSE
  )) {
    cli::cli_abort(
      "{.arg required_secret_references} must contain character values"
    )
  }

  config <- structure(
    list(
      profile = profile,
      prompt_provider = prompt_provider,
      workspace = workspace,
      evidence_root = as.character(fs::path_abs(evidence_root)),
      required_secret_references = unique(required_secret_references),
      secret_provider = secret_provider
    ),
    class = "submission_sync_runtime_config"
  )

  for (reference in config$required_secret_references) {
    if (is.null(config$secret_provider)) {
      cli::cli_abort("Secret reference {.val {reference}} is not configured")
    }
    value <- config$secret_provider(reference)
    if (is.null(value) || length(value) != 1L || !nzchar(value)) {
      cli::cli_abort("Secret reference {.val {reference}} is not configured")
    }
  }

  config
}

#' Resolve one runtime secret through the injected provider.
#'
#' @param runtime_config A `submission_sync_runtime_config` object.
#' @param reference Logical secret reference.
#' @return The resolved secret value.
#' @export
resolve_runtime_secret <- function(runtime_config, reference) {
  if (!checkmate::test_class(
    runtime_config,
    classes = "submission_sync_runtime_config"
  )) {
    cli::cli_abort(
      "{.arg runtime_config} must be a {.cls submission_sync_runtime_config}"
    )
  }
  if (!checkmate::test_string(reference, min.chars = 1)) {
    cli::cli_abort("{.arg reference} must be one non-empty identifier")
  }
  if (is.null(runtime_config$secret_provider)) {
    cli::cli_abort("Secret reference {.val {reference}} is not configured")
  }
  value <- runtime_config$secret_provider(reference)
  if (is.null(value) || length(value) != 1L || !nzchar(value)) {
    cli::cli_abort("Secret reference {.val {reference}} is not configured")
  }
  value
}

.factor_boxplot_layers <- function(analysis) {
  layers <- analysis[c("boxes", "outliers", "medians", "n_strip")]
  layers <- lapply(layers, function(data) {
    data$treatment <- factor(data$treatment, levels = analysis$facet_levels)
    data$visit <- factor(data$visit, levels = analysis$visit_levels)
    data
  })
  layers
}

#' Assemble the governed boxplot and aligned N strip
#'
#' Uses the independent analytical object as identity statistics, preserving
#' treatment facets and global visit positions in both panels.
#'
#' @param analysis A `boxplot_analysis` object.
#' @param scale_mode Either `"fixed"` or `"free"` for facet Y scales.
#' @param unit Optional selected unit appended to the Y-axis label.
#'
#' @return A `boxplot_artifact` containing plot, N strip, composition, and data.
#' @export
assemble_boxplot <- function(
  analysis,
  scale_mode = c("fixed", "free"),
  unit = NULL
) {
  if (!inherits(analysis, "boxplot_analysis")) {
    cli::cli_abort("{.arg analysis} must be a {.cls boxplot_analysis}")
  }
  scale_mode <- match.arg(scale_mode)
  plot_data <- .factor_boxplot_layers(analysis)
  y_label <- if (is.null(unit) || !nzchar(unit)) {
    analysis$y_variable
  } else {
    paste0(analysis$y_variable, " (", unit, ")")
  }
  facet_scales <- if (identical(scale_mode, "free")) "free_y" else "fixed"

  plot <- ggplot2::ggplot(
    plot_data$boxes,
    ggplot2::aes(
      x = visit,
      ymin = ymin,
      lower = lower,
      middle = middle,
      upper = upper,
      ymax = ymax
    )
  ) +
    ggplot2::geom_boxplot(
      stat = "identity", outlier.shape = NA, fill = "white",
      color = "black", linewidth = 0.6
    ) +
    ggplot2::geom_line(
      data = plot_data$medians,
      mapping = ggplot2::aes(x = visit, y = median, group = treatment),
      inherit.aes = FALSE,
      linewidth = 0.8,
      color = "black"
    ) +
    ggplot2::geom_point(
      data = plot_data$medians,
      mapping = ggplot2::aes(x = visit, y = median),
      inherit.aes = FALSE,
      shape = 21,
      size = 3,
      fill = "white",
      color = "black",
      stroke = 1.2
    ) +
    ggplot2::geom_point(
      data = plot_data$outliers,
      mapping = ggplot2::aes(x = visit, y = value),
      inherit.aes = FALSE,
      shape = 1,
      size = 2.5,
      color = "black",
      stroke = 1
    ) +
    ggplot2::facet_wrap(
      ggplot2::vars(treatment),
      scales = facet_scales,
      drop = FALSE
    ) +
    ggplot2::scale_x_discrete(drop = FALSE, limits = analysis$visit_levels) +
    ggplot2::labs(x = NULL, y = y_label) +
    ggplot2::theme_bw(base_size = 12) +
    ggplot2::theme(
      text = ggplot2::element_text(face = "bold"),
      panel.border = ggplot2::element_rect(
        color = "black", fill = NA, linewidth = 1
      ),
      panel.grid.major = ggplot2::element_line(
        color = "grey90", linewidth = 0.3
      ),
      panel.grid.minor = ggplot2::element_blank(),
      axis.text = ggplot2::element_text(face = "bold", color = "black"),
      axis.text.x = ggplot2::element_blank(),
      axis.ticks.x = ggplot2::element_blank(),
      strip.background = ggplot2::element_rect(
        fill = "grey85", color = "black", linewidth = 1
      ),
      strip.text = ggplot2::element_text(face = "bold", color = "black")
    )

  n_strip <- ggplot2::ggplot(
    plot_data$n_strip,
    ggplot2::aes(x = visit, y = 1, label = label)
  ) +
    ggplot2::geom_text(
      na.rm = TRUE, size = 4, color = "black", fontface = "bold"
    ) +
    ggplot2::facet_wrap(ggplot2::vars(treatment), drop = FALSE) +
    ggplot2::scale_x_discrete(drop = FALSE, limits = analysis$visit_levels) +
    ggplot2::scale_y_continuous(limits = c(0.5, 1.5)) +
    ggplot2::labs(x = "Analysis Visit", y = NULL) +
    ggplot2::theme_bw(base_size = 12) +
    ggplot2::theme(
      text = ggplot2::element_text(face = "bold"),
      panel.border = ggplot2::element_rect(
        color = "black", fill = NA, linewidth = 1
      ),
      axis.text = ggplot2::element_text(face = "bold", color = "black"),
      axis.text.y = ggplot2::element_blank(),
      axis.ticks.y = ggplot2::element_blank(),
      panel.grid = ggplot2::element_blank(),
      strip.text = ggplot2::element_blank(),
      strip.background = ggplot2::element_rect(
        fill = "grey85", color = "black", linewidth = 1
      )
    )

  structure(
    list(
      artifact_version = "boxplot-artifact-v1",
      status = .initial_revision_status(scale_mode),
      warning = if (identical(scale_mode, "free")) {
        "Free Y scales weaken cross-facet visual comparison."
      } else {
        NULL
      },
      scale_mode = scale_mode,
      analysis = analysis,
      plot_data = plot_data,
      plot = plot,
      n_strip = n_strip,
      combined = patchwork::wrap_plots(
        plot, n_strip,
        ncol = 1L, heights = c(4, 1)
      )
    ),
    class = "boxplot_artifact"
  )
}

.execution_source_root <- function() {
  configured_root <- Sys.getenv(
    "ADAMVIZ_SUBMISSIONSYNC_SOURCE_ROOT",
    unset = ""
  )
  configured_roots <- if (nzchar(configured_root)) {
    normalizePath(configured_root, winslash = "/", mustWork = FALSE)
  } else {
    character()
  }
  current <- normalizePath(".", winslash = "/", mustWork = FALSE)
  roots <- character()
  repeat {
    roots <- c(roots, current)
    parent <- dirname(current)
    if (identical(parent, current)) break
    current <- parent
  }
  roots <- c(
    configured_roots,
    roots,
    getNamespaceInfo(asNamespace("ADaMViz.SubmissionSync"), "path")
  )
  is_source_root <- vapply(roots, function(root) {
    file.exists(file.path(root, "DESCRIPTION")) &&
      length(list.files(file.path(root, "R"), pattern = "\\.[Rr]$")) > 0L
  }, logical(1))
  source_roots <- roots[is_source_root]
  if (length(source_roots)) source_roots[[1]] else NULL
}

run_execution_callr <- function(
  request,
  script,
  analysis_data,
  data_classification = "synthetic",
  work_dir = tempfile("execution-callr-"),
  timeout = 60,
  source_root = .execution_source_root()
) {
  if (!requireNamespace("callr", quietly = TRUE)) {
    cli::cli_abort(
      "The callr execution runner requires the {.pkg callr} package"
    )
  }
  checkmate::assert_number(timeout, lower = 1, finite = TRUE)
  worker <- function(
    request,
    script,
    analysis_data,
    data_classification,
    work_dir,
    source_root
  ) {
    if (!is.null(source_root) &&
      file.exists(file.path(source_root, "DESCRIPTION"))) {
      devtools::load_all(source_root, quiet = TRUE)
    }
    run_locally <- get(
      "run_execution_locally",
      envir = asNamespace("ADaMViz.SubmissionSync")
    )
    run_locally(
      request = request,
      script = script,
      analysis_data = analysis_data,
      data_classification = data_classification,
      work_dir = work_dir
    )
  }
  tryCatch(
    callr::r(
      worker,
      args = list(
        request,
        script,
        analysis_data,
        data_classification,
        work_dir,
        source_root
      ),
      libpath = .libPaths(),
      cmdargs = "--vanilla",
      system_profile = FALSE,
      user_profile = FALSE,
      env = c(
        R_PROFILE_USER = "",
        R_ENVIRON_USER = "",
        ADAMVIZ_SECRET_CANARY = ""
      ),
      timeout = timeout
    ),
    error = function(error) {
      structure(
        list(
          status = "failed",
          manifest_version = "execution-runner-result-v1",
          diagnostics = list(stdout = "", stderr = conditionMessage(error))
        ),
        class = "execution_runner_result"
      )
    }
  )
}

new_callr_execution_runner <- function(
  timeout = 60,
  source_root = .execution_source_root()
) {
  new_execution_runner(
  function(
    request,
    script,
    analysis_data,
    data_classification,
    work_dir
  ) {
    run_execution_callr(
      request = request,
      script = script,
      analysis_data = analysis_data,
      data_classification = data_classification,
      work_dir = work_dir,
      timeout = timeout,
      source_root = source_root
    )
  })
}

.canonicalize_value <- function(value) {
  if (is.list(value)) {
    value <- lapply(value, .canonicalize_value)
    if (!is.null(names(value))) {
      value <- value[order(names(value), method = "radix")]
    }
  }
  value
}

canonical_serialize <- function(value) {
  jsonlite::toJSON(
    .canonicalize_value(value),
    auto_unbox = TRUE,
    null = "null",
    digits = NA,
    pretty = FALSE
  )
}

canonical_hash <- function(value, algorithm = "sha256") {
  digest::digest(
    canonical_serialize(value),
    algo = algorithm,
    serialize = FALSE
  )
}

mod_evidence_ui <- function(id) {
  ns <- shiny::NS(id)
  bslib::card(
    class = "assurance-panel",
    bslib::card_header("Evidence"),
    bslib::card_body(
      shiny::tableOutput(ns("hashes")),
      shiny::tableOutput(ns("checks"))
    )
  )
}

mod_evidence_server <- function(id, current_revision) {
  shiny::moduleServer(id, function(input, output, session) {
    output$hashes <- shiny::renderTable(
      {
        state <- current_revision()
        if (is.null(state$revision)) {
          return(data.frame())
        }
        data.frame(
          item = c("Specification", "Code", "Image", "Analytical output"),
          hash = c(
            state$revision$spec_hash,
            state$revision$code_hash,
            state$revision$image_hash,
            state$revision$analytical_hash
          ),
          stringsAsFactors = FALSE
        )
      },
      striped = TRUE,
      spacing = "s"
    )

    output$checks <- shiny::renderTable(
      {
        state <- current_revision()
        if (is.null(state$verification)) {
          return(data.frame())
        }
        checks <- state$verification$checks
        data.frame(
          check = names(checks),
          passed = unname(unlist(checks)),
          stringsAsFactors = FALSE
        )
      },
      striped = TRUE,
      spacing = "s"
    )
  })
}

#' Build minimum-necessary prompt context from an authorized snapshot
#'
#' @param snapshot A pinned `study_data_snapshot`.
#'
#' @return A `prompt_context` containing only authorized labels and aggregate
#'   choices.
#' @export
build_prompt_context <- function(snapshot) {
  if (!inherits(snapshot, "study_data_snapshot")) {
    cli::cli_abort("{.arg snapshot} must be a {.cls study_data_snapshot}")
  }

  data <- snapshot$data
  parameters <- .prompt_parameter_choices(data)
  visits <- .prompt_visit_choices(data)
  treatment_levels <- lapply(
    snapshot$permitted_treatment_variables,
    function(variable) {
      sort(
        unique(stats::na.omit(as.character(data[[variable]]))),
        method = "radix"
      )
    }
  )
  names(treatment_levels) <- snapshot$permitted_treatment_variables

  labels <- list(
    dataset_id = snapshot$dataset_id,
    adam_designation = snapshot$adam_designation
  )
  if (!is.null(snapshot$classification)) {
    labels$classification <- snapshot$classification
  }

  new_prompt_context(
    dataset_id = snapshot$dataset_id,
    labels = labels,
    aggregate_profile = list(
      parameters = parameters,
      y_variables = intersect(c("AVAL", "CHG", "PCHG"), names(data)),
      treatment_variables = snapshot$permitted_treatment_variables,
      treatment_levels = treatment_levels,
      visits = visits,
      scale_modes = c("fixed", "free"),
      default_scale_mode = "fixed"
    )
  )
}

.prompt_parameter_choices <- function(data) {
  if (!all(c("PARAMCD", "PARAM") %in% names(data))) {
    return(list())
  }
  parameter_rows <- unique(
    data[c("PARAMCD", "PARAM", intersect("AVALU", names(data)))]
  )
  parameter_rows <- parameter_rows[
    order(parameter_rows$PARAMCD, method = "radix"), ,
    drop = FALSE
  ]
  lapply(split(parameter_rows, parameter_rows$PARAMCD), function(rows) {
    unit <- if ("AVALU" %in% names(rows)) {
      sort(unique(stats::na.omit(as.character(rows$AVALU))), method = "radix")
    } else {
      character()
    }
    list(
      paramcd = rows$PARAMCD[[1]],
      label = rows$PARAM[[1]],
      units = unit
    )
  })
}

.prompt_visit_choices <- function(data) {
  if (!all(c("AVISIT", "AVISITN") %in% names(data))) {
    return(list())
  }
  visits <- unique(data[c("AVISIT", "AVISITN")])
  visits <- visits[
    !is.na(visits$AVISIT) & !is.na(visits$AVISITN), ,
    drop = FALSE
  ]
  visits <- visits[
    order(visits$AVISITN, visits$AVISIT, method = "radix"), ,
    drop = FALSE
  ]
  lapply(seq_len(nrow(visits)), function(i) {
    list(label = as.character(visits$AVISIT[[i]]), order = visits$AVISITN[[i]])
  })
}

mod_revision_history_ui <- function(id) {
  ns <- shiny::NS(id)
  bslib::card(
    class = "assurance-panel",
    bslib::card_header("Revision History"),
    bslib::card_body(
      shiny::tableOutput(ns("history"))
    )
  )
}

mod_revision_history_server <- function(id, current_revision) {
  shiny::moduleServer(id, function(input, output, session) {
    output$history <- shiny::renderTable(
      {
        state <- current_revision()
        if (is.null(state$repository) || is.null(state$plot_id)) {
          return(data.frame())
        }
        revisions <- state$repository$list_revisions(state$plot_id)
        revisions$status <- vapply(
          revisions$revision_id,
          function(revision_id) {
            state$repository$get_revision(revision_id)$status
          },
          character(1)
        )
        revisions[, c(
          "revision_id", "revision_number", "initial_status",
          "status", "created_at"
        ), drop = FALSE]
      },
      striped = TRUE,
      spacing = "s"
    )
  })
}

mod_run_status_ui <- function(id) {
  ns <- shiny::NS(id)
  bslib::card(
    class = "assurance-panel",
    bslib::card_header("Run Status"),
    bslib::card_body(
      shiny::uiOutput(ns("status")),
      shiny::uiOutput(ns("warnings"))
    )
  )
}

mod_run_status_server <- function(id, current_revision) {
  shiny::moduleServer(id, function(input, output, session) {
    output$status <- shiny::renderUI({
      state <- current_revision()
      if (is.null(state$revision)) {
        return(div(
          class = "text-body-secondary", "No revision has been created."
        ))
      }
      status <- state$revision$status
      div(
        class = "status-row",
        span(class = paste("status-badge", .status_class(status)), status),
        span(
          class = "text-body-secondary",
          paste("Revision", state$revision$revision_id)
        )
      )
    })

    output$warnings <- shiny::renderUI({
      state <- current_revision()
      if (is.null(state$profile)) {
        return(NULL)
      }
      warnings <- state$profile$warnings
      if (!length(warnings)) {
        return(div(
          class = "text-body-secondary", "No nonblocking profile warnings."
        ))
      }
      tags$ul(
        class = "warning-list",
        lapply(warnings, function(warning) {
          tags$li(
            tags$strong(warning$code),
            paste0(": ", warning$message),
            if (!is.null(warning$count)) {
              paste0(" (", warning$count, ")")
            } else {
              ""
            }
          )
        })
      )
    })
  })
}

.status_class <- function(status) {
  switch(status,
    "Verified" = "status-verified",
    "Reviewed" = "status-reviewed",
    "Rejected" = "status-rejected",
    "Experimental/Draft" = "status-experimental",
    "status-draft"
  )
}

.utc_timestamp <- function() {
  format(Sys.time(), "%Y-%m-%dT%H:%M:%OS6Z", tz = "UTC")
}

.validate_identifier <- function(value, name) {
  if (!checkmate::test_string(
    value,
    min.chars = 1,
    pattern = "^[A-Za-z0-9._:-]+$"
  )) {
    cli::cli_abort("{.arg {name}} must be a non-empty stable identifier")
  }
  invisible(value)
}

.validate_evidence_repository <- function(repository, capabilities) {
  available <- is.list(repository) && all(vapply(
    capabilities,
    \(capability) is.function(repository[[capability]]),
    logical(1)
  ))
  if (!available) {
    cli::cli_abort(
      "Evidence repository must implement {.fn {capabilities}}"
    )
  }
  invisible(repository)
}

#' Create the pre-execution boxplot artifact manifest
#'
#' Binds the exact specification, script, analytical result, and expected-result
#' contract. Runtime and image hashes remain unset until controlled execution.
#'
#' @param spec A confirmed `plot_spec`.
#' @param script The exact compiled R script.
#' @param analysis A `boxplot_analysis` object.
#' @param expected_contract A list containing the expected-result `version`,
#'   `fixture_hash`, and `review_status`.
#'
#' @return A `boxplot_artifact_manifest`.
#' @export
new_artifact_manifest <- function(
  spec,
  script,
  analysis,
  expected_contract
) {
  .validate_plot_spec(spec)
  required_contract_fields <- c("version", "fixture_hash", "review_status")
  if (!identical(spec$state, "confirmed") ||
    !checkmate::test_string(script, min.chars = 1L) ||
    !inherits(analysis, "boxplot_analysis") ||
    !is.list(expected_contract) ||
    !setequal(names(expected_contract), required_contract_fields) ||
    !all(vapply(
      expected_contract,
      checkmate::test_string,
      logical(1),
      min.chars = 1L
    ))) {
    cli::cli_abort(
      "The artifact manifest requires confirmed, complete U4 inputs"
    )
  }

  authentic_spec_hash <- canonical_hash(list(
    fields = spec$fields,
    provenance = spec$provenance
  ))
  if (!identical(spec$hash, authentic_spec_hash)) {
    cli::cli_abort(
      "The confirmed plot specification hash does not match its contents"
    )
  }

  analytical_metadata <- list(
    treatment_variable = spec$fields$treatment_variable,
    y_variable = spec$fields$y_variable,
    facet_levels = spec$fields$treatment_levels,
    visit_levels = spec$fields$visits
  )
  analytical_mismatch <- vapply(
    names(analytical_metadata),
    function(field) !identical(analysis[[field]], analytical_metadata[[field]]),
    logical(1)
  )
  if (any(analytical_mismatch)) {
    cli::cli_abort(
      paste0(
        "The analytical result does not match the confirmed specification for ",
        "{.field {names(analytical_metadata)[analytical_mismatch]}}"
      )
    )
  }

  expected_script <- compile_boxplot_script(spec, analysis$low_n_policy)
  if (!identical(script, expected_script)) {
    cli::cli_abort(paste0(
      "The compiled script does not match the confirmed specification ",
      "and analytical policy"
    ))
  }

  structure(
    list(
      manifest_version = "boxplot-artifact-manifest-v1",
      status = .initial_revision_status(spec$fields$scale_mode),
      spec_hash = spec$hash,
      script_hash = .execution_hash_text(script),
      analytical_hash = canonical_hash(analysis),
      expected_contract_version = expected_contract$version,
      expected_contract_review_status = expected_contract$review_status,
      expected_contract_hash = canonical_hash(expected_contract),
      image_hash = NULL,
      runtime_artifact_hash = NULL
    ),
    class = "boxplot_artifact_manifest"
  )
}

new_review_service <- function(repository, identity_provider) {
  .validate_evidence_repository(
    repository,
    c("get_revision", "record_review_decision")
  )
  .validate_identity_provider(identity_provider)

  record_decision <- function(
    revision_id,
    actor_id,
    decision,
    expected_version,
    idempotency_key,
    hashes,
    comment,
    role
  ) {
    actor <- identity_provider$get_actor(actor_id)
    if (is.null(hashes)) {
      revision <- repository$get_revision(revision_id)
      hashes <- revision[c("code_hash", "image_hash", "analytical_hash")]
    }
    repository$record_review_decision(
      revision_id,
      actor,
      decision,
      expected_version,
      idempotency_key,
      hashes,
      comment = comment,
      role = role
    )
    invisible(repository$get_revision(revision_id))
  }

  approve <- function(
    revision_id,
    actor_id,
    expected_version,
    idempotency_key,
    hashes = NULL,
    comment = NULL,
    role = NULL
  ) {
    record_decision(
      revision_id,
      actor_id,
      "approved",
      expected_version,
      idempotency_key,
      hashes,
      comment,
      role
    )
  }
  reject <- function(
    revision_id,
    actor_id,
    expected_version,
    idempotency_key,
    rationale,
    hashes = NULL,
    role = NULL
  ) {
    record_decision(
      revision_id,
      actor_id,
      "rejected",
      expected_version,
      idempotency_key,
      hashes,
      rationale,
      role
    )
  }
  structure(list(approve = approve, reject = reject), class = "review_service")
}

new_provider_port <- function(name, capabilities) {
  if (!checkmate::test_string(name, min.chars = 1) ||
    !checkmate::test_character(
      capabilities,
      min.len = 1L, any.missing = FALSE
    )) {
    cli::cli_abort("A provider port needs a name and declared capabilities")
  }
  structure(
    list(name = name, capabilities = unique(capabilities)),
    class = "provider_port"
  )
}

.workflow_transitions <- list(
  Draft = c("Verified", "Experimental/Draft"),
  "Experimental/Draft" = character(),
  Verified = c("Reviewed"),
  Reviewed = character(),
  Rejected = character()
)

transition_revision_status <- function(status, next_status) {
  if (!checkmate::test_choice(status, choices = names(.workflow_transitions))) {
    cli::cli_abort("Unknown revision status {.val {status}}")
  }
  if (!checkmate::test_choice(
    next_status,
    choices = names(.workflow_transitions)
  )) {
    cli::cli_abort("Unknown next status {.val {next_status}}")
  }
  if (!checkmate::test_choice(
    next_status,
    choices = .workflow_transitions[[status]]
  )) {
    cli::cli_abort(paste0(
      "Cannot transition from {.val {status}} to {.val {next_status}}"
    ))
  }
  next_status
}

.initial_revision_status <- function(scale_mode) {
  if (identical(scale_mode, "free")) "Experimental/Draft" else "Draft"
}

.revision_evidence_id <- function(revision_id, evidence_type) {
  paste(
    "evidence",
    substr(canonical_hash(list(revision_id, evidence_type)), 1L, 24L),
    sep = "-"
  )
}

.record_revision_context <- function(state, request, runner_result) {
  if (is.null(state$repository) || is.null(state$revision)) {
    cli::cli_abort("Revision evidence requires a persisted revision")
  }
  revision <- state$repository$get_revision(state$revision$revision_id)
  details <- .revision_context_details(state, request, runner_result, revision)
  state$repository$record_evidence(
    evidence_id = .revision_evidence_id(
      revision$revision_id, "revision_context"
    ),
    revision_id = revision$revision_id,
    evidence_type = "revision_context",
    outcome = "recorded",
    idempotency_key = paste0(
      "evidence:revision-context:", revision$revision_id
    ),
    details = details
  )
  invisible(details)
}

.revision_context_details <- function(state, request, runner_result, revision) {
  profile <- state$profile
  snapshot <- state$snapshot
  analysis_data <- profile$analysis_data
  source_metadata <- snapshot$source_metadata %||% NULL
  if (!is.null(source_metadata)) {
    source_metadata <- source_metadata[intersect(
      c("source", "file_type", "source_file_hash"),
      names(source_metadata)
    )]
  }
  environment <- runner_result$environment %||% .execution_environment_details()
  environment$fingerprint <- runner_result$result$environment_fingerprint
  input_data <- c(
    list(
      dataset_id = snapshot$dataset_id,
      snapshot_id = snapshot$snapshot_id,
      snapshot_hash = request$snapshot_hash,
      content_hash = snapshot$content_hash,
      metadata_version = snapshot$metadata_version
    ),
    if (!is.null(snapshot$classification)) {
      list(classification = snapshot$classification)
    },
    list(
      source_metadata = source_metadata,
      selected_data_columns = names(analysis_data),
      selected_data_classes = as.list(
        stats::setNames(
          vapply(
            analysis_data,
            \(column) class(column)[[1]],
            character(1)
          ),
          names(analysis_data)
        )
      ),
      selected_data = as.list(analysis_data)
    )
  )
  list(
    evidence_version = "revision-context-evidence-v1",
    revision = unclass(revision),
    prompt = state$prompt,
    specification = unclass(state$spec),
    input_data = input_data,
    generated_r_code = state$script,
    request = unclass(request),
    execution_result = unclass(runner_result$result),
    environment = environment,
    checks = list(
      bds_profile_blocked = profile$blocked,
      verification = unclass(state$verification %||% list())
    ),
    rendered_output = list(
      image_hash = revision$image_hash,
      analytical_hash = revision$analytical_hash
    ),
    warnings = lapply(profile$warnings, unclass)
  )
}

#' The application User-Interface
#'
#' @param request Internal parameter for `{shiny}`.
#'     DO NOT REMOVE.
#' @param runtime_config Injected runtime configuration.
#' @import shiny
#' @importFrom bslib page_fillable card card_header card_body
#' @noRd
app_ui <- function(request, runtime_config = new_runtime_config()) {
  tagList(
    golem_add_external_resources(),
    bslib::page_fillable(
      title = "ADaMViz SubmissionSync",
      theme = app_theme(),
      fillable = FALSE,
      div(
        class = "assurance-shell",
        tags$header(
          class = "f001-app-header",
          tags$span(class = "f001-app-title", "ADaMViz SubmissionSync"),
          tags$a(
            class = "f001-repo-link",
            href = "https://github.com/Ramdhadage/ADaMViz.SubmissionSync",
            target = "_blank",
            rel = "noopener noreferrer",
            `aria-label` = paste(
              "ADaMViz SubmissionSync on GitHub (opens in a new tab)"
            ),
            shiny::icon("github")
          )
        ),
        mod_plot_generation_ui("plot_generation"),
        tags$footer(
          class = "f001-app-footer",
          "This app is brought to you by Ramnath Dhadage. ",
          "For more information, please visit the ",
          tags$a(
            "Source Code",
            href = "https://github.com/Ramdhadage/ADaMViz.SubmissionSync",
            target = "_blank",
            rel = "noopener noreferrer"
          ),
          " and ",
          tags$a(
            "Report Issues",
            href = paste0(
              "https://github.com/Ramdhadage/",
              "ADaMViz.SubmissionSync/issues/new"
            ),
            target = "_blank",
            rel = "noopener noreferrer"
          ),
          "."
        )
      )
    )
  )
}

#' Add external Resources to the Application
#'
#' This function is internally used to add external
#' resources inside the Shiny application.
#'
#' @import shiny
#' @importFrom golem add_resource_path activate_js favicon bundle_resources
#' @noRd
golem_add_external_resources <- function() {
  add_resource_path(
    "www",
    app_sys("app/www")
  )

  tags$head(
    favicon(),
    bundle_resources(
      path = app_sys("app/www"),
      app_title = "ADaMViz.SubmissionSync"
    )
    # Add here other external resources
    # for example, you can add shinyalert::useShinyalert()
  )
}

new_plot_revision <- function(plot_id, creator_id, spec, version = 1L) {
  .validate_plot_spec(spec)
  if (!checkmate::test_string(plot_id, min.chars = 1) ||
    !checkmate::test_string(creator_id, min.chars = 1) ||
    !checkmate::test_int(version, lower = 1L)) {
    cli::cli_abort(paste0(
      "A revision requires valid plot, creator, ",
      "and version identifiers"
    ))
  }
  status <- .initial_revision_status(spec$fields$scale_mode)
  structure(
    list(
      revision_id = paste(plot_id, version, sep = "-r"),
      plot_id = plot_id,
      creator_id = creator_id,
      version = version,
      spec_hash = spec$hash,
      status = status
    ),
    class = "plot_revision"
  )
}

#' Access files in the current app
#'
#' NOTE: If you manually change your package name in the DESCRIPTION,
#' don't forget to change it here too, and in the config file.
#' For a safer name change mechanism, use
#' `golem::set_golem_name()`.
#'
#' @param ... character vectors, specifying subdirectory and file(s)
#' within your package. The default, none, returns the root of the app.
#'
#' @noRd
app_sys <- function(...) {
  system.file(..., package = "ADaMViz.SubmissionSync")
}


#' Read App Config
#'
#' @param value Value to retrieve from the config file.
#' @param config GOLEM_CONFIG_ACTIVE value. If unset, R_CONFIG_ACTIVE.
#' If unset, "default".
#' @param use_parent Logical, scan the parent directory for config file.
#' @param file Location of the config file
#'
#' @noRd
get_golem_config <- function(
  value,
  config = Sys.getenv(
    "GOLEM_CONFIG_ACTIVE",
    Sys.getenv(
      "R_CONFIG_ACTIVE",
      "default"
    )
  ),
  use_parent = TRUE,
  # Modify this if your config file is somewhere else
  file = app_sys("golem-config.yml")
) {
  config::get(
    value = value,
    config = config,
    file = file,
    use_parent = use_parent
  )
}

new_limits_policy <- function(
  max_prompt_chars = 4000L,
  max_levels = 50L,
  max_visits = 100L
) {
  values <- c(max_prompt_chars, max_levels, max_visits)
  if (!all(vapply(values, checkmate::test_int, logical(1), lower = 1L))) {
    cli::cli_abort("All content limits must be positive integers")
  }
  structure(list(
    version = "limits-v1",
    max_prompt_chars = max_prompt_chars,
    max_levels = max_levels,
    max_visits = max_visits
  ), class = "limits_policy")
}

enforce_limit <- function(value, limit, field) {
  if (nchar(value, type = "chars") > limit) {
    cli::cli_abort("{.field {field}} exceeds its configured limit")
  }
  invisible(value)
}

#' Create the disabled ellmer prompt interpreter placeholder
#'
#' The real provider remains unavailable until its retention, training, region,
#' transport, and incident-handling terms are approved for the target use.
#'
#' @param ... Reserved for future provider-specific configuration.
#'
#' @return This function always aborts in the local POC.
#' @export
ellmer_prompt_interpreter <- function(...) {
  cli::cli_abort(paste(
    "The ellmer prompt interpreter is disabled until provider terms",
    "are approved"
  ))
}

#' Return the application Bootstrap theme.
#'
#' Keeping the theme in one function makes the visual contract explicit and
#' gives later modules one stable place to extend application branding.
#'
#' @return A pinned Bootstrap 5 bslib theme.
#' @noRd
app_theme <- function() {
  bslib::bs_theme(
    version = 5,
    primary = "#0B3C5D",
    secondary = "#5B6770",
    success = "#1B6E3A",
    base_font = bslib::font_collection(
      "Inter",
      "Segoe UI",
      "Arial",
      "sans-serif"
    ),
    heading_font = bslib::font_collection(
      "Inter",
      "Segoe UI",
      "Arial",
      "sans-serif"
    )
  )
}

1		.validate_artifact_hash <- function(hash) {
2	327x	if (!checkmate::test_string(hash, pattern = "^[0-9a-f]{64}$")) {
3	!	cli::cli_abort("Artifact hash must be a lowercase SHA-256 value")
4		}
5	327x	invisible(hash)
6		}

1		.validate_identity_provider <- function(provider) {
2	51x	if (!is.list(provider) \|\| !is.function(provider$get_actor)) {
3	!	cli::cli_abort("Identity provider must implement {.fn get_actor}")
4		}
5	51x	invisible(provider)
6		}

1		reconcile_workspace_exports <- function(workspace_provider, destination_id) {
2	2x	.validate_workspace_provider(workspace_provider)
3	2x	.validate_workspace_token(destination_id, "destination_id")
4	2x	workspace_provider$reconcile(destination_id)
5		}

1		#' The application server-side
2		#'
3		#' @param input,output,session Internal parameters for {shiny}.
4		#' DO NOT REMOVE.
5		#' @param runtime_config Injected runtime configuration.
6		#' @import shiny
7		#' @noRd
8		app_server <- function(
9		input,
10		output,
11		session,
12		runtime_config = new_runtime_config()
13		) {
14	8x	workspace_root <- fs::path(
15	8x	fs::path_temp(),
16	8x	"adamviz-submissionsync-workspace",
17	8x	runtime_config$workspace
18		)
19	8x	fs::dir_create(workspace_root, recurse = TRUE)
20	8x	workspace_provider <- local_workspace_provider(
21	8x	stats::setNames(workspace_root, runtime_config$workspace)
22		)
23	8x	fs::dir_create(runtime_config$evidence_root, recurse = TRUE)
24	8x	current_revision <- shiny::reactiveVal(.empty_assurance_state())
25
26	8x	execute_revision <- function(fields) {
27	7x	state <- current_revision()
28	7x	if (is.null(state$pending)) {
29	!	cli::cli_abort("Create an inspectable specification before execution")
30		}
31	7x	current_revision(.execute_assurance_revision(
32	7x	snapshot = state$pending$snapshot,
33	7x	prompt = state$pending$prompt,
34	7x	fields = fields,
35	7x	repository_root = runtime_config$evidence_root
36		))
37	7x	invisible(current_revision())
38		}
39
40	8x	create_correction <- function(fields, rationale, provenance) {
41	!	current_revision(.execute_correction_revision(
42	!	state = current_revision(),
43	!	fields = fields,
44	!	rationale = rationale,
45	!	provenance = provenance
46		))
47	!	invisible(current_revision())
48		}
49
50	8x	mod_plot_generation_server(
51	8x	"plot_generation",
52	8x	current_revision = current_revision,
53	8x	execute_revision = execute_revision,
54	8x	create_correction = create_correction,
55	8x	workspace_provider = workspace_provider
56		)
57		}
58
59		.empty_assurance_state <- function() {
60	21x	list(
61	21x	pending = NULL,
62	21x	plot_id = NULL,
63	21x	repository = NULL,
64	21x	identity_provider = NULL,
65	21x	review_service = NULL,
66	21x	revision = NULL,
67	21x	spec = NULL,
68	21x	snapshot = NULL,
69	21x	prompt = NULL,
70	21x	choices = NULL,
71	21x	profile = NULL,
72	21x	script = NULL,
73	21x	artifact = NULL,
74	21x	verification = NULL
75		)
76		}
77
78		.create_assurance_candidate <- function(provider, dataset_id, prompt) {
79	10x	if (!checkmate::test_string(dataset_id, min.chars = 1L)) {
80	!	cli::cli_abort("Select one authorized BDS dataset")
81		}
82	10x	snapshot <- pin_study_snapshot(provider, dataset_id)
83	10x	if (!is.null(provider$source_metadata)) {
84	8x	snapshot$source_metadata <- provider$source_metadata
85		}
86	10x	context <- build_prompt_context(snapshot)
87	10x	interpretation <- interpret_prompt(prompt, context, mock_prompt_interpreter())
88	10x	spec <- interpretation$candidate %\|\|% new_plot_spec(dataset_id = dataset_id)
89	10x	choices <- .spec_choices_from_context(context)
90	10x	list(
91	10x	pending = list(
92	10x	snapshot = snapshot,
93	10x	prompt = prompt,
94	10x	choices = choices
95		),
96	10x	plot_id = NULL,
97	10x	repository = NULL,
98	10x	identity_provider = NULL,
99	10x	review_service = NULL,
100	10x	revision = NULL,
101	10x	spec = spec,
102	10x	snapshot = snapshot,
103	10x	prompt = prompt,
104	10x	choices = choices,
105	10x	profile = NULL,
106	10x	script = NULL,
107	10x	artifact = NULL,
108	10x	verification = NULL
109		)
110		}
111
112		.spec_choices_from_context <- function(context) {
113	19x	profile <- context$aggregate_profile
114	19x	list(
115	19x	parameters = names(profile$parameters),
116	19x	units = lapply(profile$parameters, `[[`, "units"),
117	19x	y_variables = profile$y_variables,
118	19x	treatment_variables = profile$treatment_variables,
119	19x	treatment_levels = profile$treatment_levels,
120	19x	visits = vapply(profile$visits, `[[`, "", "label"),
121	19x	scale_modes = profile$scale_modes
122		)
123		}
124
125		.execute_assurance_revision <- function(
126		snapshot,
127		prompt,
128		fields,
129		repository_root = NULL
130		) {
131	6x	spec <- .confirmed_spec_from_fields(snapshot$dataset_id, fields)
132	6x	profile <- validate_bds_profile(
133	6x	snapshot,
134	6x	spec$fields[setdiff(.plot_spec_fields, c("dataset_id", "scale_mode"))]
135		)
136	6x	if (profile$blocked) {
137	!	diagnostic <- profile$blocking_diagnostics[[1]]
138	!	cli::cli_abort(c(
139	!	"The selected records are outside the supported BDS profile",
140	!	"x" = paste0(diagnostic$code, ": ", diagnostic$message)
141		))
142		}
143	6x	.materialize_revision(snapshot, prompt, spec, profile, repository_root)
144		}
145
146		.execute_correction_revision <- function(state, fields, rationale, provenance) {
147	1x	if (is.null(state$repository) \|\| is.null(state$revision) \|\|
148	1x	is.null(state$snapshot)) {
149	!	cli::cli_abort("Create a revision before starting a correction")
150		}
151	1x	parent <- state$repository$get_revision(state$revision$revision_id)
152	1x	if (!parent$status %in% c("Rejected", "Reviewed")) {
153	!	cli::cli_abort(
154	!	"Only a Rejected or Reviewed revision can start a correction"
155		)
156		}
157	1x	if (!checkmate::test_string(rationale, min.chars = 1L) \|\|
158	1x	!checkmate::test_string(provenance, min.chars = 1L)) {
159	!	cli::cli_abort("Correction rationale and provenance are required")
160		}
161	1x	spec <- .confirmed_spec_from_fields(state$snapshot$dataset_id, fields)
162	1x	profile <- validate_bds_profile(
163	1x	state$snapshot,
164	1x	spec$fields[setdiff(.plot_spec_fields, c("dataset_id", "scale_mode"))]
165		)
166	1x	if (profile$blocked) {
167	!	diagnostic <- profile$blocking_diagnostics[[1]]
168	!	cli::cli_abort(c(
169	!	"The selected records are outside the supported BDS profile",
170	!	"x" = paste0(diagnostic$code, ": ", diagnostic$message)
171		))
172		}
173
174	1x	.materialize_correction(
175	1x	state,
176	1x	spec,
177	1x	profile,
178	1x	rationale,
179	1x	provenance
180		)
181		}
182
183		.create_assurance_revision <- function(
184		provider,
185		dataset_id,
186		prompt,
187		confirm_free_scale
188		) {
189	!	snapshot <- pin_study_snapshot(provider, dataset_id)
190	!	context <- build_prompt_context(snapshot)
191	!	interpretation <- interpret_prompt(
192	!	prompt,
193	!	context,
194	!	mock_prompt_interpreter(),
195	!	snapshot = NULL
196		)
197	!	if (is.null(interpretation$candidate)) {
198	!	cli::cli_abort("The prompt could not create an executable candidate")
199		}
200	!	fields <- interpretation$candidate$fields
201	!	if (identical(fields$scale_mode, "free") && !isTRUE(confirm_free_scale)) {
202	!	cli::cli_abort(
203	!	paste0(
204	!	"Free Y scales require confirmation because they create an ",
205	!	"Experimental/Draft revision"
206		)
207		)
208		}
209	!	.execute_assurance_revision(snapshot, prompt, fields)
210		}
211
212		.confirmed_spec_from_fields <- function(dataset_id, fields) {
213	11x	if (!checkmate::test_string(fields$paramcd, min.chars = 1L) \|\|
214	11x	!checkmate::test_choice(fields$y_variable, c("AVAL", "CHG", "PCHG")) \|\|
215	11x	!checkmate::test_string(fields$unit, min.chars = 1L) \|\|
216	11x	!checkmate::test_string(fields$treatment_variable, min.chars = 1L) \|\|
217	11x	!checkmate::test_character(
218	11x	fields$treatment_levels,
219	11x	min.len = 1L,
220	11x	any.missing = FALSE,
221	11x	unique = TRUE
222		) \|\|
223	11x	!checkmate::test_character(
224	11x	fields$visits,
225	11x	min.len = 1L,
226	11x	any.missing = FALSE,
227	11x	unique = TRUE
228		)) {
229	!	cli::cli_abort(paste0(
230	!	"Confirm one parameter, one Y variable, one unit, one treatment facet, ",
231	!	"and at least one treatment level and visit"
232		))
233		}
234	11x	provenance <- as.list(stats::setNames(
235	11x	rep("user_confirmed", length(.plot_spec_fields)),
236	11x	.plot_spec_fields
237		))
238	11x	provenance$dataset_id <- "metadata"
239	11x	spec <- new_plot_spec(
240	11x	dataset_id = dataset_id,
241	11x	paramcd = fields$paramcd,
242	11x	y_variable = fields$y_variable,
243	11x	unit = fields$unit,
244	11x	treatment_variable = fields$treatment_variable,
245	11x	treatment_levels = fields$treatment_levels,
246	11x	visits = fields$visits,
247	11x	scale_mode = fields$scale_mode %\|\|% "fixed",
248	11x	provenance = as.list(provenance),
249	11x	state = "candidate"
250		)
251	11x	confirm_plot_spec(spec)
252		}
253
254		.materialize_revision <- function(
255		snapshot,
256		prompt,
257		spec,
258		profile,
259		repository_root = NULL
260		) {
261	8x	script <- compile_boxplot_script(spec, profile$low_n_policy)
262	8x	request <- new_execution_request(
263	8x	spec = spec,
264	8x	script_hash = .execution_hash_text(script),
265	8x	snapshot_id = profile$snapshot_id,
266	8x	snapshot_hash = canonical_hash(profile$analysis_data),
267	8x	harness_version = "execution-harness-v1"
268		)
269	8x	root <- repository_root %\|\|% fs::file_temp(pattern = "assurance-session-")
270	8x	artifact_store <- local_artifact_store(fs::path(root, "artifacts"))
271	8x	repository <- sqlite_evidence_repository(
272	8x	fs::path(root, "evidence.sqlite"),
273	8x	fs::path(root, "chain-root.json"),
274	8x	artifact_store
275		)
276	8x	revision_suffix <- substr(
277	8x	canonical_hash(list(spec$hash, Sys.time(), tempfile("revision-"))),
278	8x	1L,
279	8x	12L
280		)
281	8x	revision_id <- paste0("rev-", revision_suffix)
282	8x	plot_id <- paste0("plot-", revision_suffix)
283	8x	initial_status <- if (identical(spec$fields$scale_mode, "free")) {
284	2x	"Experimental/Draft"
285		} else {
286	6x	"Draft"
287		}
288
289	8x	code_hash <- artifact_store$put(.execution_text_bytes(script))
290	8x	repository$create_revision(
291	8x	plot_id = plot_id,
292	8x	revision_id = revision_id,
293	8x	revision_number = 1L,
294	8x	creator_id = "creator",
295	8x	spec_hash = spec$hash,
296	8x	code_hash = code_hash,
297	8x	image_hash = NULL,
298	8x	analytical_hash = NULL,
299	8x	idempotency_key = paste0("create:", revision_id),
300	8x	initial_status = initial_status
301		)
302
303	8x	verification <- NULL
304	8x	if (identical(initial_status, "Draft")) {
305	6x	execution_service <- new_execution_service(
306	6x	repository,
307	6x	artifact_store = artifact_store
308		)
309	6x	execution <- execution_service$submit(
310	6x	revision_id = revision_id,
311	6x	request = request,
312	6x	script = script,
313	6x	analysis_data = profile$analysis_data,
314	6x	idempotency_key = paste0("execute:", revision_id)
315		)
316	6x	verification <- execution$verification
317	6x	runner_result <- execution$runner_result
318		}
319
320	8x	identities <- local_identity_provider(list(
321	8x	new_actor("creator", "clinical_scientist"),
322	8x	new_actor("stat-programmer", "statistical_programmer"),
323	8x	new_actor("biostatistician", "biostatistician")
324		))
325	8x	analysis <- calculate_boxplot_statistics(
326	8x	profile$display_data,
327	8x	treatment_variable = spec$fields$treatment_variable,
328	8x	y_variable = spec$fields$y_variable,
329	8x	facet_levels = profile$facet_levels,
330	8x	visit_levels = profile$visit_levels,
331	8x	low_n_policy = profile$low_n_policy
332		)
333	8x	artifact <- assemble_boxplot(
334	8x	analysis,
335	8x	scale_mode = spec$fields$scale_mode,
336	8x	unit = spec$fields$unit
337		)
338	8x	context <- build_prompt_context(snapshot)
339
340	8x	state <- list(
341	8x	pending = NULL,
342	8x	plot_id = plot_id,
343	8x	repository = repository,
344	8x	identity_provider = identities,
345	8x	review_service = new_review_service(repository, identities),
346	8x	revision = repository$get_revision(revision_id),
347	8x	spec = spec,
348	8x	snapshot = snapshot,
349	8x	prompt = prompt,
350	8x	choices = .spec_choices_from_context(context),
351	8x	profile = profile,
352	8x	script = script,
353	8x	artifact = artifact,
354	8x	verification = verification
355		)
356	8x	if (!is.null(verification)) {
357	6x	.record_revision_context( # nolint: object_usage_linter.
358	6x	state,
359	6x	request = request,
360	6x	runner_result = runner_result
361		)
362		}
363	8x	state
364		}
365
366		.materialize_correction <- function(
367		state,
368		spec,
369		profile,
370		rationale,
371		provenance
372		) {
373	1x	script <- compile_boxplot_script(spec, profile$low_n_policy)
374	1x	request <- new_execution_request(
375	1x	spec = spec,
376	1x	script_hash = .execution_hash_text(script),
377	1x	snapshot_id = profile$snapshot_id,
378	1x	snapshot_hash = canonical_hash(profile$analysis_data),
379	1x	harness_version = "execution-harness-v1"
380		)
381	1x	artifact_store <- state$repository$artifact_store
382	1x	if (is.null(artifact_store)) {
383	!	cli::cli_abort("Correction revisions require an artifact store")
384		}
385	1x	parent <- state$repository$get_revision(state$revision$revision_id)
386	1x	revisions <- state$repository$list_revisions(parent$plot_id)
387	1x	revision_number <- max(revisions$revision_number) + 1L
388	1x	revision_id <- paste0("rev-", substr(canonical_hash(list(
389	1x	parent$revision_id,
390	1x	spec$hash,
391	1x	revision_number,
392	1x	Sys.time()
393	1x	)), 1L, 12L))
394	1x	code_hash <- artifact_store$put(.execution_text_bytes(script))
395	1x	lifecycle <- new_lifecycle_service(state$repository)
396	1x	lifecycle$create_correction(
397	1x	parent_revision_id = parent$revision_id,
398	1x	revision_id = revision_id,
399	1x	creator_id = "creator",
400	1x	spec_hash = spec$hash,
401	1x	code_hash = code_hash,
402	1x	image_hash = NULL,
403	1x	analytical_hash = NULL,
404	1x	rationale = rationale,
405	1x	provenance = provenance,
406	1x	idempotency_key = paste0("correct:", revision_id),
407	1x	initial_status = .initial_revision_status(spec$fields$scale_mode)
408		)
409
410	1x	verification <- NULL
411	1x	if (identical(spec$fields$scale_mode, "fixed")) {
412	1x	execution <- new_execution_service(
413	1x	state$repository,
414	1x	artifact_store = artifact_store
415	1x	)$submit(
416	1x	revision_id = revision_id,
417	1x	request = request,
418	1x	script = script,
419	1x	analysis_data = profile$analysis_data,
420	1x	idempotency_key = paste0("execute:", revision_id)
421		)
422	1x	verification <- execution$verification
423	1x	runner_result <- execution$runner_result
424		}
425
426	1x	analysis <- calculate_boxplot_statistics(
427	1x	profile$display_data,
428	1x	treatment_variable = spec$fields$treatment_variable,
429	1x	y_variable = spec$fields$y_variable,
430	1x	facet_levels = profile$facet_levels,
431	1x	visit_levels = profile$visit_levels,
432	1x	low_n_policy = profile$low_n_policy
433		)
434	1x	artifact <- assemble_boxplot(
435	1x	analysis,
436	1x	scale_mode = spec$fields$scale_mode,
437	1x	unit = spec$fields$unit
438		)
439
440	1x	state$pending <- NULL
441	1x	state$revision <- state$repository$get_revision(revision_id)
442	1x	state$spec <- spec
443	1x	state$profile <- profile
444	1x	state$script <- script
445	1x	state$artifact <- artifact
446	1x	state$verification <- verification
447	1x	if (!is.null(verification)) {
448	1x	.record_revision_context( # nolint: object_usage_linter.
449	1x	state,
450	1x	request = request,
451	1x	runner_result = runner_result
452		)
453		}
454	1x	state
455		}

1		.latest_revision_context <- function(repository, revision_id) {
2	1x	evidence <- repository$list_evidence(revision_id)
3	1x	evidence <- evidence[
4	1x	evidence$evidence_type == "revision_context", ,
5	1x	drop = FALSE
6		]
7	1x	if (!nrow(evidence)) {
8	!	cli::cli_abort(
9	!	"Revision {.val {revision_id}} has no revision context evidence"
10		)
11		}
12	1x	jsonlite::fromJSON(
13	1x	evidence$details_json[[nrow(evidence)]],
14	1x	simplifyVector = FALSE
15		)
16		}
17
18		.evidence_selected_data <- function(details) {
19	1x	columns <- lapply(details$input_data$selected_data, function(column) {
20	!	if (is.list(column)) unlist(column, use.names = FALSE) else column
21		})
22	1x	column_order <- unlist(
23	1x	details$input_data$selected_data_columns %\|\|% names(columns),
24	1x	use.names = FALSE
25		)
26	1x	columns <- columns[column_order]
27	1x	columns <- lapply(columns, function(column) {
28	5x	column[column == "NA"] <- NA
29	5x	column
30		})
31	1x	classes <- unlist(
32	1x	details$input_data$selected_data_classes %\|\|% list(),
33	1x	use.names = TRUE
34		)
35	1x	if (!is.null(names(classes))) {
36	1x	names(classes) <- sub("^.*[.]", "", names(classes))
37		}
38	1x	if (!length(names(classes)) && identical(length(classes), length(columns))) {
39	!	names(classes) <- column_order
40		}
41	1x	for (name in intersect(names(columns), names(classes))) {
42	5x	if (classes[[name]] %in% c("numeric", "integer")) {
43	2x	columns[[name]] <- as.numeric(columns[[name]])
44		}
45	5x	if (identical(classes[[name]], "integer")) {
46	!	columns[[name]] <- as.integer(columns[[name]])
47		}
48		}
49	1x	data <- as.data.frame(columns, stringsAsFactors = FALSE)
50	1x	data
51		}
52
53		.evidence_execution_request <- function(details) {
54	1x	structure(details$request, class = "execution_request")
55		}
56
57		new_reproducibility_service <- function(
58		repository,
59		artifact_store,
60		runner = new_execution_runner(),
61		verification_service = new_verification_service()
62		) {
63	1x	.validate_evidence_repository(
64	1x	repository,
65	1x	c("get_revision", "list_evidence", "record_evidence")
66		)
67	1x	if (!is.list(artifact_store) \|\|
68	1x	!is.function(artifact_store$get) \|\|
69	1x	!is.function(artifact_store$verify)) {
70	!	cli::cli_abort("Reproducibility service requires a readable artifact store")
71		}
72	1x	if (!is.function(runner$run)) {
73	!	cli::cli_abort("Reproducibility runner must provide {.fn run}")
74		}
75	1x	if (!is.function(verification_service$verify)) {
76	!	cli::cli_abort("Verification service must provide {.fn verify}")
77		}
78
79	1x	reproduce_revision <- function(revision_id, idempotency_key = NULL) {
80	1x	.validate_identifier(revision_id, "revision_id")
81	1x	if (!is.null(idempotency_key)) {
82	1x	.validate_identifier(idempotency_key, "idempotency_key")
83		}
84	1x	revision <- repository$get_revision(revision_id)
85	1x	details <- .latest_revision_context(repository, revision_id)
86	1x	request <- .evidence_execution_request(details)
87	1x	script <- rawToChar(artifact_store$get(revision$code_hash))
88	1x	analysis_data <- .evidence_selected_data(details)
89	1x	runner_result <- runner$run(
90	1x	request = request,
91	1x	script = script,
92	1x	analysis_data = analysis_data,
93	1x	data_classification = details$input_data$classification %\|\|% "synthetic"
94		)
95	1x	verification <- verification_service$verify(
96	1x	request = request,
97	1x	script = script,
98	1x	analysis_data = analysis_data,
99	1x	runner_result = runner_result
100		)
101	1x	environment_match <- identical(
102	1x	runner_result$result$environment_fingerprint,
103	1x	details$environment$fingerprint
104		)
105	1x	checks <- list(
106	1x	specification = identical(request$spec_hash, revision$spec_hash),
107	1x	generated_r_code = identical(
108	1x	.execution_hash_text(script), revision$code_hash
109		),
110	1x	analytical_result = identical(
111	1x	runner_result$result$analytical_hash,
112	1x	revision$analytical_hash
113		),
114	1x	environment = environment_match,
115	1x	image_bytes = if (environment_match) {
116	1x	identical(runner_result$result$image_hash, revision$image_hash)
117		} else {
118	1x	NA
119		}
120		)
121	1x	failed <- names(checks)[vapply(checks, identical, logical(1), FALSE)]
122	1x	status <- if (length(failed)) "failed" else "passed"
123	1x	result <- structure(
124	1x	list(
125	1x	reproducibility_version = "revision-reproducibility-v1",
126	1x	status = status,
127	1x	checks = checks,
128	1x	failed_checks = failed,
129	1x	verification = unclass(verification)
130		),
131	1x	class = "revision_reproducibility_result"
132		)
133	1x	if (!is.null(idempotency_key)) {
134	1x	repository$record_evidence(
135	1x	evidence_id = .revision_evidence_id(revision_id, idempotency_key),
136	1x	revision_id = revision_id,
137	1x	evidence_type = "reproducibility_rerun",
138	1x	outcome = status,
139	1x	idempotency_key = idempotency_key,
140	1x	details = unclass(result)
141		)
142		}
143	1x	result
144		}
145
146	1x	structure(
147	1x	list(reproduce_revision = reproduce_revision),
148	1x	class = "reproducibility_service"
149		)
150		}

1		.validate_boxplot_design <- function(facet_levels, visit_levels, low_n_policy) {
2	54x	if (!checkmate::test_character(
3	54x	facet_levels,
4	54x	min.len = 1L,
5	54x	any.missing = FALSE,
6	54x	unique = TRUE
7	54x	) \|\| !checkmate::test_character(
8	54x	visit_levels,
9	54x	min.len = 1L,
10	54x	any.missing = FALSE,
11	54x	unique = TRUE
12		)) {
13	!	cli::cli_abort(paste0(
14	!	"Facet and visit levels must be ordered, ",
15	!	"unique character vectors"
16		))
17		}
18	54x	required_policy <- c("value", "rationale", "authority", "version")
19	54x	if (!is.list(low_n_policy) \|\|
20	54x	!setequal(names(low_n_policy), required_policy) \|\|
21	54x	!checkmate::test_number(low_n_policy$value, lower = 1, finite = TRUE) \|\|
22	54x	!all(vapply(
23	54x	low_n_policy[setdiff(required_policy, "value")],
24	54x	checkmate::test_string,
25	54x	logical(1),
26	54x	min.chars = 1L
27		))) {
28	!	cli::cli_abort(paste0(
29	!	"{.arg low_n_policy} must retain value, rationale, ",
30	!	"authority, and version"
31		))
32		}
33	54x	invisible(TRUE)
34		}
35
36		.validate_boxplot_inputs <- function(
37		data,
38		treatment_variable,
39		y_variable,
40		facet_levels,
41		visit_levels,
42		low_n_policy
43		) {
44	21x	required_columns <- c(
45	21x	"USUBJID", "AVISIT", "AVISITN", treatment_variable, y_variable
46		)
47	21x	missing_columns <- setdiff(required_columns, names(data))
48	21x	if (!is.data.frame(data) \|\| length(missing_columns)) {
49	!	cli::cli_abort(
50	!	paste0(
51	!	"{.arg data} must contain the governed analytical columns: ",
52	!	"{.field {required_columns}}"
53		)
54		)
55		}
56	21x	if (!is.numeric(data[[y_variable]])) {
57	!	cli::cli_abort("The selected Y variable must be numeric")
58		}
59	21x	.validate_boxplot_design(facet_levels, visit_levels, low_n_policy)
60		}
61
62		.type7_quantile_from_sorted <- function(values, probability) {
63	342x	count <- length(values)
64	342x	position <- (count - 1) * probability + 1
65	342x	lower_index <- floor(position)
66	342x	fraction <- position - lower_index
67	342x	if (fraction == 0 \|\| lower_index == count) {
68	158x	return(values[[lower_index]])
69		}
70	184x	values[[lower_index]] + fraction * (
71	184x	values[[lower_index + 1L]] - values[[lower_index]]
72		)
73		}
74
75		.summarize_box <- function(
76		rows,
77		treatment_variable,
78		y_variable,
79		low_n_threshold
80		) {
81	114x	values <- rows[[y_variable]]
82	114x	sorted_values <- sort(values, method = "radix")
83	114x	lower <- .type7_quantile_from_sorted(sorted_values, 0.25)
84	114x	middle <- .type7_quantile_from_sorted(sorted_values, 0.5)
85	114x	upper <- .type7_quantile_from_sorted(sorted_values, 0.75)
86	114x	interquartile_range <- upper - lower
87	114x	lower_fence <- lower - 1.5 * interquartile_range
88	114x	upper_fence <- upper + 1.5 * interquartile_range
89	114x	inside <- values >= lower_fence & values <= upper_fence
90	114x	distinct_n <- length(unique(as.character(rows$USUBJID)))
91
92	114x	list(
93	114x	box = data.frame(
94	114x	treatment = as.character(rows[[treatment_variable]][[1]]),
95	114x	visit = as.character(rows$AVISIT[[1]]),
96	114x	visit_n = rows$AVISITN[[1]],
97	114x	n = as.integer(distinct_n),
98	114x	ymin = min(values[inside]),
99	114x	lower = lower,
100	114x	middle = middle,
101	114x	upper = upper,
102	114x	ymax = max(values[inside]),
103	114x	low_n = distinct_n < low_n_threshold,
104	114x	stringsAsFactors = FALSE
105		),
106	114x	outliers = data.frame(
107	114x	treatment = as.character(rows[[treatment_variable]][!inside]),
108	114x	visit = as.character(rows$AVISIT[!inside]),
109	114x	visit_n = rows$AVISITN[!inside],
110	114x	USUBJID = as.character(rows$USUBJID[!inside]),
111	114x	value = values[!inside],
112	114x	stringsAsFactors = FALSE
113		)
114		)
115		}
116
117		.summarize_box_indices <- function(
118		index,
119		data,
120		treatment_variable,
121		y_variable,
122		low_n_threshold
123		) {
124	114x	.summarize_box(
125	114x	data[index, , drop = FALSE],
126	114x	treatment_variable,
127	114x	y_variable,
128	114x	low_n_threshold
129		)
130		}
131
132		.empty_outlier_data <- function() {
133	19x	data.frame(
134	19x	treatment = character(),
135	19x	visit = character(),
136	19x	visit_n = numeric(),
137	19x	USUBJID = character(),
138	19x	value = numeric(),
139	19x	stringsAsFactors = FALSE
140		)
141		}
142
143		#' Calculate governed longitudinal boxplot statistics
144		#'
145		#' Calculates type-7 hinges, 1.5-IQR whiskers, visible outlier membership,
146		#' distinct-subject counts, low-N flags, and median-line rows from the selected
147		#' analytical data. Missing selected Y values do not contribute.
148		#'
149		#' @param data Selected records from a validated visit-based BDS profile.
150		#' @param treatment_variable Name of the selected treatment variable.
151		#' @param y_variable Name of the selected numeric Y variable.
152		#' @param facet_levels Ordered included treatment values.
153		#' @param visit_levels Ordered included visit labels.
154		#' @param low_n_policy Retained policy with `value`, `rationale`, `authority`,
155		#' and `version`.
156		#'
157		#' @return A deterministic `boxplot_analysis` object.
158		#' @export
159		calculate_boxplot_statistics <- function(
160		data,
161		treatment_variable,
162		y_variable,
163		facet_levels,
164		visit_levels,
165		low_n_policy
166		) {
167	21x	.validate_boxplot_inputs(
168	21x	data,
169	21x	treatment_variable,
170	21x	y_variable,
171	21x	facet_levels,
172	21x	visit_levels,
173	21x	low_n_policy
174		)
175	21x	low_n_policy$value <- as.numeric(low_n_policy$value)
176	21x	display <- data[
177	21x	!is.na(data[[y_variable]]) &
178	21x	!is.na(data[[treatment_variable]]) &
179	21x	data[[treatment_variable]] %in% facet_levels &
180	21x	!is.na(data$AVISIT) &
181	21x	data$AVISIT %in% visit_levels, ,
182	21x	drop = FALSE
183		]
184	21x	if (any(!is.finite(display[[y_variable]]))) {
185	1x	cli::cli_abort("The selected Y variable must contain only finite values")
186		}
187	20x	if (nrow(display)) {
188	20x	treatment_order <- match(
189	20x	as.character(display[[treatment_variable]]),
190	20x	facet_levels
191		)
192	20x	visit_order <- match(as.character(display$AVISIT), visit_levels)
193	20x	ordering <- order(
194	20x	treatment_order,
195	20x	visit_order,
196	20x	as.character(display$USUBJID),
197	20x	method = "radix"
198		)
199	20x	display <- display[ordering, , drop = FALSE]
200	20x	row.names(display) <- NULL
201	20x	group_start <- c(
202	20x	TRUE,
203	20x	as.character(display[[treatment_variable]][-1L]) !=
204	20x	as.character(display[[treatment_variable]][-nrow(display)]) \|
205	20x	as.character(display$AVISIT[-1L]) !=
206	20x	as.character(display$AVISIT[-nrow(display)])
207		)
208	20x	group_id <- cumsum(group_start)
209	20x	summaries <- lapply(
210	20x	split(seq_len(nrow(display)), group_id),
211	20x	.summarize_box_indices,
212	20x	data = display,
213	20x	treatment_variable = treatment_variable,
214	20x	y_variable = y_variable,
215	20x	low_n_threshold = low_n_policy$value
216		)
217	20x	boxes <- do.call(rbind, lapply(summaries, `[[`, "box"))
218	20x	outlier_rows <- lapply(summaries, `[[`, "outliers")
219	20x	outliers <- if (sum(vapply(outlier_rows, nrow, integer(1))) > 0L) {
220	1x	do.call(rbind, outlier_rows)
221		} else {
222	19x	.empty_outlier_data()
223		}
224	20x	box_order <- order(
225	20x	match(boxes$treatment, facet_levels),
226	20x	match(boxes$visit, visit_levels),
227	20x	method = "radix"
228		)
229	20x	boxes <- boxes[box_order, , drop = FALSE]
230	20x	row.names(boxes) <- NULL
231	20x	if (nrow(outliers)) {
232	1x	outlier_order <- order(
233	1x	match(outliers$treatment, facet_levels),
234	1x	match(outliers$visit, visit_levels),
235	1x	outliers$value,
236	1x	outliers$USUBJID,
237	1x	method = "radix"
238		)
239	1x	outliers <- outliers[outlier_order, , drop = FALSE]
240	1x	row.names(outliers) <- NULL
241		}
242		} else {
243	!	boxes <- data.frame(
244	!	treatment = character(), visit = character(), visit_n = numeric(),
245	!	n = integer(), ymin = numeric(), lower = numeric(), middle = numeric(),
246	!	upper = numeric(), ymax = numeric(), low_n = logical(),
247	!	stringsAsFactors = FALSE
248		)
249	!	outliers <- .empty_outlier_data()
250		}
251	20x	medians <- boxes[c("treatment", "visit", "visit_n", "middle")]
252	20x	names(medians)[[4]] <- "median"
253	20x	n_strip <- boxes[c("treatment", "visit", "visit_n", "n", "low_n")]
254	20x	n_strip$label <- ifelse(
255	20x	n_strip$low_n,
256	20x	paste0("N = ", n_strip$n, " - Low N"),
257	20x	paste0("N = ", n_strip$n)
258		)
259
260	20x	structure(
261	20x	list(
262	20x	analysis_version = "boxplot-analysis-v1",
263	20x	treatment_variable = treatment_variable,
264	20x	y_variable = y_variable,
265	20x	facet_levels = facet_levels,
266	20x	visit_levels = visit_levels,
267	20x	low_n_policy = low_n_policy,
268	20x	boxes = boxes,
269	20x	outliers = outliers,
270	20x	medians = medians,
271	20x	n_strip = n_strip
272		),
273	20x	class = "boxplot_analysis"
274		)
275		}

1		reconcile_execution_attempts <- function(repository, revision_ids) {
2	1x	.validate_evidence_repository(
3	1x	repository,
4	1x	c("list_attempts", "complete_attempt")
5		)
6	1x	if (!checkmate::test_character(
7	1x	revision_ids,
8	1x	any.missing = FALSE,
9	1x	unique = TRUE
10		)) {
11	!	cli::cli_abort(
12	!	"{.arg revision_ids} must contain unique revision identifiers"
13		)
14		}
15	1x	reconciled <- list()
16	1x	for (revision_id in revision_ids) {
17	1x	attempts <- repository$list_attempts(revision_id)
18	1x	active <- attempts[is.na(attempts$outcome), , drop = FALSE]
19	!	if (!nrow(active)) next
20	1x	for (index in seq_len(nrow(active))) {
21	1x	attempt_id <- active$attempt_id[[index]]
22	1x	repository$complete_attempt(
23	1x	attempt_id,
24	1x	"failed",
25	1x	paste0("reconcile:", attempt_id)
26		)
27	1x	reconciled[[attempt_id]] <- "failed"
28		}
29		}
30	1x	structure(
31	1x	list(
32	1x	reconciliation_version = "attempt-reconciliation-v1",
33	1x	reconciled = reconciled
34		),
35	1x	class = "attempt_reconciliation"
36		)
37		}

1		mod_export_ui <- function(id) {
2	6x	ns <- shiny::NS(id)
3	6x	bslib::card(
4	6x	class = "assurance-panel",
5	6x	bslib::card_header("Controlled export"),
6	6x	bslib::card_body(
7	6x	shiny::uiOutput(ns("controls")),
8	6x	shiny::verbatimTextOutput(ns("message")),
9	6x	shiny::tableOutput(ns("receipts"))
10		)
11		)
12		}
13
14		mod_export_server <- function(id, current_revision, workspace_provider) {
15	15x	shiny::moduleServer(id, function(input, output, session) {
16	15x	message <- shiny::reactiveVal("No export attempted.")
17	15x	receipt_refresh <- shiny::reactiveVal(0L)
18
19	15x	export_ready <- shiny::reactive({
20	25x	identical(current_revision()$revision$status, "Reviewed")
21		})
22
23	15x	output$controls <- shiny::renderUI({
24	25x	shiny::tags$fieldset(
25	25x	disabled = if (!export_ready()) NA else NULL,
26	25x	shiny::selectInput(
27	25x	session$ns("actor_id"),
28	25x	"Actor",
29	25x	choices = c(
30	25x	"Creator" = "creator",
31	25x	"Statistical programmer" = "stat-programmer",
32	25x	"Biostatistician" = "biostatistician"
33		)
34		),
35	25x	shiny::textInput(
36	25x	session$ns("destination_id"), "Destination",
37	25x	value = "local"
38		),
39	25x	shiny::downloadButton(
40	25x	session$ns("download_zip"), "Export and download ZIP",
41	25x	enabled = export_ready()
42		)
43		)
44		})
45
46	15x	output$message <- shiny::renderText(message())
47	15x	output$download_zip <- shiny::downloadHandler(
48	15x	filename = function() {
49	13x	state <- current_revision()
50	13x	if (is.null(state$revision)) {
51	!	return("image-code.zip")
52		}
53	13x	paste0(state$revision$revision_id, "-image-code.zip")
54		},
55	15x	content = function(file) {
56	13x	shiny::req(export_ready())
57	8x	state <- current_revision()
58	8x	succeeded <- tryCatch(
59		{
60	8x	if (is.null(state$revision) \|\| is.null(state$repository)) {
61	!	cli::cli_abort("Create a revision before export")
62		}
63	8x	if (is.null(state$identity_provider)) {
64	!	cli::cli_abort("Export requires an identity provider")
65		}
66	8x	service <- new_export_service(
67	8x	state$repository,
68	8x	state$repository$artifact_store,
69	8x	workspace_provider,
70	8x	state$identity_provider
71		)
72	8x	receipt <- service$export_revision(
73	8x	revision_id = state$revision$revision_id,
74	8x	actor_id = input$actor_id,
75	8x	destination_id = input$destination_id,
76	8x	expected_version = as.integer(state$revision$version),
77	8x	idempotency_key = paste(
78	8x	"app-export",
79	8x	state$revision$revision_id,
80	8x	input$actor_id,
81	8x	input$destination_id,
82	8x	sep = ":"
83		)
84		)
85	7x	receipt_refresh(receipt_refresh() + 1L)
86	7x	.write_export_zip(receipt, file, state$revision$revision_id)
87	6x	message(paste("Exported", receipt$receipt_id, receipt$revision_id))
88	6x	TRUE
89		},
90	8x	error = function(error) {
91	2x	message(conditionMessage(error))
92	2x	FALSE
93		}
94		)
95	8x	shiny::req(succeeded)
96		},
97	15x	contentType = "application/zip"
98		)
99	15x	output$receipts <- shiny::renderTable(
100		{
101	31x	receipt_refresh()
102	31x	state <- current_revision()
103	31x	if (is.null(state$revision) \|\| is.null(state$repository)) {
104	7x	return(data.frame())
105		}
106	24x	state$repository$list_export_receipts(state$revision$revision_id)
107		},
108	15x	striped = TRUE,
109	15x	spacing = "s"
110		)
111		})
112		}
113
114		.write_export_zip <- function(export, file, revision_id) {
115	8x	if (is.null(export)) {
116	!	cli::cli_abort("Export the revision before download")
117		}
118	8x	if (!identical(export$revision_id, revision_id)) {
119	1x	cli::cli_abort("Export the current revision before download")
120		}
121
122	7x	root <- fs::dir_create(fs::file_temp("revision-download-"))
123	7x	fs::file_copy(export$code_path, fs::path(root, "script.R"))
124	7x	fs::file_copy(export$image_path, fs::path(root, "plot.png"))
125
126	7x	file <- fs::path_abs(file)
127	7x	old <- getwd()
128	7x	on.exit(
129		{
130	7x	setwd(old)
131	7x	fs::dir_delete(root)
132		},
133	7x	add = TRUE
134		)
135	7x	setwd(root)
136	7x	status <- utils::zip(file, c("script.R", "plot.png"), flags = "-q")
137	7x	if (!identical(status, 0L) \|\| !fs::file_exists(file)) {
138	!	cli::cli_abort("Could not create ZIP download")
139		}
140	7x	invisible(file)
141		}

1		.execution_request_fingerprint <- function(request, script, analysis_data) {
2	10x	canonical_hash(list(
3	10x	request = unclass(request),
4	10x	script_hash = .execution_hash_text(script),
5	10x	snapshot_hash = canonical_hash(analysis_data)
6		))
7		}
8
9		.execution_attempt_id <- function(idempotency_key) {
10	10x	paste0("attempt-", substr(canonical_hash(idempotency_key), 1L, 24L))
11		}
12
13		.execution_id <- function(prefix, attempt_id, suffix) {
14	18x	paste(
15	18x	prefix,
16	18x	substr(canonical_hash(list(attempt_id, suffix)), 1L, 24L),
17	18x	sep = "-"
18		)
19		}
20
21		new_execution_service <- function(
22		repository,
23		runner = new_callr_execution_runner(),
24		verification_service = new_verification_service(),
25		artifact_store = NULL
26		) {
27	11x	.validate_evidence_repository(
28	11x	repository,
29	11x	c(
30	11x	"record_attempt", "list_attempts", "complete_attempt",
31	11x	"record_evidence", "accept_artifact_bundle", "mark_verified",
32	11x	"get_revision"
33		)
34		)
35	11x	if (!is.function(runner$run)) {
36	!	cli::cli_abort("Execution runner must provide {.fn run}")
37		}
38	11x	if (!is.function(verification_service$verify)) {
39	!	cli::cli_abort("Verification service must provide {.fn verify}")
40		}
41
42	11x	start <- function(
43	11x	revision_id,
44	11x	request,
45	11x	script,
46	11x	analysis_data,
47	11x	idempotency_key
48		) {
49	11x	revision <- repository$get_revision(revision_id)
50	11x	if (!identical(revision$status, "Draft")) {
51	1x	cli::cli_abort("Only Draft revisions can be submitted for verification")
52		}
53	10x	attempts <- repository$list_attempts(revision_id)
54	10x	active <- attempts[is.na(attempts$outcome), , drop = FALSE]
55	10x	attempt_id <- .execution_attempt_id(idempotency_key)
56	10x	fingerprint <- .execution_request_fingerprint(
57	10x	request,
58	10x	script,
59	10x	analysis_data
60		)
61	10x	if (nrow(active) && !attempt_id %in% active$attempt_id) {
62	!	cli::cli_abort("A revision can have only one active execution attempt")
63		}
64	10x	repository$record_attempt(attempt_id, revision_id, fingerprint)
65	10x	invisible(list(
66	10x	revision_id = revision_id,
67	10x	revision_version = as.integer(revision$version),
68	10x	attempt_id = attempt_id,
69	10x	idempotency_key = idempotency_key,
70	10x	request = request,
71	10x	script = script,
72	10x	analysis_data = analysis_data,
73	10x	work_dir = fs::file_temp(pattern = paste0(attempt_id, "-"))
74		))
75		}
76
77	11x	complete <- function(attempt, runner_result) {
78	10x	verification <- verification_service$verify(
79	10x	request = attempt$request,
80	10x	script = attempt$script,
81	10x	analysis_data = attempt$analysis_data,
82	10x	runner_result = runner_result
83		)
84	10x	evidence_id <- .execution_id("evidence", attempt$attempt_id, "verification")
85	10x	repository$record_evidence(
86	10x	evidence_id = evidence_id,
87	10x	revision_id = attempt$revision_id,
88	10x	evidence_type = "execution_verification",
89	10x	outcome = verification$status,
90	10x	idempotency_key = paste0(attempt$idempotency_key, ":evidence"),
91	10x	details = list(
92	10x	attempt_id = attempt$attempt_id,
93	10x	verification = unclass(verification),
94	10x	execution_result = unclass(runner_result$result %\|\|% list()),
95	10x	environment = runner_result$environment %\|\|% list(
96	10x	fingerprint = runner_result$result$environment_fingerprint %\|\|%
97	10x	NA_character_
98		),
99	10x	diagnostics = runner_result$diagnostics
100		)
101		)
102	10x	if (!identical(verification$status, "passed")) {
103	2x	repository$complete_attempt(
104	2x	attempt$attempt_id,
105	2x	"failed",
106	2x	paste0(attempt$idempotency_key, ":terminal")
107		)
108	2x	return(invisible(list(
109	2x	attempt_id = attempt$attempt_id,
110	2x	status = "failed",
111	2x	verification = verification,
112	2x	runner_result = runner_result
113		)))
114		}
115	8x	if (!is.null(artifact_store)) {
116	7x	artifact_store$put(.execution_text_bytes(attempt$script))
117	7x	artifact_store$put(readBin(
118	7x	runner_result$image_path,
119	7x	what = "raw",
120	7x	n = fs::file_size(runner_result$image_path)
121		))
122		}
123	8x	repository$accept_artifact_bundle(
124	8x	bundle_id = .execution_id("bundle", attempt$attempt_id, "accepted"),
125	8x	revision_id = attempt$revision_id,
126	8x	code_hash = attempt$request$script_hash,
127	8x	image_hash = runner_result$result$image_hash,
128	8x	analytical_hash = runner_result$result$analytical_hash,
129	8x	idempotency_key = paste0(attempt$idempotency_key, ":bundle")
130		)
131	8x	repository$complete_attempt(
132	8x	attempt$attempt_id,
133	8x	"succeeded",
134	8x	paste0(attempt$idempotency_key, ":terminal")
135		)
136	8x	repository$mark_verified(
137	8x	attempt$revision_id,
138	8x	attempt$revision_version,
139	8x	paste0(attempt$idempotency_key, ":verified")
140		)
141	8x	invisible(list(
142	8x	attempt_id = attempt$attempt_id,
143	8x	status = "verified",
144	8x	verification = verification,
145	8x	result = runner_result$result,
146	8x	runner_result = runner_result
147		))
148		}
149
150	11x	submit <- function(
151	11x	revision_id,
152	11x	request,
153	11x	script,
154	11x	analysis_data,
155	11x	idempotency_key,
156	11x	data_classification = "synthetic"
157		) {
158	11x	attempt <- start(
159	11x	revision_id,
160	11x	request,
161	11x	script,
162	11x	analysis_data,
163	11x	idempotency_key
164		)
165	10x	runner_result <- tryCatch(
166	10x	runner$run(
167	10x	request = request,
168	10x	script = script,
169	10x	analysis_data = analysis_data,
170	10x	data_classification = data_classification,
171	10x	work_dir = attempt$work_dir
172		),
173	10x	error = \(error) {
174	1x	structure(
175	1x	list(
176	1x	status = "failed",
177	1x	manifest_version = "execution-runner-result-v1",
178	1x	diagnostics = list(stdout = "", stderr = conditionMessage(error))
179		),
180	1x	class = "execution_runner_result"
181		)
182		}
183		)
184	10x	complete(attempt, runner_result)
185		}
186
187	11x	structure(
188	11x	list(submit = submit, start = start, complete = complete),
189	11x	class = "execution_service"
190		)
191		}

1		mod_specification_ui <- function(id) {
2	6x	ns <- shiny::NS(id)
3	6x	bslib::card(
4	6x	class = "assurance-panel",
5	6x	bslib::card_header("Confirm plot choices"),
6	6x	bslib::card_body(
7	6x	tags$details(
8	6x	class = "f001-panel",
9	6x	open = NA,
10	6x	tags$summary("Plot type"),
11	6x	tags$div(
12	6x	class = "f001-panel-body",
13	6x	tags$p("Longitudinal numeric BDS boxplot"),
14	6x	tags$p(
15	6x	class = "text-body-secondary",
16	6x	"This is the plot pattern supported by the current POC."
17		)
18		)
19		),
20	6x	tags$details(
21	6x	class = "f001-panel",
22	6x	open = NA,
23	6x	tags$summary("Variables and settings"),
24	6x	tags$div(
25	6x	class = "f001-panel-body",
26	6x	shiny::uiOutput(ns("summary")),
27	6x	shiny::tableOutput(ns("fields")),
28	6x	shiny::uiOutput(ns("controls")),
29	6x	shiny::uiOutput(ns("message"))
30		)
31		)
32		)
33		)
34		}
35
36		mod_specification_server <- function(
37		id,
38		current_revision,
39		execute_revision = NULL,
40		create_correction = NULL
41		) {
42	16x	shiny::moduleServer(id, function(input, output, session) {
43	16x	message <- shiny::reactiveVal(NULL)
44
45	16x	output$summary <- shiny::renderUI({
46	20x	state <- current_revision()
47	20x	if (is.null(state$spec)) {
48	3x	return(div(
49	3x	class = "text-body-secondary", "No confirmed specification yet."
50		))
51		}
52	17x	if (!is.null(state$pending)) {
53	10x	return(div(
54	10x	class = "assurance-summary",
55	10x	tags$strong("Specification pending confirmation")
56		))
57		}
58	7x	div(
59	7x	class = "assurance-summary",
60	7x	tags$strong("Specification hash"),
61	7x	tags$code(state$spec$hash)
62		)
63		})
64
65	16x	output$fields <- shiny::renderTable(
66		{
67	20x	state <- current_revision()
68	20x	if (is.null(state$spec)) {
69	3x	return(data.frame())
70		}
71	17x	fields <- state$spec$fields
72	17x	data.frame(
73	17x	field = names(fields),
74	17x	value = vapply(fields, .display_value, character(1)),
75	17x	provenance = vapply(names(fields), function(name) {
76	136x	state$spec$provenance[[name]] %\|\|% ""
77	17x	}, character(1)),
78	17x	stringsAsFactors = FALSE
79		)
80		},
81	16x	striped = TRUE,
82	16x	bordered = FALSE,
83	16x	spacing = "s"
84		)
85
86	16x	output$controls <- shiny::renderUI({
87	26x	state <- current_revision()
88	26x	read_only <- is.null(state$pending) && !.can_create_correction(state)
89	26x	choices <- .specification_choices(state)
90	22x	fields <- state$spec$fields
91	22x	treatment_variable <- input$treatment_variable %\|\|%
92	22x	fields$treatment_variable %\|\|% choices$treatment_variables[[1]]
93	22x	paramcd <- input$paramcd %\|\|% fields$paramcd %\|\|% choices$parameters[[1]]
94	22x	units <- choices$units[[paramcd]] %\|\|% character()
95	22x	current_unit <- input$unit %\|\|% fields$unit
96	22x	selected_unit <- if (
97	22x	length(current_unit) == 1L && current_unit %in% units
98		) {
99	21x	current_unit
100	22x	} else if (length(units) == 1L) {
101	!	units[[1]]
102		} else {
103	1x	character()
104		}
105	22x	treatment_levels <- choices$treatment_levels[[treatment_variable]]
106	22x	current_treatment_levels <- input$treatment_levels %\|\|%
107	22x	fields$treatment_levels
108	22x	selected_treatment_levels <- if (
109	22x	length(current_treatment_levels) &&
110	22x	all(current_treatment_levels %in% treatment_levels)
111		) {
112	22x	current_treatment_levels
113		} else {
114	!	treatment_levels
115		}
116	22x	current_visits <- input$visits %\|\|% fields$visits
117	22x	selected_visits <- if (
118	22x	length(current_visits) && all(current_visits %in% choices$visits)
119		) {
120	22x	current_visits
121		} else {
122	!	choices$visits
123		}
124
125	22x	settings <- tagList(
126	22x	shiny::selectInput(
127	22x	session$ns("paramcd"), "Parameter", choices$parameters,
128	22x	selected = paramcd
129		),
130	22x	shiny::selectInput(
131	22x	session$ns("y_variable"),
132	22x	"Y variable",
133	22x	choices$y_variables,
134	22x	selected = fields$y_variable %\|\|% choices$y_variables[[1]]
135		),
136	22x	shiny::selectInput(
137	22x	session$ns("unit"), "Unit", units,
138	22x	selected = selected_unit
139		),
140	22x	shiny::selectInput(
141	22x	session$ns("treatment_variable"),
142	22x	"Treatment facet",
143	22x	choices$treatment_variables,
144	22x	selected = treatment_variable
145		),
146	22x	shiny::checkboxGroupInput(
147	22x	session$ns("treatment_levels"),
148	22x	"Included treatment levels",
149	22x	treatment_levels,
150	22x	selected = selected_treatment_levels
151		),
152	22x	shiny::checkboxGroupInput(
153	22x	session$ns("visits"),
154	22x	"Included visits",
155	22x	choices$visits,
156	22x	selected = selected_visits
157		),
158	22x	shiny::radioButtons(
159	22x	session$ns("scale_mode"),
160	22x	"Y scales",
161	22x	choices = c("Fixed" = "fixed", "Free" = "free"),
162	22x	selected = fields$scale_mode %\|\|% "fixed",
163	22x	inline = TRUE
164		),
165	22x	shiny::checkboxInput(
166	22x	session$ns("confirm_free_scale"),
167	22x	"I understand free Y scales create an Experimental/Draft revision",
168	22x	value = FALSE
169		)
170		)
171
172	22x	if (read_only) {
173	5x	return(tags$fieldset(
174	5x	disabled = TRUE,
175	5x	class = "specification-controls",
176	5x	tags$legend(class = "visually-hidden", "Confirmed plot settings"),
177	5x	settings
178		))
179		}
180
181	17x	tags$div(
182	17x	class = "specification-controls",
183	17x	settings,
184	17x	if (.can_create_correction(state)) {
185	2x	tagList(
186	2x	shiny::textAreaInput(
187	2x	session$ns("correction_rationale"),
188	2x	"Correction rationale",
189	2x	rows = 2
190		),
191	2x	shiny::textInput(
192	2x	session$ns("correction_provenance"),
193	2x	"Correction provenance"
194		),
195	2x	.assurance_task_button(
196	2x	session$ns("correct"),
197	2x	"Create correction revision",
198	2x	class = "btn-primary"
199		)
200		)
201		} else {
202	15x	.assurance_task_button(
203	15x	session$ns("execute"),
204	15x	"Confirm and generate",
205	15x	class = "btn-primary"
206		)
207		}
208		)
209		})
210
211	16x	output$message <- shiny::renderUI({
212	14x	text <- message()
213	14x	if (is.null(text)) {
214	13x	return(NULL)
215		}
216	1x	div(class = "assurance-message", role = "status", text)
217		})
218
219	16x	shiny::observeEvent(input$execute,
220		{
221	7x	message(NULL)
222	7x	if (!is.function(execute_revision)) {
223	!	message("Execution is unavailable in this context.")
224	!	return()
225		}
226	16x	if (
227	7x	identical(input$scale_mode, "free") &&
228	7x	!isTRUE(input$confirm_free_scale)
229		) {
230	1x	message("Free Y scales require confirmation before execution.")
231	1x	return()
232		}
233	6x	tryCatch(
234	6x	execute_revision(
235	6x	.current_spec_input_fields(input, current_revision())
236		),
237	6x	error = function(error) {
238	!	message(conditionMessage(error))
239		}
240		)
241		},
242	16x	ignoreInit = TRUE
243		)
244
245	16x	shiny::observeEvent(input$correct,
246		{
247	1x	message(NULL)
248	1x	if (!is.function(create_correction)) {
249	!	message("Correction is unavailable in this context.")
250	!	return()
251		}
252	16x	if (
253	1x	!checkmate::test_string(input$correction_rationale, min.chars = 1L) \|\|
254	1x	!checkmate::test_string(
255	1x	input$correction_provenance,
256	1x	min.chars = 1L
257		)
258		) {
259	!	message(
260	!	"Enter the correction rationale and provenance before continuing."
261		)
262	!	return()
263		}
264	16x	if (
265	1x	identical(input$scale_mode, "free") &&
266	1x	!isTRUE(input$confirm_free_scale)
267		) {
268	!	message("Free Y scales require confirmation before correction.")
269	!	return()
270		}
271	1x	tryCatch(
272	1x	create_correction(
273	1x	.current_spec_input_fields(input, current_revision()),
274	1x	input$correction_rationale,
275	1x	input$correction_provenance
276		),
277	1x	error = function(error) {
278	!	message(conditionMessage(error))
279		}
280		)
281		},
282	16x	ignoreInit = TRUE
283		)
284		})
285		}
286
287		.current_spec_input_fields <- function(input, state) {
288	7x	choices <- .specification_choices(state)
289	7x	fields <- state$spec$fields
290	7x	treatment_variable <- input$treatment_variable %\|\|%
291	7x	fields$treatment_variable %\|\|% choices$treatment_variables[[1]]
292	7x	paramcd <- input$paramcd %\|\|% fields$paramcd %\|\|% choices$parameters[[1]]
293	7x	units <- choices$units[[paramcd]] %\|\|% character()
294	7x	unit <- input$unit %\|\|% fields$unit %\|\|% if (length(units) == 1L) {
295	!	units[[1]]
296		} else {
297	!	NULL
298		}
299	7x	treatment_levels <- input$treatment_levels %\|\|%
300	7x	fields$treatment_levels %\|\|% choices$treatment_levels[[treatment_variable]]
301	7x	visits <- input$visits %\|\|% fields$visits %\|\|% choices$visits
302
303	7x	list(
304	7x	paramcd = paramcd,
305	7x	y_variable = input$y_variable %\|\|% fields$y_variable %\|\|%
306	7x	choices$y_variables[[1]],
307	7x	unit = unit,
308	7x	treatment_variable = treatment_variable,
309	7x	treatment_levels = treatment_levels,
310	7x	visits = visits,
311	7x	scale_mode = input$scale_mode %\|\|% fields$scale_mode %\|\|% "fixed"
312		)
313		}
314
315		.specification_choices <- function(state) {
316	33x	choices <- state$pending$choices %\|\|% state$choices
317	33x	if (is.null(choices)) {
318	4x	cli::cli_abort("Specification choices are unavailable")
319		}
320	29x	choices
321		}
322
323		.can_create_correction <- function(state) {
324	28x	!is.null(state$revision) &&
325	28x	state$revision$status %in% c("Rejected", "Reviewed") &&
326	28x	!is.null(state$choices)
327		}
328
329		.display_value <- function(value) {
330	136x	if (is.null(value)) {
331	1x	return("")
332		}
333	135x	paste(as.character(value), collapse = ", ")
334		}

1		new_actor <- function(id, roles, active = TRUE) {
2	112x	if (!checkmate::test_string(id, min.chars = 1) \|\|
3	112x	!checkmate::test_character(
4	112x	roles,
5	112x	min.len = 1L,
6	112x	any.missing = FALSE
7		) \|\|
8	112x	!checkmate::test_flag(active)) {
9	!	cli::cli_abort(paste0(
10	!	"An actor requires an identifier, at least one role, ",
11	!	"and an active flag"
12		))
13		}
14	112x	structure(
15	112x	list(id = id, roles = unique(roles), active = active),
16	112x	class = "submission_sync_actor"
17		)
18		}
19
20		authorize_revision_action <- function(actor, revision, action) {
21	2x	if (!inherits(actor, "submission_sync_actor") \|\|
22	2x	!inherits(revision, "plot_revision")) {
23	!	cli::cli_abort("Authorization requires an actor and plot revision")
24		}
25	2x	if (!actor$active) {
26	!	cli::cli_abort("The current actor is not active")
27		}
28	2x	if (action %in% c("approve", "reject") &&
29	2x	identical(actor$id, revision$creator_id)) {
30	1x	cli::cli_abort("A revision creator cannot review their own revision")
31		}
32	1x	if (action == "approve" &&
33	1x	!any(actor$roles %in% c("statistical_programmer", "biostatistician"))) {
34	1x	cli::cli_abort("The current actor is not eligible to approve a revision")
35		}
36	!	invisible(TRUE)
37		}

1		#' Calculate a stable content hash for study data
2		#'
3		#' The hash is independent of row order while preserving column names, types,
4		#' missing values, and stored values.
5		#'
6		#' @param data A data frame containing a study-data snapshot.
7		#'
8		#' @return A SHA-256 content hash.
9		#' @export
10		study_data_content_hash <- function(data) {
11	54x	if (!checkmate::test_data_frame(data, min.rows = 1L, min.cols = 1L)) {
12	!	cli::cli_abort("{.arg data} must be a non-empty data frame")
13		}
14
15	54x	normalized <- .normalize_study_data(data)
16	54x	payload <- lapply(normalized, function(column) {
17	651x	list(type = typeof(column), class = class(column), values = unname(column))
18		})
19	54x	canonical_hash(list(columns = names(normalized), data = payload))
20		}
21
22		.normalize_study_data <- function(data) {
23	139x	data <- data[, sort(names(data), method = "radix"), drop = FALSE]
24	139x	row_keys <- do.call(
25	139x	paste,
26	139x	c(lapply(data, .stable_column_text), sep = "\u001f")
27		)
28	139x	result <- data[
29	139x	order(row_keys, method = "radix", na.last = TRUE), ,
30	139x	drop = FALSE
31		]
32	139x	row.names(result) <- NULL
33	139x	result
34		}
35
36		.stable_column_text <- function(x) {
37	1582x	if (inherits(x, "POSIXt")) {
38	!	value <- format(x, "%Y-%m-%dT%H:%M:%OS6Z", tz = "UTC")
39	1582x	} else if (inherits(x, "Date")) {
40	!	value <- format(x, "%Y-%m-%d")
41	1582x	} else if (is.numeric(x)) {
42	525x	value <- ifelse(is.na(x), NA_character_, sprintf("%.17g", x))
43		} else {
44	1057x	value <- enc2utf8(as.character(x))
45		}
46	1582x	paste0(typeof(x), ":", ifelse(is.na(value), "<NA>", value))
47		}
48
49		.validate_study_data_provider <- function(provider) {
50	31x	if (!inherits(provider, "study_data_provider")) {
51	!	cli::cli_abort("{.arg provider} must be a {.cls study_data_provider}")
52		}
53	31x	invisible(provider)
54		}
55
56		#' List datasets authorized by a study-data provider
57		#'
58		#' @param provider A study-data provider.
59		#'
60		#' @return A deterministic data frame of authorized, non-patient metadata.
61		#' @export
62		list_study_catalog <- function(provider) {
63	4x	.validate_study_data_provider(provider)
64	4x	scenarios <- provider$manifest$scenarios
65	4x	catalog <- data.frame(
66	4x	dataset_id = vapply(scenarios, `[[`, "", "dataset_id"),
67	4x	classification = vapply(
68	4x	scenarios,
69	4x	function(scenario) scenario$classification %\|\|% NA_character_,
70		""
71		),
72	4x	adam_designation = vapply(scenarios, `[[`, "", "adam_designation"),
73	4x	metadata_version = vapply(scenarios, `[[`, "", "metadata_version"),
74	4x	content_hash = vapply(scenarios, `[[`, "", "content_hash"),
75	4x	snapshot_id = vapply(scenarios, `[[`, "", "snapshot_id"),
76	4x	scenario_id = vapply(scenarios, `[[`, "", "scenario_id"),
77	4x	purpose = vapply(scenarios, `[[`, "", "purpose"),
78	4x	expected_behavior = vapply(scenarios, `[[`, "", "expected_behavior"),
79	4x	stringsAsFactors = FALSE
80		)
81	4x	catalog$declared_keys <- I(lapply(scenarios, `[[`, "declared_keys"))
82	4x	catalog$permitted_treatment_variables <- I(lapply(
83	4x	scenarios,
84		`[[`,
85	4x	"permitted_treatment_variables"
86		))
87	4x	catalog <- catalog[, c(
88	4x	"dataset_id", "classification", "adam_designation", "declared_keys",
89	4x	"metadata_version", "content_hash", "permitted_treatment_variables",
90	4x	"snapshot_id", "scenario_id", "purpose", "expected_behavior"
91		)]
92	4x	catalog <- catalog[
93	4x	order(catalog$dataset_id, method = "radix"), ,
94	4x	drop = FALSE
95		]
96	4x	row.names(catalog) <- NULL
97	4x	catalog
98		}
99
100		#' Pin an authorized immutable study-data snapshot
101		#'
102		#' @param provider A study-data provider.
103		#' @param dataset_id One opaque dataset identifier from the authorized catalog.
104		#'
105		#' @return A hash-verified `study_data_snapshot`.
106		#' @export
107		pin_study_snapshot <- function(provider, dataset_id) {
108	27x	.validate_study_data_provider(provider)
109	27x	if (!checkmate::test_string(dataset_id, min.chars = 1L)) {
110	!	cli::cli_abort("{.arg dataset_id} must be one non-empty identifier")
111		}
112
113	27x	matches <- which(vapply(
114	27x	provider$manifest$scenarios,
115	27x	function(x) identical(x$dataset_id, dataset_id),
116	27x	logical(1)
117		))
118	27x	if (length(matches) != 1L) {
119	1x	cli::cli_abort(
120	1x	"{.val {dataset_id}} is not present in the authorized catalog"
121		)
122		}
123	26x	metadata <- provider$manifest$scenarios[[matches]]
124	26x	data <- provider$read_data(metadata)
125	26x	observed_hash <- study_data_content_hash(data)
126	26x	if (!identical(observed_hash, metadata$content_hash)) {
127	1x	cli::cli_abort(
128	1x	"The authorized snapshot content hash does not match its catalog entry"
129		)
130		}
131
132	25x	snapshot <- list(
133	25x	snapshot_contract_version = "study-snapshot-v1",
134	25x	snapshot_id = metadata$snapshot_id,
135	25x	dataset_id = metadata$dataset_id,
136	25x	adam_designation = metadata$adam_designation,
137	25x	declared_keys = unlist(metadata$declared_keys, use.names = FALSE),
138	25x	metadata_version = metadata$metadata_version,
139	25x	content_hash = metadata$content_hash,
140	25x	permitted_treatment_variables = unlist(
141	25x	metadata$permitted_treatment_variables,
142	25x	use.names = FALSE
143		),
144	25x	data = .normalize_study_data(data)
145		)
146	25x	if (!is.null(metadata$classification)) {
147	12x	snapshot$classification <- metadata$classification
148		}
149	25x	structure(snapshot, class = "study_data_snapshot")
150		}

1		.base_synthetic_bds <- function() {
2	!	data.frame(
3	!	STUDYID = "SYNTH001",
4	!	USUBJID = rep(sprintf("SYNTH001-%03d", 1:6), each = 3L),
5	!	PARAMCD = "ALT",
6	!	PARAM = "Alanine aminotransferase",
7	!	AVISIT = rep(c("Baseline", "Week 4", "Week 8"), times = 6L),
8	!	AVISITN = rep(c(0, 4, 8), times = 6L),
9	!	AVAL = c(
10	!	20, 24, 26, 22, 25, 28, 24, 27, 30,
11	!	26, 29, 32, 28, NA, 34, 30, NA, 36
12		),
13	!	CHG = c(
14	!	0, 4, 6, 0, 3, 6, 0, 3, 6,
15	!	0, 3, 6, 0, NA, 6, 0, NA, 6
16		),
17	!	PCHG = c(
18	!	0, 20, 30, 0, 13.6363636364, 27.2727272727,
19	!	0, 12.5, 25, 0, 11.5384615385, 23.0769230769,
20	!	0, NA, 21.4285714286, 0, NA, 20
21		),
22	!	AVALU = "U/L",
23	!	TRT01A = rep(c("Placebo", "Active"), each = 9L),
24	!	ANL01FL = rep(c("Y", "N"), 9L),
25	!	stringsAsFactors = FALSE
26		)
27		}
28
29		.synthetic_scenario_data <- function() {
30	!	standard <- .base_synthetic_bds()
31
32	!	multiple_units <- standard
33	!	multiple_units$AVALU[multiple_units$USUBJID == "SYNTH001-006"] <- "ukat/L"
34
35	!	duplicate_keys <- standard
36	!	duplicate_keys <- rbind(
37	!	duplicate_keys,
38	!	transform(
39	!	duplicate_keys[
40	!	duplicate_keys$USUBJID == "SYNTH001-001" &
41	!	duplicate_keys$AVISIT == "Week 4",
42		],
43	!	AVAL = 999
44		)
45		)
46
47	!	sparse_missing <- standard
48	!	sparse_missing$AVAL[
49	!	sparse_missing$AVISIT == "Week 4" &
50	!	sparse_missing$USUBJID %in% c("SYNTH001-005", "SYNTH001-006")
51	!	] <- NA_real_
52
53	!	empty_combination <- standard
54	!	empty_combination$AVAL[
55	!	empty_combination$TRT01A == "Active" & empty_combination$AVISIT == "Week 4"
56	!	] <- NA_real_
57
58	!	bad_visit_mapping <- standard
59	!	bad_visit_mapping$AVISITN[
60	!	bad_visit_mapping$USUBJID == "SYNTH001-001" &
61	!	bad_visit_mapping$AVISIT == "Week 4"
62	!	] <- 5
63
64	!	empty_treatment <- standard
65	!	empty_treatment$AVAL[empty_treatment$TRT01A == "Placebo"] <- NA_real_
66
67	!	extra_timepoint_keys <- standard
68	!	extra_timepoint_keys$ATPTN <- 1L
69	!	repeated <- extra_timepoint_keys[
70	!	extra_timepoint_keys$USUBJID == "SYNTH001-001" &
71	!	extra_timepoint_keys$AVISIT == "Week 4",
72		]
73	!	repeated$ATPTN <- 2L
74	!	extra_timepoint_keys <- rbind(extra_timepoint_keys, repeated)
75
76	!	identifier_canary <- standard
77	!	canary <- identifier_canary[
78	!	identifier_canary$USUBJID == "SYNTH001-001" &
79	!	identifier_canary$AVISIT == "Week 4",
80		]
81	!	canary$USUBJID <- "SYNTH-CANARY-DO-NOT-RETAIN"
82	!	identifier_canary <- rbind(
83	!	identifier_canary, canary, transform(canary, AVAL = 999)
84		)
85
86	!	exclusions <- standard
87	!	exclusions <- rbind(
88	!	exclusions,
89	!	exclusions[
90	!	exclusions$USUBJID == "SYNTH001-001" & exclusions$AVISIT == "Week 8",
91		]
92		)
93
94	!	list(
95	!	standard = standard,
96	!	`multiple-units` = multiple_units,
97	!	`duplicate-keys` = duplicate_keys,
98	!	`sparse-missing` = sparse_missing,
99	!	`empty-combination` = empty_combination,
100	!	`bad-visit-mapping` = bad_visit_mapping,
101	!	`empty-treatment` = empty_treatment,
102	!	`extra-timepoint-keys` = extra_timepoint_keys,
103	!	`identifier-canary` = identifier_canary,
104	!	exclusions = exclusions
105		)
106		}
107
108		.synthetic_scenario_purpose <- c(
109		standard = "Passing visit-based numeric BDS profile",
110		`multiple-units` = "Unresolved multiple-unit selection",
111		`duplicate-keys` = "Unsupported duplicate subject-parameter-visit key",
112		`sparse-missing` = "Six source subjects and four non-missing selected values",
113		`empty-combination` = "No display data for one treatment-visit combination",
114		`bad-visit-mapping` = "Conflicting AVISIT to AVISITN mapping",
115		`empty-treatment` = paste(
116		"Included treatment level with all selected", "Y values missing"
117		),
118		`extra-timepoint-keys` = paste(
119		"Legitimate additional timepoint key outside", "the cell profile"
120		),
121		`identifier-canary` = "Authorization-scoped duplicate identifier canary",
122		exclusions = "Explicit selections remove an otherwise blocking duplicate"
123		)
124
125		.synthetic_expected_behavior <- c(
126		standard = "passes",
127		`multiple-units` = "blocks:unit_selection_required",
128		`duplicate-keys` = "blocks:unsupported_duplicate_visit_key",
129		`sparse-missing` = "warns:low_sample_size",
130		`empty-combination` = "warns:empty_treatment_visit",
131		`bad-visit-mapping` = "blocks:invalid_visit_mapping",
132		`empty-treatment` = "warns:empty_treatment_level",
133		`extra-timepoint-keys` = "blocks:unsupported_additional_timepoint_keys",
134		`identifier-canary` = "blocks:unsupported_duplicate_visit_key",
135		exclusions = "passes:explicit_exclusions_precede_key_check"
136		)
137
138		.synthetic_declared_keys <- function(scenario_id) {
139	!	keys <- c("STUDYID", "USUBJID", "PARAMCD", "AVISITN")
140	!	if (identical(scenario_id, "extra-timepoint-keys")) c(keys, "ATPTN") else keys
141		}
142
143		.build_synthetic_manifest <- function(scenarios) {
144	!	entries <- lapply(names(scenarios), function(scenario_id) {
145	!	list(
146	!	scenario_id = scenario_id,
147	!	dataset_id = paste0("adlb-", scenario_id),
148	!	snapshot_id = paste0("synthetic-adlb-", scenario_id, "-v1"),
149	!	file = paste0("adlb-", scenario_id, ".rds"),
150	!	purpose = unname(.synthetic_scenario_purpose[[scenario_id]]),
151	!	expected_behavior = unname(.synthetic_expected_behavior[[scenario_id]]),
152	!	generator_version = "synthetic-bds-generator-v1",
153	!	seed = 20260906,
154	!	classification = "synthetic",
155	!	adam_designation = "BDS",
156	!	declared_keys = .synthetic_declared_keys(scenario_id),
157	!	metadata_version = "synthetic-adlb-metadata-v1",
158	!	permitted_treatment_variables = "TRT01A",
159	!	content_hash = study_data_content_hash(scenarios[[scenario_id]])
160		)
161		})
162	!	list(
163	!	manifest_version = "synthetic-bds-manifest-v1",
164	!	generator_version = "synthetic-bds-generator-v1",
165	!	classification = "synthetic",
166	!	clinical_evidence_use = FALSE,
167	!	scenarios = entries
168		)
169		}
170
171		.validate_synthetic_manifest <- function(manifest) {
172	22x	required_top <- c(
173	22x	"manifest_version", "generator_version", "classification",
174	22x	"clinical_evidence_use", "scenarios"
175		)
176	22x	required_scenario <- c(
177	22x	"scenario_id", "dataset_id", "snapshot_id", "file", "purpose",
178	22x	"expected_behavior", "generator_version", "seed", "classification",
179	22x	"adam_designation", "declared_keys", "metadata_version",
180	22x	"permitted_treatment_variables", "content_hash"
181		)
182	22x	valid <- is.list(manifest) && all(required_top %in% names(manifest)) &&
183	22x	identical(manifest$manifest_version, "synthetic-bds-manifest-v1") &&
184	22x	identical(manifest$classification, "synthetic") &&
185	22x	identical(manifest$clinical_evidence_use, FALSE) &&
186	22x	is.list(manifest$scenarios) && length(manifest$scenarios) > 0L &&
187	22x	all(vapply(manifest$scenarios, function(x) {
188	220x	all(required_scenario %in% names(x)) &&
189	220x	identical(x$classification, "synthetic") &&
190	220x	identical(x$adam_designation, "BDS") &&
191	220x	identical(x$generator_version, manifest$generator_version) &&
192	220x	all(vapply(
193	220x	x[c(
194	220x	"scenario_id", "dataset_id", "snapshot_id", "file", "purpose",
195	220x	"expected_behavior", "metadata_version", "content_hash"
196		)],
197	220x	checkmate::test_string,
198	220x	logical(1),
199	220x	min.chars = 1L
200		)) &&
201	220x	checkmate::test_string(x$file, pattern = "^adlb-[a-z0-9-]+\\.rds$") &&
202	220x	checkmate::test_string(x$content_hash, pattern = "^[a-f0-9]{64}$") &&
203	220x	checkmate::test_number(x$seed, finite = TRUE) &&
204	220x	checkmate::test_character(
205	220x	unlist(x$declared_keys, use.names = FALSE),
206	220x	min.len = 3L,
207	220x	any.missing = FALSE,
208	220x	unique = TRUE
209		) &&
210	220x	all(c("USUBJID", "PARAMCD", "AVISITN") %in%
211	220x	unlist(x$declared_keys, use.names = FALSE)) &&
212	220x	checkmate::test_character(
213	220x	unlist(x$permitted_treatment_variables, use.names = FALSE),
214	220x	min.len = 1L,
215	220x	any.missing = FALSE,
216	220x	unique = TRUE
217		)
218	22x	}, logical(1)))
219	22x	if (valid) {
220	20x	identifiers <- lapply(
221	20x	c("scenario_id", "dataset_id", "snapshot_id", "file"),
222	20x	function(field) vapply(manifest$scenarios, `[[`, "", field)
223		)
224	20x	valid <- all(vapply(identifiers, function(x) !anyDuplicated(x), logical(1)))
225		}
226	22x	if (!valid) {
227	3x	cli::cli_abort("The governed synthetic scenario manifest is invalid")
228		}
229	19x	invisible(manifest)
230		}
231
232		#' Read the governed synthetic scenario manifest
233		#'
234		#' @param root Governed synthetic-data directory.
235		#'
236		#' @return The validated versioned manifest.
237		#' @export
238		synthetic_scenario_manifest <- function(root = .synthetic_data_root()) {
239	14x	manifest <- jsonlite::read_json(
240	14x	file.path(root, "scenario-manifest.json"),
241	14x	simplifyVector = FALSE
242		)
243	14x	.validate_synthetic_manifest(manifest)
244	14x	manifest
245		}
246
247		#' Load a governed synthetic BDS scenario
248		#'
249		#' @param scenario_id Scenario identifier from [synthetic_scenario_manifest()].
250		#' @param root Governed synthetic-data directory.
251		#'
252		#' @return A hash-verified synthetic BDS data frame.
253		#' @export
254		load_synthetic_scenario <- function(
255		scenario_id, root = .synthetic_data_root()
256		) {
257	10x	if (!checkmate::test_string(scenario_id, min.chars = 1L)) {
258	!	cli::cli_abort("{.arg scenario_id} must be one non-empty identifier")
259		}
260	10x	manifest <- synthetic_scenario_manifest(root)
261	10x	matches <- which(vapply(
262	10x	manifest$scenarios,
263	10x	function(x) identical(x$scenario_id, scenario_id),
264	10x	logical(1)
265		))
266	10x	if (length(matches) != 1L) {
267	!	cli::cli_abort("{.val {scenario_id}} is not a governed synthetic scenario")
268		}
269	10x	metadata <- manifest$scenarios[[matches]]
270	10x	data <- readRDS(file.path(root, metadata$file))
271	10x	if (!identical(study_data_content_hash(data), metadata$content_hash)) {
272	!	cli::cli_abort(
273	!	"The synthetic scenario content hash does not match its manifest"
274		)
275		}
276	10x	data
277		}
278
279		.write_synthetic_scenarios <- function(root = .synthetic_data_root()) {
280	!	dir.create(root, recursive = TRUE, showWarnings = FALSE)
281	!	scenarios <- .synthetic_scenario_data()
282	!	manifest <- .build_synthetic_manifest(scenarios)
283	!	for (scenario in manifest$scenarios) {
284	!	saveRDS(
285	!	scenarios[[scenario$scenario_id]],
286	!	file.path(root, scenario$file),
287	!	version = 3,
288	!	compress = "xz"
289		)
290		}
291	!	jsonlite::write_json(
292	!	manifest,
293	!	file.path(root, "scenario-manifest.json"),
294	!	auto_unbox = TRUE,
295	!	pretty = TRUE,
296	!	null = "null",
297	!	digits = NA
298		)
299	!	invisible(manifest)
300		}

1		.prompt_context_blocked_terms <- c(
2		"USUBJID", "patient", "secret", "credential", "workspace", "path", "url",
3		"file", "directory", "comment", "diagnostic"
4		)
5
6		new_prompt_context <- function(
7		dataset_id, labels = list(), aggregate_profile = list()
8		) {
9	33x	if (!checkmate::test_string(dataset_id, min.chars = 1) \|\|
10	33x	!checkmate::test_list(labels) \|\|
11	33x	!checkmate::test_list(aggregate_profile)) {
12	!	cli::cli_abort(
13	!	"Prompt context requires an opaque dataset identifier and list inputs"
14		)
15		}
16	33x	if (!.assert_prompt_context_content(list(
17	33x	labels = labels, aggregate_profile = aggregate_profile
18		))) {
19	3x	cli::cli_abort("Prompt context contains prohibited content")
20		}
21	30x	payload <- list(
22	30x	version = "prompt-context-v1",
23	30x	dataset_id = dataset_id,
24	30x	labels = labels,
25	30x	aggregate_profile = aggregate_profile
26		)
27	30x	payload$hash <- canonical_hash(payload)
28	30x	structure(payload, class = "prompt_context")
29		}
30
31		.assert_prompt_context_content <- function(value) {
32	33x	content <- paste(unlist(value, use.names = TRUE), collapse = " ")
33	33x	pattern <- paste(
34	33x	c(.prompt_context_blocked_terms, "https?://"),
35	33x	collapse = "\|"
36		)
37	33x	if (grepl(pattern, content, ignore.case = TRUE)) {
38	3x	return(FALSE)
39		}
40	30x	TRUE
41		}

1		.validate_prompt_context <- function(context) {
2	23x	if (!inherits(context, "prompt_context")) {
3	!	cli::cli_abort("{.arg context} must be a {.cls prompt_context}")
4		}
5	23x	invisible(context)
6		}
7
8		.validate_prompt_interpreter <- function(interpreter) {
9	23x	if (!inherits(interpreter, "prompt_interpreter")) {
10	!	cli::cli_abort("{.arg interpreter} must be a {.cls prompt_interpreter}")
11		}
12	23x	invisible(interpreter)
13		}
14
15		#' Interpret a prompt through a provider-neutral adapter
16		#'
17		#' @param prompt One natural-language request.
18		#' @param context A `prompt_context`.
19		#' @param interpreter A prompt interpreter, such as `mock_prompt_interpreter()`.
20		#' @param snapshot Optional pinned snapshot used for U3 semantic validation.
21		#'
22		#' @return A `prompt_interpretation` with status, candidate, choices, and
23		#' provider metadata. It never includes executable code.
24		#' @export
25		interpret_prompt <- function(prompt, context, interpreter, snapshot = NULL) {
26	23x	if (!checkmate::test_string(prompt, min.chars = 1L)) {
27	!	cli::cli_abort("{.arg prompt} must be one non-empty string")
28		}
29	23x	.validate_prompt_context(context)
30	23x	.validate_prompt_interpreter(interpreter)
31
32	23x	blocked <- .detect_blocked_prompt(prompt)
33	23x	if (!is.null(blocked)) {
34	6x	return(.prompt_interpretation(
35	6x	status = "manual_selection",
36	6x	candidate = NULL,
37	6x	clarifications = list(reason = blocked),
38	6x	metadata = list(provider = interpreter$provider, provider_called = FALSE)
39		))
40		}
41
42	17x	raw <- interpreter$interpret(prompt = prompt, context = context)
43	17x	result <- .normalize_provider_result(raw, context, interpreter)
44	17x	if (identical(result$status, "candidate") && !is.null(snapshot)) {
45	3x	.validate_prompt_candidate(result$candidate, snapshot)
46		}
47	17x	result
48		}
49
50		.detect_blocked_prompt <- function(prompt) {
51	23x	checks <- c(
52	23x	arbitrary_r_deferred = paste(
53	23x	"\\b(run\|write\|execute\|compile)\\b.*\\b(r\|code\|script)\\b",
54	23x	paste0(
55	23x	"\\b(log[- ]?transform\|transform\|derive\|calculate\|compute\|mutate\|",
56	23x	"normaliz\\w\|standardiz\\w)\\b"
57		),
58	23x	"\\b(AVAL\|CHG\|PCHG)\\b\\s[-+/^]",
59	23x	"[-+/^]\\s\\b(AVAL\|CHG\|PCHG)\\b",
60	23x	"library\\s\\(\|ggplot\\s\\(\|system\\s*\\(",
61	23x	sep = "\|"
62		),
63	23x	prompt_injection = paste(
64	23x	"ignore (all )?(previous\|system)\|developer message\|tool instruction"
65		),
66	23x	path_or_url = "https?://\|[A-Za-z]:[\\\\/]\|\\\\\\\\\|\\.rds\\b\|\\.csv\\b",
67	23x	sensitive_content = "USUBJID\|patient\|secret\|credential\|workspace"
68		)
69	23x	matched <- names(checks)[vapply(
70	23x	checks, grepl, logical(1),
71	23x	x = prompt, ignore.case = TRUE
72		)]
73	6x	if (length(matched)) matched[[1]] else NULL
74		}
75
76		.normalize_provider_result <- function(raw, context, interpreter) {
77	17x	allowed <- c(
78	17x	"status", "fields", "clarifications", "required_confirmations", "metadata"
79		)
80	17x	extras <- setdiff(names(raw), allowed)
81	17x	if (length(extras)) {
82	1x	return(.prompt_interpretation(
83	1x	status = "manual_selection",
84	1x	candidate = NULL,
85	1x	clarifications = list(reason = "extra_provider_fields"),
86	1x	metadata = list(provider = interpreter$provider, provider_called = TRUE)
87		))
88		}
89	16x	if (!checkmate::test_choice(
90	16x	raw$status, c("candidate", "clarification", "manual_selection")
91		)) {
92	!	return(.prompt_interpretation(
93	!	status = "manual_selection",
94	!	candidate = NULL,
95	!	clarifications = list(reason = "malformed_provider_response"),
96	!	metadata = list(provider = interpreter$provider, provider_called = TRUE)
97		))
98		}
99	16x	if (!identical(raw$status, "candidate")) {
100	2x	return(.prompt_interpretation(
101	2x	status = raw$status,
102	2x	candidate = NULL,
103	2x	clarifications = raw$clarifications %\|\|% list(reason = raw$status),
104	2x	metadata = c(
105	2x	list(provider = interpreter$provider, provider_called = TRUE),
106	2x	raw$metadata %\|\|% list()
107		)
108		))
109		}
110
111	14x	fields <- raw$fields
112	14x	field_extras <- setdiff(names(fields), .plot_spec_fields)
113	14x	if (length(field_extras)) {
114	1x	return(.prompt_interpretation(
115	1x	status = "manual_selection",
116	1x	candidate = NULL,
117	1x	clarifications = list(reason = "extra_candidate_fields"),
118	1x	metadata = list(provider = interpreter$provider, provider_called = TRUE)
119		))
120		}
121	13x	candidate <- new_plot_spec(
122	13x	dataset_id = context$dataset_id,
123	13x	paramcd = fields$paramcd %\|\|% NULL,
124	13x	y_variable = fields$y_variable %\|\|% NULL,
125	13x	unit = fields$unit %\|\|% NULL,
126	13x	treatment_variable = fields$treatment_variable %\|\|% NULL,
127	13x	treatment_levels = fields$treatment_levels %\|\|% NULL,
128	13x	visits = fields$visits %\|\|% NULL,
129	13x	scale_mode = fields$scale_mode %\|\|% "fixed",
130	13x	provenance = .candidate_provenance(fields),
131	13x	state = "candidate"
132		)
133	13x	clarifications <- plot_spec_clarifications(candidate)
134	13x	status <- if (
135	13x	length(clarifications) \|\| length(raw$required_confirmations %\|\|% list())
136		) {
137	2x	"clarification"
138		} else {
139	11x	"candidate"
140		}
141	13x	.prompt_interpretation(
142	13x	status = status,
143	13x	candidate = candidate,
144	13x	clarifications = list(
145	13x	missing_fields = clarifications,
146	13x	required_confirmations = raw$required_confirmations %\|\|% list()
147		),
148	13x	metadata = c(
149	13x	list(
150	13x	provider = interpreter$provider,
151	13x	model = interpreter$model,
152	13x	provider_called = TRUE,
153	13x	interpreter_version = "prompt-interpreter-v1",
154	13x	schema_version = "plot-spec-v1",
155	13x	response_retention = "none"
156		),
157	13x	raw$metadata %\|\|% list()
158		)
159		)
160		}
161
162		.candidate_provenance <- function(fields) {
163	13x	provenance <- rep("prompt", length(fields))
164	13x	names(provenance) <- names(fields)
165	13x	provenance <- as.list(provenance)
166	13x	provenance$dataset_id <- "metadata"
167	!	if (is.null(fields$scale_mode)) provenance$scale_mode <- "default"
168	13x	provenance
169		}
170
171		.validate_prompt_candidate <- function(candidate, snapshot) {
172	3x	selections <- candidate$fields[
173	3x	setdiff(.plot_spec_fields, c("dataset_id", "scale_mode"))
174		]
175	3x	result <- validate_bds_profile(snapshot, selections)
176	3x	if (result$blocked) {
177	!	cli::cli_abort(
178	!	"The interpreted candidate does not satisfy the supported BDS profile"
179		)
180		}
181	3x	invisible(candidate)
182		}
183
184		.prompt_interpretation <- function(
185		status, candidate, clarifications, metadata
186		) {
187	23x	structure(
188	23x	list(
189	23x	version = "prompt-interpretation-v1",
190	23x	status = status,
191	23x	candidate = candidate,
192	23x	clarifications = clarifications,
193	23x	metadata = metadata,
194	23x	executable_code = NULL
195		),
196	23x	class = "prompt_interpretation"
197		)
198		}
199
200		`%\|\|%` <- function(x, y) {
201	257x	if (is.null(x)) y else x
202		}

1		#' Create a deterministic prompt interpreter for tests and local development
2		#'
3		#' @return A provider-neutral `prompt_interpreter`.
4		#' @export
5		mock_prompt_interpreter <- function() {
6	18x	structure(
7	18x	list(
8	18x	port = new_provider_port(
9	18x	"prompt_interpreter", c("structured_candidate", "clarification")
10		),
11	18x	provider = "deterministic-mock",
12	18x	model = "mock-rule-set-v1",
13	18x	interpret = .mock_interpret_prompt
14		),
15	18x	class = "prompt_interpreter"
16		)
17		}
18
19		.mock_interpret_prompt <- function(prompt, context) {
20	15x	profile <- context$aggregate_profile
21	15x	parameters <- profile$parameters
22	15x	paramcd <- .mock_match_parameter(prompt, parameters)
23	15x	if (is.null(paramcd)) {
24	2x	return(list(
25	2x	status = "clarification",
26	2x	clarifications = list(field = "paramcd", choices = names(parameters))
27		))
28		}
29	13x	units <- parameters[[paramcd]]$units
30	13x	unit <- .mock_match_value(prompt, units)
31	12x	if (is.null(unit) && length(units) == 1L) unit <- units[[1]]
32
33	13x	treatment_variable <- profile$treatment_variables[[1]]
34	13x	treatment_levels <- profile$treatment_levels[[treatment_variable]]
35	13x	included_treatment_levels <- .mock_exclude_values(prompt, treatment_levels)
36	13x	visits <- vapply(profile$visits, `[[`, "", "label")
37	13x	included_visits <- .mock_exclude_values(prompt, visits)
38	13x	scale_mode <- if (grepl(
39	13x	"free[- ]?scale\|free y\|separate scale", prompt,
40	13x	ignore.case = TRUE
41		)) {
42	1x	"free"
43		} else {
44	12x	"fixed"
45		}
46	13x	required_confirmations <- if (identical(scale_mode, "free")) {
47	1x	list(scale_mode = "Free scales create an Experimental/Draft candidate")
48		} else {
49	12x	list()
50		}
51	13x	clarifications <- if (length(units) > 1L && is.null(unit)) {
52	1x	list(field = "unit", choices = units)
53		} else {
54	12x	list()
55		}
56
57	13x	list(
58	13x	status = "candidate",
59	13x	fields = list(
60	13x	paramcd = paramcd,
61	13x	y_variable = .mock_y_variable(prompt, profile$y_variables),
62	13x	unit = unit,
63	13x	treatment_variable = treatment_variable,
64	13x	treatment_levels = included_treatment_levels,
65	13x	visits = included_visits,
66	13x	scale_mode = scale_mode
67		),
68	13x	clarifications = clarifications,
69	13x	required_confirmations = required_confirmations,
70	13x	metadata = list(prompt_template = "mock-prompt-template-v1")
71		)
72		}
73
74		.mock_match_parameter <- function(prompt, parameters) {
75	15x	matches <- names(parameters)[vapply(names(parameters), function(paramcd) {
76	15x	grepl(paste0("\\b", paramcd, "\\b"), prompt, ignore.case = TRUE) \|\|
77	15x	grepl(tolower(parameters[[paramcd]]$label), tolower(prompt), fixed = TRUE)
78	15x	}, logical(1))]
79	2x	if (length(matches) == 1L) matches[[1]] else NULL
80		}
81
82		.mock_match_value <- function(prompt, values) {
83	13x	matches <- values[vapply(
84	13x	tolower(values), grepl, logical(1),
85	13x	x = tolower(prompt), fixed = TRUE
86		)]
87	!	if (length(matches) == 1L) matches[[1]] else NULL
88		}
89
90		.mock_y_variable <- function(prompt, choices) {
91	13x	if ("PCHG" %in% choices && grepl(
92	13x	"percent\|percentage\|pct\|PCHG", prompt,
93	13x	ignore.case = TRUE
94		)) {
95	1x	return("PCHG")
96		}
97	12x	if ("CHG" %in% choices && grepl("change\|CHG", prompt, ignore.case = TRUE)) {
98	1x	return("CHG")
99		}
100	11x	"AVAL"
101		}
102
103		.mock_exclude_values <- function(prompt, values) {
104	26x	kept <- values
105	26x	for (value in values) {
106	65x	pattern <- paste0(
107	65x	"\\b(exclude\|without\|omit)\\b[^.]*\\b",
108	65x	gsub(" ", "\\\\s+", value), "\\b"
109		)
110	65x	if (grepl(pattern, prompt, ignore.case = TRUE)) {
111	2x	kept <- setdiff(kept, value)
112		}
113		}
114	26x	kept
115		}

1		.standalone_boxplot_stats <- function(
2		data,
3		treatment_variable,
4		y_variable,
5		facet_levels,
6		visit_levels,
7		low_n_policy
8		) {
9	20x	required_columns <- c(
10	20x	"USUBJID", "AVISIT", "AVISITN", treatment_variable, y_variable
11		)
12	20x	if (!is.data.frame(data) \|\| length(setdiff(required_columns, names(data)))) {
13	!	cli::cli_abort(paste0(
14	!	"analysis_data must contain USUBJID, AVISIT, AVISITN, ",
15	!	"treatment, and Y columns"
16		))
17		}
18	20x	if (!is.numeric(data[[y_variable]])) {
19	!	cli::cli_abort("The selected Y variable must be numeric")
20		}
21	20x	if (!is.character(facet_levels) \|\| !length(facet_levels) \|\|
22	20x	anyDuplicated(facet_levels) \|\|
23	20x	!is.character(visit_levels) \|\| !length(visit_levels) \|\|
24	20x	anyDuplicated(visit_levels)) {
25	!	cli::cli_abort(paste0(
26	!	"Facet and visit levels must be ordered, ",
27	!	"unique character vectors"
28		))
29		}
30	20x	if (!is.list(low_n_policy) \|\|
31	20x	!identical(
32	20x	sort(names(low_n_policy)),
33	20x	sort(c("value", "rationale", "authority", "version"))
34		) \|\|
35	20x	!is.numeric(low_n_policy$value) \|\| length(low_n_policy$value) != 1L \|\|
36	20x	!is.finite(low_n_policy$value) \|\| low_n_policy$value < 1) {
37	!	cli::cli_abort(paste0(
38	!	"low_n_policy must retain value, rationale, ",
39	!	"authority, and version"
40		))
41		}
42	20x	if (!all(vapply(
43	20x	low_n_policy[c("rationale", "authority", "version")],
44	20x	function(value) {
45	60x	is.character(value) && length(value) == 1L && nzchar(value)
46		},
47	20x	logical(1)
48		))) {
49	!	cli::cli_abort("low_n_policy text fields must be non-empty strings")
50		}
51	20x	type7_quantile <- function(values, probability) {
52	354x	position <- (length(values) - 1) * probability + 1
53	354x	lower_index <- floor(position)
54	354x	fraction <- position - lower_index
55	354x	if (fraction == 0 \|\| lower_index == length(values)) {
56	158x	return(values[[lower_index]])
57		}
58	196x	values[[lower_index]] + fraction * (
59	196x	values[[lower_index + 1L]] - values[[lower_index]]
60		)
61		}
62	20x	summarize_box <- function(rows) {
63	118x	values <- rows[[y_variable]]
64	118x	sorted_values <- sort(values, method = "radix")
65	118x	lower <- type7_quantile(sorted_values, 0.25)
66	118x	middle <- type7_quantile(sorted_values, 0.5)
67	118x	upper <- type7_quantile(sorted_values, 0.75)
68	118x	interquartile_range <- upper - lower
69	118x	inside <- values >= lower - 1.5 * interquartile_range &
70	118x	values <= upper + 1.5 * interquartile_range
71	118x	distinct_n <- length(unique(as.character(rows$USUBJID)))
72	118x	list(
73	118x	box = data.frame(
74	118x	treatment = as.character(rows[[treatment_variable]][[1]]),
75	118x	visit = as.character(rows$AVISIT[[1]]),
76	118x	visit_n = rows$AVISITN[[1]],
77	118x	n = as.integer(distinct_n),
78	118x	ymin = min(values[inside]),
79	118x	lower = lower,
80	118x	middle = middle,
81	118x	upper = upper,
82	118x	ymax = max(values[inside]),
83	118x	low_n = distinct_n < low_n_policy$value,
84	118x	stringsAsFactors = FALSE
85		),
86	118x	outliers = data.frame(
87	118x	treatment = as.character(rows[[treatment_variable]][!inside]),
88	118x	visit = as.character(rows$AVISIT[!inside]),
89	118x	visit_n = rows$AVISITN[!inside],
90	118x	USUBJID = as.character(rows$USUBJID[!inside]),
91	118x	value = values[!inside],
92	118x	stringsAsFactors = FALSE
93		)
94		)
95		}
96	20x	empty_outliers <- function() {
97	20x	data.frame(
98	20x	treatment = character(), visit = character(), visit_n = numeric(),
99	20x	USUBJID = character(), value = numeric(), stringsAsFactors = FALSE
100		)
101		}
102	20x	low_n_policy$value <- as.numeric(low_n_policy$value)
103	20x	display <- data[
104	20x	!is.na(data[[y_variable]]) &
105	20x	!is.na(data[[treatment_variable]]) &
106	20x	data[[treatment_variable]] %in% facet_levels &
107	20x	!is.na(data$AVISIT) & data$AVISIT %in% visit_levels, ,
108	20x	drop = FALSE
109		]
110	20x	if (any(!is.finite(display[[y_variable]]))) {
111	!	cli::cli_abort("The selected Y variable must contain only finite values")
112		}
113	20x	if (nrow(display)) {
114	20x	ordering <- order(
115	20x	match(as.character(display[[treatment_variable]]), facet_levels),
116	20x	match(as.character(display$AVISIT), visit_levels),
117	20x	as.character(display$USUBJID),
118	20x	method = "radix"
119		)
120	20x	display <- display[ordering, , drop = FALSE]
121	20x	row.names(display) <- NULL
122	20x	group_start <- c(
123	20x	TRUE,
124	20x	as.character(display[[treatment_variable]][-1L]) !=
125	20x	as.character(display[[treatment_variable]][-nrow(display)]) \|
126	20x	as.character(display$AVISIT[-1L]) !=
127	20x	as.character(display$AVISIT[-nrow(display)])
128		)
129	20x	summaries <- lapply(
130	20x	split(seq_len(nrow(display)), cumsum(group_start)),
131	20x	function(index) {
132	118x	summarize_box(display[index, , drop = FALSE])
133		}
134		)
135	20x	boxes <- do.call(rbind, lapply(summaries, `[[`, "box"))
136	20x	outlier_rows <- lapply(summaries, `[[`, "outliers")
137	20x	outliers <- if (sum(vapply(outlier_rows, nrow, integer(1))) > 0L) {
138	!	do.call(rbind, outlier_rows)
139		} else {
140	20x	empty_outliers()
141		}
142	20x	box_order <- order(
143	20x	match(boxes$treatment, facet_levels),
144	20x	match(boxes$visit, visit_levels),
145	20x	method = "radix"
146		)
147	20x	boxes <- boxes[box_order, , drop = FALSE]
148	20x	row.names(boxes) <- NULL
149	20x	if (nrow(outliers)) {
150	!	outlier_order <- order(
151	!	match(outliers$treatment, facet_levels),
152	!	match(outliers$visit, visit_levels),
153	!	outliers$value,
154	!	outliers$USUBJID,
155	!	method = "radix"
156		)
157	!	outliers <- outliers[outlier_order, , drop = FALSE]
158	!	row.names(outliers) <- NULL
159		}
160		} else {
161	!	boxes <- data.frame(
162	!	treatment = character(), visit = character(), visit_n = numeric(),
163	!	n = integer(), ymin = numeric(), lower = numeric(), middle = numeric(),
164	!	upper = numeric(), ymax = numeric(), low_n = logical(),
165	!	stringsAsFactors = FALSE
166		)
167	!	outliers <- empty_outliers()
168		}
169	20x	medians <- boxes[c("treatment", "visit", "visit_n", "middle")]
170	20x	names(medians)[[4]] <- "median"
171	20x	n_strip <- boxes[c("treatment", "visit", "visit_n", "n", "low_n")]
172	20x	n_strip$label <- ifelse(
173	20x	n_strip$low_n,
174	20x	paste0("N = ", n_strip$n, " - Low N"),
175	20x	paste0("N = ", n_strip$n)
176		)
177	20x	structure(
178	20x	list(
179	20x	analysis_version = "boxplot-analysis-v1",
180	20x	treatment_variable = treatment_variable,
181	20x	y_variable = y_variable,
182	20x	facet_levels = facet_levels,
183	20x	visit_levels = visit_levels,
184	20x	low_n_policy = low_n_policy,
185	20x	boxes = boxes,
186	20x	outliers = outliers,
187	20x	medians = medians,
188	20x	n_strip = n_strip
189		),
190	20x	class = "boxplot_analysis"
191		)
192		}
193
194		.standalone_assemble_boxplot <- function(
195		analysis,
196		scale_mode = c("fixed", "free"),
197		unit = NULL
198		) {
199	20x	if (!inherits(analysis, "boxplot_analysis")) {
200	!	cli::cli_abort("analysis must be a boxplot_analysis object")
201		}
202	20x	scale_mode <- match.arg(scale_mode)
203	20x	plot_data <- analysis[c("boxes", "outliers", "medians", "n_strip")]
204	20x	plot_data <- lapply(plot_data, function(data) {
205	80x	data$treatment <- factor(data$treatment, levels = analysis$facet_levels)
206	80x	data$visit <- factor(data$visit, levels = analysis$visit_levels)
207	80x	data
208		})
209	20x	y_label <- if (is.null(unit) \|\| !nzchar(unit)) {
210	!	analysis$y_variable
211		} else {
212	20x	paste0(analysis$y_variable, " (", unit, ")")
213		}
214	20x	facet_scales <- if (identical(scale_mode, "free")) "free_y" else "fixed"
215	20x	plot_theme <- ggplot2::theme_bw(base_size = 12) +
216	20x	ggplot2::theme(
217	20x	panel.border = ggplot2::element_rect(
218	20x	color = "black", fill = NA, linewidth = 1
219		),
220	20x	panel.grid.major = ggplot2::element_line(
221	20x	color = "grey90", linewidth = 0.3
222		),
223	20x	panel.grid.minor = ggplot2::element_blank(),
224	20x	text = ggplot2::element_text(face = "bold"),
225	20x	axis.text = ggplot2::element_text(face = "bold", color = "black"),
226	20x	axis.text.x = ggplot2::element_blank(),
227	20x	axis.ticks.x = ggplot2::element_blank(),
228	20x	strip.background = ggplot2::element_rect(
229	20x	fill = "grey85", color = "black", linewidth = 1
230		),
231	20x	strip.text = ggplot2::element_text(face = "bold", color = "black")
232		)
233	20x	plot <- ggplot2::ggplot(
234	20x	plot_data$boxes,
235	20x	ggplot2::aes(
236	20x	x = visit, ymin = ymin, lower = lower, middle = middle,
237	20x	upper = upper, ymax = ymax
238		)
239		) +
240	20x	ggplot2::geom_boxplot(
241	20x	stat = "identity", outlier.shape = NA, fill = "white",
242	20x	color = "black", linewidth = 0.6
243		) +
244	20x	ggplot2::geom_line(
245	20x	data = plot_data$medians,
246	20x	mapping = ggplot2::aes(x = visit, y = median, group = treatment),
247	20x	inherit.aes = FALSE,
248	20x	linewidth = 0.8,
249	20x	color = "black"
250		) +
251	20x	ggplot2::geom_point(
252	20x	data = plot_data$medians,
253	20x	mapping = ggplot2::aes(x = visit, y = median),
254	20x	inherit.aes = FALSE,
255	20x	shape = 21,
256	20x	size = 3,
257	20x	fill = "white",
258	20x	color = "black",
259	20x	stroke = 1.2
260		) +
261	20x	ggplot2::geom_point(
262	20x	data = plot_data$outliers,
263	20x	mapping = ggplot2::aes(x = visit, y = value),
264	20x	inherit.aes = FALSE,
265	20x	shape = 1,
266	20x	size = 2.5,
267	20x	color = "black",
268	20x	stroke = 1
269		) +
270	20x	ggplot2::facet_wrap(
271	20x	ggplot2::vars(treatment),
272	20x	scales = facet_scales, drop = FALSE
273		) +
274	20x	ggplot2::scale_x_discrete(drop = FALSE, limits = analysis$visit_levels) +
275	20x	ggplot2::labs(x = NULL, y = y_label) +
276	20x	plot_theme
277	20x	n_strip <- ggplot2::ggplot(
278	20x	plot_data$n_strip,
279	20x	ggplot2::aes(x = visit, y = 1, label = label)
280		) +
281	20x	ggplot2::geom_text(
282	20x	na.rm = TRUE, size = 4, color = "black", fontface = "bold"
283		) +
284	20x	ggplot2::facet_wrap(ggplot2::vars(treatment), drop = FALSE) +
285	20x	ggplot2::scale_x_discrete(drop = FALSE, limits = analysis$visit_levels) +
286	20x	ggplot2::scale_y_continuous(limits = c(0.5, 1.5)) +
287	20x	ggplot2::labs(x = "Analysis Visit", y = NULL) +
288	20x	ggplot2::theme_bw(base_size = 12) +
289	20x	ggplot2::theme(
290	20x	panel.border = ggplot2::element_rect(
291	20x	color = "black", fill = NA, linewidth = 1
292		),
293	20x	text = ggplot2::element_text(face = "bold"),
294	20x	axis.text = ggplot2::element_text(face = "bold", color = "black"),
295	20x	axis.text.y = ggplot2::element_blank(),
296	20x	axis.ticks.y = ggplot2::element_blank(),
297	20x	panel.grid = ggplot2::element_blank(),
298	20x	strip.text = ggplot2::element_blank(),
299	20x	strip.background = ggplot2::element_rect(
300	20x	fill = "grey85", color = "black", linewidth = 1
301		)
302		)
303	20x	combined <- patchwork::wrap_plots(
304	20x	plot,
305	20x	n_strip,
306	20x	ncol = 1L,
307	20x	heights = c(4, 1)
308		)
309	20x	structure(
310	20x	list(
311	20x	artifact_version = "boxplot-artifact-v1",
312	20x	status = if (identical(scale_mode, "free")) {
313	!	"Experimental/Draft"
314		} else {
315	20x	"Draft"
316		},
317	20x	warning = if (identical(scale_mode, "free")) {
318	!	"Free Y scales weaken cross-facet visual comparison."
319		} else {
320	20x	NULL
321		},
322	20x	scale_mode = scale_mode,
323	20x	analysis = analysis,
324	20x	plot_data = plot_data,
325	20x	plot = plot,
326	20x	n_strip = n_strip,
327	20x	combined = combined
328		),
329	20x	class = "boxplot_artifact"
330		)
331		}
332
333		.standalone_function_text <- function(name, fn) {
334	!	paste0(name, " <- ", paste(deparse(fn), collapse = "\n"))
335		}

1		new_lifecycle_service <- function(repository) {
2	6x	.validate_evidence_repository(
3	6x	repository,
4	6x	c("get_revision", "list_revisions", "create_revision")
5		)
6
7	6x	create_correction <- function(
8	6x	parent_revision_id, revision_id, creator_id, spec_hash,
9	6x	code_hash, image_hash, analytical_hash, rationale,
10	6x	provenance, idempotency_key, initial_status = "Draft"
11		) {
12	7x	if (!checkmate::test_string(rationale, min.chars = 1)) {
13	1x	cli::cli_abort("Correction rationale is required")
14		}
15	6x	if (!checkmate::test_string(provenance, min.chars = 1)) {
16	!	cli::cli_abort("Correction provenance is required")
17		}
18	6x	parent <- repository$get_revision(parent_revision_id)
19	6x	if (!parent$status %in% c("Rejected", "Reviewed")) {
20	2x	cli::cli_abort("Only a closed revision can have a correction successor")
21		}
22	4x	revisions <- repository$list_revisions(parent$plot_id)
23	4x	repository$create_revision(
24	4x	parent$plot_id, revision_id, max(revisions$revision_number) + 1L,
25	4x	creator_id, spec_hash, code_hash, image_hash, analytical_hash,
26	4x	idempotency_key,
27	4x	parent_revision_id = parent_revision_id, correction_rationale = rationale,
28	4x	correction_provenance = provenance, initial_status = initial_status
29		)
30	4x	invisible(repository$get_revision(revision_id))
31		}
32	6x	structure(
33	6x	list(
34	6x	create_correction = create_correction
35		),
36	6x	class = "lifecycle_service"
37		)
38		}

1		local_identity_provider <- function(actors) {
2	51x	if (!is.list(actors) \|\| !all(vapply(
3	51x	actors, inherits, logical(1), "submission_sync_actor"
4		))) {
5	!	cli::cli_abort("Local identities must be submission sync actors")
6		}
7	51x	ids <- vapply(actors, `[[`, character(1), "id")
8	51x	if (anyDuplicated(ids)) {
9	!	cli::cli_abort("Local identity identifiers must be unique")
10		}
11
12	51x	get_actor <- function(actor_id) {
13	93x	if (!checkmate::test_string(actor_id, min.chars = 1)) {
14	!	cli::cli_abort("Actor identifier is required")
15		}
16	93x	match <- which(ids == actor_id)
17	93x	if (!length(match)) {
18	!	cli::cli_abort("Authenticated actor {.val {actor_id}} was not found")
19		}
20	93x	actors[[match]]
21		}
22	51x	structure(list(get_actor = get_actor), class = "local_identity_provider")
23		}

1		.verification_checks <- function(
2		request, script, analysis_data, runner_result
3		) {
4	19x	result <- runner_result$result
5	19x	checks <- list(
6	19x	schema = inherits(request, "execution_request"),
7	19x	script_hash = identical(.execution_hash_text(script), request$script_hash),
8	19x	snapshot_hash = identical(
9	19x	canonical_hash(analysis_data), request$snapshot_hash
10		),
11	19x	runner_success = identical(runner_result$status, "succeeded"),
12	19x	runner_manifest = identical(
13	19x	runner_result$manifest_version,
14	19x	"execution-runner-result-v1"
15		),
16	19x	result_manifest = inherits(result, "execution_result") &&
17	19x	identical(result$manifest_version, "execution-result-v1"),
18	19x	request_binding = FALSE,
19	19x	analytical_hash = FALSE,
20	19x	image_hash = FALSE,
21	19x	environment_fingerprint = FALSE
22		)
23	19x	if (isTRUE(checks$result_manifest)) {
24	16x	request_fields <- setdiff(names(unclass(request)), "manifest_version")
25	16x	checks$request_binding <- identical(
26	16x	unclass(result)[request_fields],
27	16x	unclass(request)[request_fields]
28		)
29	16x	checks$analytical_hash <- identical(
30	16x	result$analytical_hash,
31	16x	canonical_hash(runner_result$analytical_output)
32		)
33	16x	image_exists <- checkmate::test_string(
34	16x	runner_result$image_path,
35	16x	min.chars = 1L
36	16x	) && fs::file_exists(runner_result$image_path) &&
37	16x	fs::file_size(runner_result$image_path) > 0
38	16x	checks$image_hash <- image_exists &&
39	16x	checkmate::test_string(result$image_hash, pattern = "^[0-9a-f]{64}$") &&
40	16x	identical(
41	16x	.execution_hash_file(runner_result$image_path),
42	16x	result$image_hash
43		)
44	16x	checks$environment_fingerprint <- checkmate::test_string(
45	16x	result$environment_fingerprint,
46	16x	pattern = "^[0-9a-f]{64}$"
47		)
48		}
49	19x	checks
50		}
51
52		verify_execution_result <- function(
53		request, script, analysis_data, runner_result
54		) {
55	19x	checks <- .verification_checks(request, script, analysis_data, runner_result)
56	19x	failed <- names(checks)[!unlist(checks, use.names = FALSE)]
57	19x	structure(
58	19x	list(
59	19x	verification_version = "execution-verification-v1",
60	19x	status = if (length(failed)) "failed" else "passed",
61	19x	checks = checks,
62	19x	failed_checks = failed
63		),
64	19x	class = "execution_verification"
65		)
66		}
67
68		new_verification_service <- function() {
69	12x	structure(
70	12x	list(verify = verify_execution_result),
71	12x	class = "verification_service"
72		)
73		}

1		#' Run the Shiny Application
2		#'
3		#' @param ... arguments to pass to golem_opts.
4		#' See `?golem::get_golem_options` for more details.
5		#' @param runtime_config Injected runtime configuration.
6		#' @inheritParams shiny::shinyApp
7		#'
8		#' @export
9		#' @importFrom shiny shinyApp
10		#' @importFrom golem with_golem_options
11		run_app <- function(
12		onStart = NULL, # nolint: object_name_linter
13		options = list(),
14		enableBookmarking = NULL, # nolint: object_name_linter
15		uiPattern = "/", # nolint: object_name_linter
16		runtime_config = new_runtime_config(),
17		...
18		) {
19	!	with_golem_options(
20	!	app = shinyApp(
21	!	ui = function(request) app_ui(request, runtime_config = runtime_config),
22	!	server = function(input, output, session) {
23	!	app_server(input, output, session, runtime_config = runtime_config)
24		},
25	!	onStart = onStart,
26	!	options = options,
27	!	enableBookmarking = enableBookmarking,
28	!	uiPattern = uiPattern
29		),
30	!	golem_opts = list(...)
31		)
32		}

1		mod_review_ui <- function(id) {
2	6x	ns <- shiny::NS(id)
3	6x	bslib::card(
4	6x	class = "assurance-panel",
5	6x	bslib::card_header("Two-Person Review"),
6	6x	bslib::card_body(
7	6x	shiny::selectInput(
8	6x	ns("actor_id"),
9	6x	"Reviewer identity",
10	6x	choices = c(
11	6x	"Statistical programmer" = "stat-programmer",
12	6x	"Biostatistician" = "biostatistician",
13	6x	"Creator" = "creator"
14		)
15		),
16	6x	shiny::selectInput(
17	6x	ns("role"),
18	6x	"Review role",
19	6x	choices = c(
20	6x	"Statistical programmer" = "statistical_programmer",
21	6x	"Biostatistician" = "biostatistician"
22		)
23		),
24	6x	shiny::textAreaInput(
25	6x	ns("comment"), "Comment or rejection rationale",
26	6x	rows = 3
27		),
28	6x	div(
29	6x	class = "review-actions",
30	6x	shiny::actionButton(ns("approve"), "Approve", class = "btn-success"),
31	6x	shiny::actionButton(
32	6x	ns("reject"), "Reject",
33	6x	class = "btn-outline-danger"
34		)
35		),
36	6x	shiny::uiOutput(ns("message")),
37	6x	shiny::tableOutput(ns("decisions"))
38		)
39		)
40		}
41
42		mod_review_server <- function(id, current_revision, set_current_revision) {
43	12x	shiny::moduleServer(id, function(input, output, session) {
44	12x	message <- shiny::reactiveVal(NULL)
45
46	12x	output$message <- shiny::renderUI({
47	13x	text <- message()
48	13x	if (is.null(text)) {
49	7x	return(NULL)
50		}
51	6x	div(class = "assurance-message", role = "status", text)
52		})
53
54	12x	decide <- function(decision) {
55	9x	state <- current_revision()
56	9x	if (is.null(state$review_service) \|\| is.null(state$revision)) {
57	!	cli::cli_abort("Create and verify a revision before review")
58		}
59	9x	current <- state$repository$get_revision(state$revision$revision_id)
60	9x	key <- paste(
61	9x	decision,
62	9x	current$revision_id,
63	9x	input$actor_id,
64	9x	current$version,
65	9x	sep = ":"
66		)
67	9x	if (identical(decision, "approved")) {
68	8x	revision <- state$review_service$approve(
69	8x	current$revision_id,
70	8x	input$actor_id,
71	8x	as.integer(current$version),
72	8x	key,
73	8x	comment = input$comment,
74	8x	role = input$role
75		)
76		} else {
77	1x	revision <- state$review_service$reject(
78	1x	current$revision_id,
79	1x	input$actor_id,
80	1x	as.integer(current$version),
81	1x	key,
82	1x	rationale = input$comment,
83	1x	role = input$role
84		)
85		}
86	7x	state$revision <- revision
87	7x	set_current_revision(state)
88	7x	message(paste("Recorded", decision, "decision."))
89		}
90
91	12x	shiny::observeEvent(input$approve,
92		{
93	8x	tryCatch(
94	8x	decide("approved"),
95	8x	error = function(error) message(conditionMessage(error))
96		)
97		},
98	12x	ignoreInit = TRUE
99		)
100
101	12x	shiny::observeEvent(input$reject,
102		{
103	1x	tryCatch(
104	1x	decide("rejected"),
105	1x	error = function(error) message(conditionMessage(error))
106		)
107		},
108	12x	ignoreInit = TRUE
109		)
110
111	12x	output$decisions <- shiny::renderTable(
112		{
113	18x	state <- current_revision()
114	18x	if (is.null(state$repository) \|\| is.null(state$revision)) {
115	7x	return(data.frame())
116		}
117	11x	decisions <- state$repository$list_review_decisions(
118	11x	state$revision$revision_id
119		)
120	11x	if (!nrow(decisions)) {
121	4x	return(data.frame())
122		}
123	7x	decisions[, c(
124	7x	"actor_id", "role", "decision", "created_at"
125	7x	), drop = FALSE]
126		},
127	12x	striped = TRUE,
128	12x	spacing = "s"
129		)
130		})
131		}

1		.synthetic_data_root <- function() {
2	19x	installed <- system.file(
3	19x	"extdata", "synthetic",
4	19x	package = "ADaMViz.SubmissionSync"
5		)
6	19x	if (nzchar(installed)) {
7	19x	return(installed)
8		}
9	!	candidates <- c(
10	!	file.path("inst", "extdata", "synthetic"),
11	!	file.path("..", "..", "inst", "extdata", "synthetic")
12		)
13	!	existing <- candidates[dir.exists(candidates)]
14	!	if (length(existing)) {
15	!	normalizePath(existing[[1]], winslash = "/")
16		} else {
17	!	candidates[[1]]
18		}
19		}
20
21		#' Create the governed local study-data provider
22		#'
23		#' @param root Directory containing `scenario-manifest.json` and its pinned RDS
24		#' snapshots. The default resolves package installation data and then the
25		#' source-tree location.
26		#'
27		#' @return A local `study_data_provider`.
28		#' @export
29		local_study_data_provider <- function(root = .synthetic_data_root()) {
30	5x	if (!checkmate::test_directory_exists(root, access = "r")) {
31	!	cli::cli_abort("The local synthetic study-data directory is unavailable")
32		}
33	5x	manifest_path <- file.path(root, "scenario-manifest.json")
34	5x	if (!checkmate::test_file_exists(manifest_path, access = "r")) {
35	!	cli::cli_abort("The governed synthetic scenario manifest is unavailable")
36		}
37	5x	manifest <- jsonlite::read_json(manifest_path, simplifyVector = FALSE)
38	5x	.validate_synthetic_manifest(manifest)
39
40	5x	structure(
41	5x	list(
42	5x	port = new_provider_port(
43	5x	"study_data", c("list_catalog", "read_snapshot")
44		),
45	5x	manifest = manifest,
46	5x	read_data = function(metadata) {
47	13x	file_name <- metadata$file
48	13x	if (!checkmate::test_string(
49	13x	file_name,
50	13x	pattern = "^adlb-[a-z0-9-]+\\.rds$"
51		)) {
52	!	cli::cli_abort(
53	!	"The synthetic manifest contains an invalid snapshot file name"
54		)
55		}
56	13x	readRDS(file.path(root, file_name))
57		}
58		),
59	5x	class = "study_data_provider"
60		)
61		}

1		mod_plot_preview_ui <- function(id) {
2	6x	ns <- shiny::NS(id)
3	6x	bslib::card(
4	6x	class = "assurance-panel",
5	6x	bslib::card_header("Plot preview"),
6	6x	bslib::card_body(
7	6x	shiny::uiOutput(ns("plot")),
8	6x	tags$details(
9	6x	class = "f001-panel",
10	6x	tags$summary("Generated R script"),
11	6x	tags$div(
12	6x	class = "f001-panel-body",
13	6x	shiny::verbatimTextOutput(ns("code"), placeholder = TRUE)
14		)
15		)
16		)
17		)
18		}
19
20		mod_plot_preview_server <- function(id, current_revision) {
21	13x	shiny::moduleServer(id, function(input, output, session) {
22	13x	output$plot <- shiny::renderUI({
23	13x	state <- current_revision()
24	13x	image_hash <- state$revision$image_hash %\|\|% NA_character_
25	13x	store <- state$repository$artifact_store
26	13x	if (!is.null(store) && checkmate::test_string(
27	13x	image_hash,
28	13x	pattern = "^[0-9a-f]{64}$"
29		)) {
30	5x	shiny::imageOutput(session$ns("accepted_plot"), height = "520px")
31		} else {
32	8x	shiny::plotOutput(session$ns("experimental_plot"), height = "520px")
33		}
34		})
35
36	13x	output$experimental_plot <- shiny::renderPlot(
37		{
38	9x	state <- current_revision()
39	9x	shiny::validate(shiny::need(
40	9x	!is.null(state$artifact), "No plot artifact yet."
41		))
42	1x	state$artifact$combined
43		},
44	13x	alt = function() {
45	9x	state <- current_revision()
46	9x	if (is.null(state$profile)) {
47	7x	return("No governed plot revision has been generated.")
48		}
49	2x	paste(
50	2x	"Longitudinal boxplot for",
51	2x	state$spec$fields$paramcd,
52	2x	"using",
53	2x	state$spec$fields$y_variable,
54	2x	"faceted by",
55	2x	state$spec$fields$treatment_variable,
56	2x	"with N values in an aligned lower strip."
57		)
58		}
59		)
60
61	13x	output$accepted_plot <- shiny::renderImage(
62		{
63	13x	state <- current_revision()
64	13x	image_hash <- state$revision$image_hash %\|\|% NA_character_
65	13x	store <- state$repository$artifact_store
66	13x	shiny::validate(shiny::need(
67	13x	!is.null(store) && checkmate::test_string(
68	13x	image_hash,
69	13x	pattern = "^[0-9a-f]{64}$"
70		),
71	13x	"No accepted plot artifact yet."
72		))
73	5x	image_path <- tempfile(fileext = ".png")
74	5x	writeBin(store$get(image_hash), image_path)
75	5x	list(
76	5x	src = image_path,
77	5x	contentType = "image/png",
78	5x	style = "width: 100%; height: 100%; object-fit: contain;",
79	5x	alt = paste(
80	5x	"Accepted longitudinal boxplot for",
81	5x	state$spec$fields$paramcd
82		)
83		)
84		},
85	13x	deleteFile = TRUE
86		)
87
88	13x	output$code <- shiny::renderText({
89	13x	state <- current_revision()
90	13x	code_hash <- state$revision$code_hash %\|\|% NA_character_
91	13x	store <- state$repository$artifact_store
92	13x	if (!is.null(store) && checkmate::test_string(
93	13x	code_hash,
94	13x	pattern = "^[0-9a-f]{64}$"
95		)) {
96	5x	return(rawToChar(store$get(code_hash)))
97		}
98	8x	shiny::validate(shiny::need(
99	8x	!is.null(state$script), "No executed R script yet."
100		))
101	1x	state$script
102		})
103		})
104		}

1		.standalone_script_expressions <- function(spec, low_n_policy) {
2	33x	calculate_expression <- rlang::call2(
3		"<-",
4	33x	rlang::sym("calculate_boxplot_statistics"),
5	33x	rlang::call2(
6	33x	"function",
7	33x	formals(.standalone_boxplot_stats), # nolint: object_usage_linter.
8	33x	body(.standalone_boxplot_stats) # nolint: object_usage_linter.
9		)
10		)
11	33x	assemble_expression <- rlang::call2(
12		"<-",
13	33x	rlang::sym("assemble_boxplot"),
14	33x	rlang::call2(
15	33x	"function",
16	33x	formals(.standalone_assemble_boxplot),
17	33x	body(.standalone_assemble_boxplot)
18		)
19		)
20	33x	treatment_variable <- spec$fields$treatment_variable
21	33x	y_variable <- spec$fields$y_variable
22	33x	facet_levels <- spec$fields$treatment_levels
23	33x	visit_levels <- spec$fields$visits
24	33x	scale_mode <- spec$fields$scale_mode
25	33x	unit <- spec$fields$unit
26	33x	list(
27	33x	calculate_expression,
28	33x	assemble_expression,
29	33x	rlang::expr(boxplot_analysis <- calculate_boxplot_statistics(
30	33x	data = !!rlang::sym("analysis_data"),
31	33x	treatment_variable = !!treatment_variable,
32	33x	y_variable = !!y_variable,
33	33x	facet_levels = !!facet_levels,
34	33x	visit_levels = !!visit_levels,
35	33x	low_n_policy = list(
36	33x	value = !!as.numeric(low_n_policy$value),
37	33x	rationale = !!low_n_policy$rationale,
38	33x	authority = !!low_n_policy$authority,
39	33x	version = !!low_n_policy$version
40		)
41		)),
42	33x	rlang::expr(boxplot_artifact <- assemble_boxplot(
43	33x	analysis = boxplot_analysis,
44	33x	scale_mode = !!scale_mode,
45	33x	unit = !!unit
46		)),
47	33x	rlang::expr(if (sys.nframe() == 0L) print(boxplot_artifact$combined))
48		)
49		}
50
51		#' Compile the deterministic governed boxplot script
52		#'
53		#' The controlled runner provides validated selected records as `analysis_data`.
54		#' The caller must supply `analysis_data`. The script contains resolved
55		#' literals, inlined helpers, and uses `ggplot2`, `cli`, and `patchwork`.
56		#'
57		#' @param spec A confirmed `plot_spec`.
58		#' @param low_n_policy Retained policy with `value`, `rationale`, `authority`,
59		#' and `version`.
60		#'
61		#' @return A length-one UTF-8 R script.
62		#' @export
63		compile_boxplot_script <- function(spec, low_n_policy) {
64	33x	.validate_plot_spec(spec)
65	33x	if (!identical(spec$state, "confirmed")) {
66	!	cli::cli_abort("Only a confirmed plot specification can be compiled")
67		}
68	33x	.validate_boxplot_design(
69	33x	spec$fields$treatment_levels,
70	33x	spec$fields$visits,
71	33x	low_n_policy
72		)
73	33x	script_expressions <- .standalone_script_expressions(spec, low_n_policy)
74	33x	script_text <- vapply(
75	33x	script_expressions,
76	33x	\(expression) rlang::expr_text(expression, width = 80L),
77	33x	character(1)
78		)
79	33x	lines <- c(
80	33x	"# Boxplot Analysis Script",
81	33x	"# Required packages: ggplot2, cli, patchwork",
82	33x	"# The generated script does not require the source application package.",
83	33x	"# Source this script after defining analysis_data.",
84		"",
85	33x	"library(ggplot2)",
86	33x	"library(cli)",
87	33x	"library(patchwork)",
88		"",
89	33x	"# Data loading ----",
90	33x	"if (!exists(\"analysis_data\", inherits = FALSE)) {",
91	33x	" stop(\"analysis_data must be supplied\", call. = FALSE)",
92		"}",
93		"",
94	33x	"# Analysis and plotting functions ----",
95	33x	script_text[1:2],
96		"",
97	33x	"# Execute analysis ----",
98	33x	script_text[3:5]
99		)
100	33x	enc2utf8(paste0(paste(lines, collapse = "\n"), "\n"))
101		}

1		.plot_spec_fields <- c(
2		"dataset_id", "paramcd", "y_variable", "unit", "treatment_variable",
3		"treatment_levels", "visits", "scale_mode"
4		)
5
6		new_plot_spec <- function(
7		dataset_id,
8		paramcd = NULL,
9		y_variable = NULL,
10		unit = NULL,
11		treatment_variable = NULL,
12		treatment_levels = NULL,
13		visits = NULL,
14		scale_mode = "fixed",
15		provenance = list(),
16		state = c("candidate", "confirmed")
17		) {
18	77x	state <- match.arg(state)
19	77x	if (!checkmate::test_string(dataset_id, min.chars = 1)) {
20	!	cli::cli_abort("{.arg dataset_id} must be one non-empty identifier")
21		}
22	77x	if (!is.null(y_variable) && !checkmate::test_choice(
23	77x	y_variable,
24	77x	choices = c("AVAL", "CHG", "PCHG")
25		)) {
26	1x	cli::cli_abort(paste0(
27	1x	"{.arg y_variable} must be one of {.val ",
28	1x	"{c('AVAL', 'CHG', 'PCHG')}}"
29		))
30		}
31	76x	if (!checkmate::test_choice(scale_mode, choices = c("fixed", "free"))) {
32	!	cli::cli_abort("{.arg scale_mode} must be {.val fixed} or {.val free}")
33		}
34	76x	unknown_provenance <- setdiff(names(provenance), .plot_spec_fields)
35	76x	if (length(unknown_provenance)) {
36	1x	cli::cli_abort(paste0(
37	1x	"Unknown provenance field{?s}: {.field {unknown_provenance}}"
38		))
39		}
40	75x	invalid_sources <- unlist(provenance, use.names = FALSE)
41	75x	if (length(invalid_sources) && any(!invalid_sources %in% c(
42	75x	"prompt", "metadata", "default", "user_confirmed"
43		))) {
44	!	cli::cli_abort(paste0(
45	!	"Provenance values must be prompt, metadata, default, or user_confirmed"
46		))
47		}
48
49	75x	fields <- list(
50	75x	dataset_id = dataset_id,
51	75x	paramcd = paramcd,
52	75x	y_variable = y_variable,
53	75x	unit = unit,
54	75x	treatment_variable = treatment_variable,
55	75x	treatment_levels = treatment_levels,
56	75x	visits = visits,
57	75x	scale_mode = scale_mode
58		)
59	75x	structure(
60	75x	list(
61	75x	schema_version = "plot-spec-v1",
62	75x	state = state,
63	75x	fields = fields,
64	75x	provenance = provenance,
65	75x	hash = canonical_hash(list(fields = fields, provenance = provenance))
66		),
67	75x	class = "plot_spec"
68		)
69		}
70
71		plot_spec_clarifications <- function(spec) {
72	26x	.validate_plot_spec(spec)
73	26x	required <- .plot_spec_fields[.plot_spec_fields != "scale_mode"]
74	26x	required[vapply(spec$fields[required], is.null, logical(1))]
75		}
76
77		confirm_plot_spec <- function(spec) {
78	12x	missing_fields <- plot_spec_clarifications(spec)
79	12x	if (length(missing_fields)) {
80	!	cli::cli_abort(paste0(
81	!	"The plot specification needs clarification for {.field {missing_fields}}"
82		))
83		}
84	12x	unconfirmed <- setdiff(.plot_spec_fields, names(spec$provenance))
85	12x	if (length(unconfirmed)) {
86	!	cli::cli_abort(paste0(
87	!	"The plot specification lacks provenance for {.field {unconfirmed}}"
88		))
89		}
90	12x	new_plot_spec(
91	12x	dataset_id = spec$fields$dataset_id,
92	12x	paramcd = spec$fields$paramcd,
93	12x	y_variable = spec$fields$y_variable,
94	12x	unit = spec$fields$unit,
95	12x	treatment_variable = spec$fields$treatment_variable,
96	12x	treatment_levels = spec$fields$treatment_levels,
97	12x	visits = spec$fields$visits,
98	12x	scale_mode = spec$fields$scale_mode,
99	12x	provenance = spec$provenance,
100	12x	state = "confirmed"
101		)
102		}
103
104		.validate_plot_spec <- function(spec) {
105	89x	if (!inherits(spec, "plot_spec")) {
106	!	cli::cli_abort("{.arg spec} must be a {.cls plot_spec}")
107		}
108	89x	invisible(spec)
109		}

1		.export_receipt_id <- function(idempotency_key) {
2	25x	paste0("receipt-", substr(canonical_hash(idempotency_key), 1L, 24L))
3		}
4
5		.export_actor_roles <- c(
6		"clinical_scientist", "statistical_programmer",
7		"biostatistician", "export_publisher"
8		)
9
10		.authorize_export_actor <- function(actor) {
11	33x	if (!inherits(actor, "submission_sync_actor")) {
12	!	cli::cli_abort("Export authorization requires an authenticated actor")
13		}
14	33x	if (!isTRUE(actor$active)) {
15	2x	cli::cli_abort("The current actor is not active")
16		}
17	31x	if (!any(actor$roles %in% .export_actor_roles)) {
18	3x	cli::cli_abort("The current actor is not authorized to export revisions")
19		}
20	28x	invisible(TRUE)
21		}
22
23		.assert_exportable_revision <- function(revision, expected_version) {
24	28x	if (!identical(as.integer(revision$version), as.integer(expected_version))) {
25	3x	cli::cli_abort("The revision token is stale")
26		}
27	25x	if (!identical(revision$status, "Reviewed")) {
28	3x	cli::cli_abort("Only Reviewed revisions can be exported")
29		}
30	22x	invisible(revision)
31		}
32
33		new_export_service <- function(
34		repository,
35		artifact_store,
36		workspace_provider,
37		identity_provider
38		) {
39	17x	.validate_evidence_repository(
40	17x	repository,
41	17x	c(
42	17x	"get_revision", "get_artifact_bundle", "record_export_receipt",
43	17x	"list_export_receipts"
44		)
45		)
46	17x	if (!is.list(artifact_store) \|\|
47	17x	!is.function(artifact_store$get) \|\|
48	17x	!is.function(artifact_store$verify)) {
49	!	cli::cli_abort("Export service requires a readable artifact store")
50		}
51	17x	.validate_workspace_provider(workspace_provider)
52	17x	.validate_identity_provider(identity_provider)
53
54	17x	export_revision <- function(
55	17x	revision_id,
56	17x	actor_id,
57	17x	destination_id,
58	17x	expected_version,
59	17x	idempotency_key
60		) {
61	25x	.validate_identifier(revision_id, "revision_id")
62	25x	.validate_workspace_token(destination_id, "destination_id")
63	25x	.validate_identifier(idempotency_key, "idempotency_key")
64
65	25x	receipt_id <- .export_receipt_id(idempotency_key)
66	25x	actor <- identity_provider$get_actor(actor_id)
67	25x	.authorize_export_actor(actor)
68	20x	revision <- repository$get_revision(revision_id)
69	20x	.assert_exportable_revision(revision, expected_version)
70	14x	prior <- repository$list_export_receipts(revision_id)
71	14x	prior <- prior[prior$receipt_id == receipt_id, , drop = FALSE]
72	14x	if (nrow(prior)) {
73	4x	prior <- as.list(prior[1, , drop = FALSE])
74	4x	if (!identical(prior$destination_id, destination_id)) {
75	1x	cli::cli_abort(
76	1x	"The idempotency key was already used for a different destination"
77		)
78		}
79	3x	published <- workspace_provider$inspect_published(
80	3x	destination_id, receipt_id
81		)
82	3x	if (is.null(published)) {
83	!	cli::cli_abort("The previously published export is missing")
84		}
85	3x	if (!identical(published$code_hash, prior$code_hash) \|\|
86	3x	!identical(published$image_hash, prior$image_hash)) {
87	!	cli::cli_abort("Published export hashes do not match the receipt")
88		}
89	3x	return(invisible(c(
90	3x	list(receipt_id = receipt_id, revision_id = revision_id),
91	3x	published
92		)))
93		}
94	10x	bundle <- repository$get_artifact_bundle(revision_id)
95
96	9x	code_bytes <- artifact_store$get(bundle$code_hash)
97	9x	image_bytes <- artifact_store$get(bundle$image_hash)
98	9x	export_id <- receipt_id
99
100	9x	published <- workspace_provider$inspect_published(destination_id, export_id)
101	8x	if (is.null(published)) {
102	8x	stage <- workspace_provider$stage_bundle(
103	8x	destination_id = destination_id,
104	8x	export_id = export_id,
105	8x	code_bytes = code_bytes,
106	8x	image_bytes = image_bytes
107		)
108
109	8x	actor <- identity_provider$get_actor(actor_id)
110	8x	.authorize_export_actor(actor)
111	8x	current <- repository$get_revision(revision_id)
112	8x	.assert_exportable_revision(current, expected_version)
113	8x	if (!identical(current$code_hash, bundle$code_hash) \|\|
114	8x	!identical(current$image_hash, bundle$image_hash)) {
115	!	workspace_provider$quarantine_staged(stage, "stale-revision")
116	!	cli::cli_abort(
117	!	"The accepted artifact bundle no longer matches the revision"
118		)
119		}
120	8x	published <- workspace_provider$publish_staged(stage)
121		}
122
123	8x	if (!identical(published$code_hash, bundle$code_hash) \|\|
124	8x	!identical(published$image_hash, bundle$image_hash)) {
125	!	cli::cli_abort("Published export hashes do not match the accepted bundle")
126		}
127
128	8x	repository$record_export_receipt(
129	8x	receipt_id = receipt_id,
130	8x	revision_id = revision_id,
131	8x	destination_id = destination_id,
132	8x	code_hash = bundle$code_hash,
133	8x	image_hash = bundle$image_hash,
134	8x	idempotency_key = idempotency_key
135		)
136	8x	invisible(c(
137	8x	list(receipt_id = receipt_id, revision_id = revision_id),
138	8x	published
139		))
140		}
141
142	17x	structure(
143	17x	list(export_revision = export_revision),
144	17x	class = "export_service"
145		)
146		}

1		local_workspace_provider <- function(destinations) {
2	26x	if (is.character(destinations)) {
3	26x	roots <- as.list(destinations)
4	!	} else if (is.list(destinations)) {
5	!	roots <- destinations
6		} else {
7	!	cli::cli_abort(
8	!	"{.arg destinations} must be a named character vector or list"
9		)
10		}
11	26x	destination_ids <- names(roots)
12	26x	if (!length(destination_ids) \|\|
13	26x	any(!nzchar(destination_ids)) \|\|
14	26x	anyDuplicated(destination_ids)) {
15	!	cli::cli_abort(
16	!	"Workspace destinations must have unique logical identifiers"
17		)
18		}
19	26x	lapply(destination_ids, .validate_workspace_token, name = "destination_id")
20	26x	roots <- lapply(roots, function(root) {
21	26x	checkmate::assert_string(root, min.chars = 1L)
22	26x	if (!fs::dir_exists(root)) {
23	!	cli::cli_abort("Workspace root {.path {root}} must already exist")
24		}
25	26x	fs::path_abs(normalizePath(root, winslash = "/", mustWork = TRUE))
26		})
27
28	26x	destination_root <- function(destination_id) {
29	52x	.validate_workspace_token(destination_id, "destination_id")
30	52x	root <- roots[[destination_id]]
31	52x	if (is.null(root)) {
32	2x	cli::cli_abort(
33	2x	"Workspace destination {.val {destination_id}} is not registered"
34		)
35		}
36	50x	.validate_workspace_root(root)
37	50x	root
38		}
39
40	26x	export_paths <- function(destination_id, export_id) {
41	50x	root <- destination_root(destination_id)
42	48x	.validate_workspace_token(export_id, "export_id")
43	43x	list(
44	43x	root = root,
45	43x	staging = fs::path(root, ".staging", export_id),
46	43x	final = fs::path(root, export_id),
47	43x	quarantine = fs::path(root, ".quarantine")
48		)
49		}
50
51	26x	stage_bundle <- function(destination_id, export_id, code_bytes, image_bytes) {
52	17x	if (!is.raw(code_bytes) \|\| !is.raw(image_bytes)) {
53	!	cli::cli_abort("Workspace bundles must be supplied as raw vectors")
54		}
55	17x	paths <- export_paths(destination_id, export_id)
56	11x	if (fs::dir_exists(paths$staging) \|\| fs::dir_exists(paths$final)) {
57	1x	cli::cli_abort("Workspace export {.val {export_id}} already exists")
58		}
59	10x	fs::dir_create(paths$staging, recurse = TRUE)
60	10x	writeBin(code_bytes, fs::path(paths$staging, "script.R"))
61	10x	writeBin(image_bytes, fs::path(paths$staging, "plot.png"))
62	10x	hashes <- .workspace_pair_hashes(paths$staging)
63	10x	writeLines(
64	10x	canonical_serialize(list(
65	10x	destination_id = destination_id,
66	10x	export_id = export_id,
67	10x	code_hash = hashes$code_hash,
68	10x	image_hash = hashes$image_hash,
69	10x	staged_at = .utc_timestamp()
70		)),
71	10x	fs::path(paths$staging, "manifest.json"),
72	10x	useBytes = TRUE
73		)
74	10x	structure(
75	10x	c(
76	10x	paths, hashes,
77	10x	list(destination_id = destination_id, export_id = export_id)
78		),
79	10x	class = "workspace_staged_export"
80		)
81		}
82
83	26x	publish_staged <- function(stage) {
84	9x	if (!inherits(stage, "workspace_staged_export")) {
85	!	cli::cli_abort("{.arg stage} must be a staged workspace export")
86		}
87	9x	paths <- export_paths(stage$destination_id, stage$export_id)
88	9x	if (!fs::dir_exists(paths$staging)) {
89	!	cli::cli_abort(
90	!	"Staged workspace export {.val {stage$export_id}} is missing"
91		)
92		}
93	9x	if (fs::dir_exists(paths$final)) {
94	!	cli::cli_abort("Workspace export {.val {stage$export_id}} already exists")
95		}
96	9x	hashes <- .workspace_pair_hashes(paths$staging)
97	9x	if (is.null(hashes) \|\|
98	9x	!identical(hashes$code_hash, stage$code_hash) \|\|
99	9x	!identical(hashes$image_hash, stage$image_hash)) {
100	!	quarantine_staged(stage, "hash-mismatch")
101	!	cli::cli_abort(
102	!	"Staged workspace export hashes changed before publication"
103		)
104		}
105	9x	fs::file_delete(fs::path(paths$staging, "manifest.json"))
106	9x	fs::file_move(paths$staging, paths$final)
107	9x	published <- inspect_published(stage$destination_id, stage$export_id)
108	9x	if (is.null(published) \|\|
109	9x	!identical(published$code_hash, stage$code_hash) \|\|
110	9x	!identical(published$image_hash, stage$image_hash)) {
111	!	cli::cli_abort(
112	!	"Published workspace export hashes do not match the staged bundle"
113		)
114		}
115	9x	invisible(published)
116		}
117
118	26x	inspect_published <- function(destination_id, export_id) {
119	22x	paths <- export_paths(destination_id, export_id)
120	21x	hashes <- .workspace_pair_hashes(paths$final)
121	21x	if (is.null(hashes)) {
122	8x	return(NULL)
123		}
124	13x	c(
125	13x	list(
126	13x	destination_id = destination_id,
127	13x	export_id = export_id,
128	13x	path = paths$final,
129	13x	code_path = fs::path(paths$final, "script.R"),
130	13x	image_path = fs::path(paths$final, "plot.png")
131		),
132	13x	hashes
133		)
134		}
135
136	26x	quarantine_staged <- function(stage, reason = "orphaned") {
137	1x	if (!inherits(stage, "workspace_staged_export")) {
138	!	cli::cli_abort("{.arg stage} must be a staged workspace export")
139		}
140	1x	paths <- export_paths(stage$destination_id, stage$export_id)
141	1x	if (!fs::dir_exists(paths$staging)) {
142	!	return(invisible(NULL))
143		}
144	1x	fs::dir_create(paths$quarantine, recurse = TRUE)
145	1x	target <- fs::path(
146	1x	paths$quarantine,
147	1x	paste(
148	1x	stage$export_id,
149	1x	substr(canonical_hash(list(reason, .utc_timestamp())), 1L, 12L),
150	1x	sep = "-"
151		)
152		)
153	1x	fs::file_move(paths$staging, target)
154	1x	invisible(target)
155		}
156
157	26x	reconcile <- function(destination_id) {
158	2x	root <- destination_root(destination_id)
159	2x	staging_root <- fs::path(root, ".staging")
160	2x	if (!fs::dir_exists(staging_root)) {
161	1x	return(data.frame(
162	1x	destination_id = character(),
163	1x	export_id = character(),
164	1x	action = character(),
165	1x	path = character()
166		))
167		}
168	1x	staged <- fs::dir_ls(staging_root, type = "directory", fail = FALSE)
169	1x	results <- lapply(staged, function(path) {
170	1x	export_id <- fs::path_file(path)
171	1x	.validate_workspace_token(export_id, "export_id")
172	1x	stage <- structure(
173	1x	c(
174	1x	export_paths(destination_id, export_id),
175	1x	.workspace_pair_hashes(path) %\|\|% list(
176	1x	code_hash = NA_character_, image_hash = NA_character_
177		),
178	1x	list(destination_id = destination_id, export_id = export_id)
179		),
180	1x	class = "workspace_staged_export"
181		)
182	1x	quarantine <- quarantine_staged(stage, "reconciled-orphan")
183	1x	data.frame(
184	1x	destination_id = destination_id,
185	1x	export_id = export_id,
186	1x	action = "quarantined",
187	1x	path = quarantine,
188	1x	stringsAsFactors = FALSE
189		)
190		})
191	1x	if (!length(results)) {
192	!	return(data.frame(
193	!	destination_id = character(),
194	!	export_id = character(),
195	!	action = character(),
196	!	path = character()
197		))
198		}
199	1x	do.call(rbind, results)
200		}
201
202	26x	structure(
203	26x	list(
204	26x	assurance_class = "development-only",
205	26x	destinations = roots,
206	26x	list_destinations = function() names(roots),
207	26x	stage_bundle = stage_bundle,
208	26x	publish_staged = publish_staged,
209	26x	inspect_published = inspect_published,
210	26x	quarantine_staged = quarantine_staged,
211	26x	reconcile = reconcile
212		),
213	26x	class = c("development_only_workspace_provider", "local_workspace_provider")
214		)
215		}
216
217		.validate_workspace_root <- function(root) {
218	50x	if (isTRUE(fs::is_link(root))) {
219	!	cli::cli_abort("Workspace roots cannot be symbolic links or reparse points")
220		}
221	50x	invisible(root)
222		}

1		mod_prompt_ui <- function(id) {
2	!	ns <- shiny::NS(id)
3	!	bslib::card(
4	!	class = "assurance-panel",
5	!	bslib::card_header("Prompt and Dataset"),
6	!	bslib::card_body(
7	!	shiny::selectInput(
8	!	ns("dataset_id"), "Synthetic BDS scenario",
9	!	choices = character()
10		),
11	!	shiny::textAreaInput(
12	!	ns("prompt"),
13	!	"Plot request",
14	!	value = "Create a boxplot of ALT AVAL by treatment over all visits.",
15	!	width = "100%",
16	!	rows = 4
17		),
18	!	shiny::checkboxInput(
19	!	ns("confirm_free_scale"),
20	!	paste(
21	!	"I understand free Y scales create an Experimental/Draft revision"
22		),
23	!	value = FALSE
24		),
25	!	.assurance_task_button(
26	!	ns("submit"), "Create revision",
27	!	class = "btn-primary"
28		),
29	!	shiny::uiOutput(ns("message"))
30		)
31		)
32		}
33
34		mod_prompt_server <- function(id, catalog, create_revision) {
35	1x	shiny::moduleServer(id, function(input, output, session) {
36	1x	shiny::observe({
37	1x	choices <- stats::setNames(catalog()$dataset_id, catalog()$purpose)
38	1x	shiny::updateSelectInput(session, "dataset_id", choices = choices)
39		})
40
41	1x	message <- shiny::reactiveVal(NULL)
42	1x	output$message <- shiny::renderUI({
43	1x	text <- message()
44	1x	if (is.null(text)) {
45	1x	return(NULL)
46		}
47	!	div(class = "assurance-message", role = "status", text)
48		})
49
50	1x	shiny::observeEvent(input$submit,
51		{
52	1x	message(NULL)
53	1x	tryCatch(
54	1x	create_revision(
55	1x	dataset_id = input$dataset_id,
56	1x	prompt = input$prompt,
57	1x	confirm_free_scale = isTRUE(input$confirm_free_scale)
58		),
59	1x	error = function(error) {
60	!	message(conditionMessage(error))
61		}
62		)
63		},
64	1x	ignoreInit = TRUE
65		)
66		})
67		}
68
69		.assurance_task_button <- function(input_id, label, ...) {
70	17x	task_button <- get0(
71	17x	"input_task_button",
72	17x	envir = asNamespace("bslib"),
73	17x	inherits = FALSE
74		)
75	17x	if (is.function(task_button)) {
76	17x	return(task_button(input_id, label, ...))
77		}
78	!	shiny::actionButton(input_id, label, ...)
79		}

1		.validate_workspace_provider <- function(provider) {
2	19x	capabilities <- c(
3	19x	"list_destinations", "stage_bundle", "publish_staged",
4	19x	"inspect_published", "quarantine_staged", "reconcile"
5		)
6	19x	if (!is.list(provider) \|\| !all(vapply(
7	19x	capabilities,
8	19x	\(capability) is.function(provider[[capability]]),
9	19x	logical(1)
10		))) {
11	!	cli::cli_abort(
12	!	"Workspace provider must implement {.fn {capabilities}}"
13		)
14		}
15	19x	invisible(provider)
16		}
17
18		.validate_workspace_token <- function(value, name = "workspace token") {
19	154x	reserved <- c(
20	154x	"CON", "PRN", "AUX", "NUL",
21	154x	paste0("COM", 1:9), paste0("LPT", 1:9)
22		)
23	154x	if (!checkmate::test_string(value, min.chars = 1L) \|\|
24	154x	!grepl("^[A-Za-z0-9._-]+$", value) \|\|
25	154x	value %in% c(".", "..") \|\|
26	154x	toupper(tools::file_path_sans_ext(value)) %in% reserved) {
27	5x	cli::cli_abort("{.arg {name}} must be a safe logical identifier")
28		}
29	149x	invisible(value)
30		}
31
32		.workspace_pair_hashes <- function(path) {
33	41x	code_path <- fs::path(path, "script.R")
34	41x	image_path <- fs::path(path, "plot.png")
35	41x	if (!fs::file_exists(code_path) \|\| !fs::file_exists(image_path)) {
36	8x	return(NULL)
37		}
38	33x	list(
39	33x	code_hash = digest::digest(file = code_path, algo = "sha256"),
40	33x	image_hash = digest::digest(file = image_path, algo = "sha256")
41		)
42		}

1		local_artifact_store <- function(root) {
2	47x	checkmate::assert_string(root, min.chars = 1)
3	47x	fs::dir_create(root, recurse = TRUE)
4	47x	root <- fs::path_abs(root)
5
6	47x	artifact_path <- function(hash) {
7	325x	.validate_artifact_hash(hash)
8	325x	fs::path(root, substr(hash, 1L, 2L), hash)
9		}
10
11	47x	put <- function(bytes) {
12	78x	if (!is.raw(bytes)) {
13	!	cli::cli_abort("Artifact content must be a raw vector")
14		}
15	78x	hash <- digest::digest(bytes, algo = "sha256", serialize = FALSE)
16	78x	path <- artifact_path(hash)
17	78x	if (fs::file_exists(path)) {
18	16x	verify(hash)
19		} else {
20	62x	fs::dir_create(fs::path_dir(path), recurse = TRUE)
21	62x	temporary <- fs::file_temp(
22	62x	tmp_dir = fs::path_dir(path),
23	62x	pattern = "artifact-"
24		)
25	62x	writeBin(bytes, temporary)
26	62x	if (!identical(digest::digest(file = temporary, algo = "sha256"), hash)) {
27	!	fs::file_delete(temporary)
28	!	cli::cli_abort("Artifact hash verification failed before publication")
29		}
30	62x	if (!fs::file_exists(path)) {
31	62x	fs::file_move(temporary, path)
32		} else {
33	!	fs::file_delete(temporary)
34		}
35		}
36	77x	hash
37		}
38
39	47x	get <- function(hash) {
40	32x	path <- artifact_path(hash)
41	32x	if (!fs::file_exists(path)) {
42	!	cli::cli_abort("Artifact {.val {hash}} does not exist")
43		}
44	32x	verify(hash)
45	31x	readBin(path, what = "raw", n = fs::file_size(path))
46		}
47
48	47x	verify <- function(hash) {
49	209x	path <- artifact_path(hash)
50	209x	if (!fs::file_exists(path) \|\|
51	209x	!identical(digest::digest(file = path, algo = "sha256"), hash)) {
52	5x	cli::cli_abort("Artifact hash verification failed for {.val {hash}}")
53		}
54	204x	TRUE
55		}
56
57	47x	exists <- function(hash) unname(fs::file_exists(artifact_path(hash)))
58
59	47x	cleanup_orphans <- function(referenced_hashes, minimum_age_seconds) {
60	2x	if (!is.character(referenced_hashes)) {
61	!	cli::cli_abort("Referenced artifact hashes must be a character vector")
62		}
63	2x	if (length(referenced_hashes)) {
64	2x	invisible(lapply(referenced_hashes, .validate_artifact_hash))
65		}
66	2x	files <- fs::dir_ls(root, recurse = TRUE, type = "file", fail = FALSE)
67	2x	relative <- fs::path_rel(files, start = root)
68	2x	components <- strsplit(relative, "[/\\\\]")
69	2x	is_artifact <- vapply(components, function(parts) {
70	4x	length(parts) == 2L &&
71	4x	grepl("^[0-9a-f]{2}$", parts[[1]]) &&
72	4x	grepl("^[0-9a-f]{64}$", parts[[2]]) &&
73	4x	identical(parts[[1]], substr(parts[[2]], 1L, 2L))
74	2x	}, logical(1))
75	2x	artifact_paths <- files[is_artifact]
76	2x	orphan_paths <- artifact_paths[
77	2x	!fs::path_file(artifact_paths) %in% referenced_hashes
78		]
79	2x	if (length(orphan_paths)) {
80	1x	age_seconds <- as.numeric(
81	1x	difftime(
82	1x	Sys.time(),
83	1x	fs::file_info(orphan_paths)$modification_time,
84	1x	units = "secs"
85		)
86		)
87	1x	orphan_paths <- orphan_paths[age_seconds >= minimum_age_seconds]
88		}
89	2x	orphan_hashes <- fs::path_file(orphan_paths)
90	1x	if (length(orphan_paths)) fs::file_delete(orphan_paths)
91	2x	orphan_hashes
92		}
93
94	47x	structure(
95	47x	list(
96	47x	root = fs::path_abs(root), put = put, get = get, verify = verify,
97	47x	exists = exists, path = artifact_path, .cleanup_orphans = cleanup_orphans
98		),
99	47x	class = "local_artifact_store"
100		)
101		}

1		.new_profile_diagnostic <- function(
2		code,
3		message,
4		count = NULL,
5		integrity_ref = NULL
6		) {
7	73x	compact <- list(code = code, message = message)
8	71x	if (!is.null(count)) compact$count <- as.integer(count)
9	71x	if (!is.null(integrity_ref)) compact$integrity_ref <- integrity_ref
10	73x	compact
11		}
12
13		.resolve_low_n_policy <- function(low_n_threshold) {
14	68x	if (is.numeric(low_n_threshold) && length(low_n_threshold) == 1L &&
15	68x	!is.na(low_n_threshold) && identical(as.numeric(low_n_threshold), 5)) {
16	66x	return(list(
17	66x	value = 5,
18	66x	rationale = "Assurance Cell default",
19	66x	authority = "plot-pattern-assurance-cell-v1",
20	66x	version = "low-n-default-v1"
21		))
22		}
23	2x	required <- c("value", "rationale", "authority", "version")
24	2x	valid <- is.list(low_n_threshold) &&
25	2x	identical(sort(names(low_n_threshold)), sort(required)) &&
26	2x	checkmate::test_number(low_n_threshold$value, lower = 1, finite = TRUE) &&
27	2x	all(vapply(
28	2x	low_n_threshold[required[-1]],
29	2x	checkmate::test_string,
30	2x	logical(1),
31	2x	min.chars = 1L
32		))
33	2x	if (!valid) {
34	1x	cli::cli_abort(
35	1x	paste0(
36	1x	"A non-default low-N threshold requires sponsor-approved value, ",
37	1x	"rationale, authority, and version"
38		)
39		)
40		}
41	1x	low_n_threshold$value <- as.numeric(low_n_threshold$value)
42	1x	low_n_threshold
43		}
44
45		.profile_result <- function(snapshot, selections, choices, policy) {
46	67x	structure(
47	67x	list(
48	67x	profile_version = "visit-based-numeric-bds-v1",
49	67x	snapshot_id = snapshot$snapshot_id,
50	67x	snapshot_hash = snapshot$content_hash,
51	67x	blocked = FALSE,
52	67x	dataset_conformance = "not_assessed",
53	67x	selections = selections,
54	67x	choices = choices,
55	67x	facet_levels = choices$included_treatment_levels,
56	67x	visit_levels = choices$included_visits,
57	67x	low_n_policy = policy,
58	67x	selected_data = data.frame(),
59	67x	analysis_data = data.frame(),
60	67x	display_data = data.frame(),
61	67x	counts = data.frame(),
62	67x	blocking_diagnostics = list(),
63	67x	warnings = list(),
64	67x	authorized_diagnostics = list(),
65	67x	durable_diagnostics = list(),
66	67x	analytical_input_hash = NULL
67		),
68	67x	class = "bds_profile_result"
69		)
70		}
71
72		.block_profile <- function(result, diagnostic, authorized = list()) {
73	17x	result$blocked <- TRUE
74	17x	result$blocking_diagnostics <- list(diagnostic)
75	17x	result$durable_diagnostics <- list(diagnostic)
76	17x	result$authorized_diagnostics <- authorized
77	17x	result
78		}
79
80		.sort_profile_data <- function(data, treatment_variable) {
81	105x	columns <- intersect(
82	105x	c(treatment_variable, "AVISITN", "AVISIT", "USUBJID", "PARAMCD"),
83	105x	names(data)
84		)
85	105x	ordering <- do.call(
86	105x	order,
87	105x	c(data[columns], list(method = "radix", na.last = TRUE))
88		)
89	105x	result <- data[ordering, , drop = FALSE]
90	105x	row.names(result) <- NULL
91	105x	result
92		}
93
94		.minimize_analysis_data <- function(data, treatment_variable, y_variable) {
95	50x	result <- data[
96	50x	unique(c(
97	50x	"USUBJID", "AVISIT", "AVISITN", treatment_variable, y_variable
98		))
99		]
100	50x	subject_ids <- sort(unique(as.character(result$USUBJID)), method = "radix")
101	50x	prefix <- "SUBJ"
102	50x	repeat {
103	51x	pseudonyms <- sprintf("%s-%06d", prefix, seq_along(subject_ids))
104	50x	if (!any(pseudonyms %in% subject_ids)) break
105	1x	prefix <- paste0("PSEUDO-", prefix)
106		}
107	50x	names(pseudonyms) <- subject_ids
108	50x	result$USUBJID <- unname(pseudonyms[as.character(result$USUBJID)])
109	50x	result
110		}
111
112		.validate_profile_inputs <- function(snapshot, selections) {
113	68x	if (!inherits(snapshot, "study_data_snapshot")) {
114	!	cli::cli_abort("{.arg snapshot} must be a {.cls study_data_snapshot}")
115		}
116	68x	required <- c(
117	68x	"paramcd", "y_variable", "unit", "treatment_variable",
118	68x	"treatment_levels", "visits"
119		)
120	68x	if (!is.list(selections) \|\| !setequal(names(selections), required)) {
121	!	cli::cli_abort(paste0(
122	!	"{.arg selections} must contain the complete visit-based ",
123	!	"BDS selection fields"
124		))
125		}
126	68x	if (!checkmate::test_string(selections$paramcd, min.chars = 1L) \|\|
127	68x	!checkmate::test_choice(
128	68x	selections$y_variable,
129	68x	c("AVAL", "CHG", "PCHG")
130		) \|\|
131	68x	!checkmate::test_string(
132	68x	selections$treatment_variable,
133	68x	min.chars = 1L
134		)) {
135	!	cli::cli_abort(paste0(
136	!	"The parameter, Y variable, and treatment selections must each be ",
137	!	"singular and valid"
138		))
139		}
140	68x	invisible(TRUE)
141		}
142
143		#' Validate the supported visit-based numeric BDS profile
144		#'
145		#' Explicit parameter, unit, treatment, and visit selections are applied before
146		#' visit-key and selected-Y checks. Blocking diagnostics are separated from
147		#' nonblocking sparse-data warnings.
148		#'
149		#' @param snapshot A pinned `study_data_snapshot`.
150		#' @param selections A complete list containing `paramcd`, `y_variable`, `unit`,
151		#' `treatment_variable`, `treatment_levels`, and `visits`.
152		#' @param low_n_threshold The default value `5`, or a sponsor-approved list with
153		#' `value`, `rationale`, `authority`, and `version`.
154		#'
155		#' @return A deterministic `bds_profile_result`.
156		#' @export
157		validate_bds_profile <- function(snapshot, selections, low_n_threshold = 5) {
158	68x	.validate_profile_inputs(snapshot, selections)
159	68x	policy <- .resolve_low_n_policy(low_n_threshold)
160	67x	data <- snapshot$data
161	67x	treatment <- selections$treatment_variable
162	67x	y <- selections$y_variable
163	67x	choices <- list(
164	67x	parameters = sort(
165	67x	unique(stats::na.omit(as.character(data$PARAMCD))),
166	67x	method = "radix"
167		),
168	67x	y_variables = intersect(c("AVAL", "CHG", "PCHG"), names(data)),
169	67x	units = character(),
170	67x	treatment_variables = snapshot$permitted_treatment_variables,
171	67x	treatment_levels = character(),
172	67x	visits = character(),
173	67x	included_treatment_levels = character(),
174	67x	included_visits = character()
175		)
176	67x	result <- .profile_result(snapshot, selections, choices, policy)
177
178	67x	classification_allowed <- if (is.null(snapshot$classification)) {
179	8x	identical(snapshot$source_metadata$source, "direct_upload")
180		} else {
181	59x	snapshot$classification %in% c("public", "synthetic", "deidentified")
182		}
183	67x	if (!classification_allowed \|\|
184	67x	!identical(snapshot$adam_designation, "BDS")) {
185	1x	return(.block_profile(result, .new_profile_diagnostic(
186	1x	"unsupported_source_metadata",
187	1x	paste0(
188	1x	"The authorized source is outside the permitted BDS profile ",
189	1x	"metadata envelope"
190		)
191		)))
192		}
193	66x	required_columns <- unique(c(
194	66x	"USUBJID", "PARAMCD", "AVISIT", "AVISITN", y, treatment,
195	66x	if ("AVALU" %in% names(data)) "AVALU"
196		))
197	66x	missing_columns <- setdiff(required_columns, names(data))
198	66x	if (length(missing_columns)) {
199	1x	return(.block_profile(result, .new_profile_diagnostic(
200	1x	"missing_required_variables",
201	1x	paste0(
202	1x	"The selected source lacks variables required by the supported ",
203	1x	"BDS profile"
204		),
205	1x	length(missing_columns),
206	1x	canonical_hash(sort(missing_columns, method = "radix"))
207		)))
208		}
209	65x	if (!treatment %in% snapshot$permitted_treatment_variables) {
210	!	return(.block_profile(result, .new_profile_diagnostic(
211	!	"treatment_not_permitted",
212	!	paste0(
213	!	"The selected treatment variable is not permitted by the ",
214	!	"authorized catalog"
215		)
216		)))
217		}
218	65x	if (!selections$paramcd %in% choices$parameters) {
219	!	return(.block_profile(result, .new_profile_diagnostic(
220	!	"parameter_not_available",
221	!	"The selected parameter is not present in the authorized snapshot"
222		)))
223		}
224	65x	if (!is.numeric(data[[y]])) {
225	1x	return(.block_profile(result, .new_profile_diagnostic(
226	1x	"selected_y_not_numeric",
227	1x	"The selected Y variable must be numeric for this BDS profile"
228		)))
229		}
230
231	64x	selected <- data[
232	64x	data$PARAMCD == selections$paramcd & !is.na(data$PARAMCD), ,
233	64x	drop = FALSE
234		]
235	64x	units <- if ("AVALU" %in% names(selected)) {
236	64x	sort(unique(stats::na.omit(as.character(selected$AVALU))), method = "radix")
237		} else {
238	!	character()
239		}
240	64x	result$choices$units <- units
241	64x	if (length(units) > 1L && is.null(selections$unit)) {
242	2x	return(.block_profile(result, .new_profile_diagnostic(
243	2x	"unit_selection_required",
244	2x	"Multiple non-missing units require one explicit unit selection",
245	2x	length(units),
246	2x	canonical_hash(units)
247		)))
248		}
249	62x	if (!is.null(selections$unit)) {
250	62x	if (!checkmate::test_string(selections$unit, min.chars = 1L) \|\|
251	62x	!selections$unit %in% units) {
252	!	return(.block_profile(result, .new_profile_diagnostic(
253	!	"unit_not_available",
254	!	"The selected unit is not present for the selected parameter"
255		)))
256		}
257	62x	selected <- selected[
258	62x	!is.na(selected$AVALU) & selected$AVALU == selections$unit, ,
259	62x	drop = FALSE
260		]
261		}
262
263	62x	missing_subject <- is.na(selected$USUBJID) \|
264	62x	!nzchar(as.character(selected$USUBJID))
265	62x	if (any(missing_subject)) {
266	1x	return(.block_profile(result, .new_profile_diagnostic(
267	1x	"missing_profile_key",
268	1x	"The selected records contain a missing supported-profile key value",
269	1x	sum(missing_subject),
270	1x	canonical_hash(list(
271	1x	snapshot_id = snapshot$snapshot_id,
272	1x	count = sum(missing_subject)
273		))
274		)))
275		}
276	61x	missing_treatment <- is.na(selected[[treatment]]) \|
277	61x	!nzchar(as.character(selected[[treatment]]))
278	61x	if (any(missing_treatment)) {
279	1x	return(.block_profile(result, .new_profile_diagnostic(
280	1x	"missing_treatment_value",
281	1x	paste0(
282	1x	"The selected records contain a missing treatment value required ",
283	1x	"for faceting"
284		),
285	1x	sum(missing_treatment),
286	1x	canonical_hash(list(
287	1x	snapshot_id = snapshot$snapshot_id,
288	1x	count = sum(missing_treatment)
289		))
290		)))
291		}
292
293	60x	treatment_levels <- sort(
294	60x	unique(stats::na.omit(as.character(selected[[treatment]]))),
295	60x	method = "radix"
296		)
297	60x	result$choices$treatment_levels <- treatment_levels
298	60x	included_treatments <- selections$treatment_levels
299	!	if (is.null(included_treatments)) included_treatments <- treatment_levels
300	60x	if (!checkmate::test_character(
301	60x	included_treatments,
302	60x	any.missing = FALSE,
303	60x	unique = TRUE
304		) \|\|
305	60x	length(setdiff(included_treatments, treatment_levels))) {
306	!	return(.block_profile(result, .new_profile_diagnostic(
307	!	"treatment_level_not_available",
308	!	paste0(
309	!	"Every included treatment level must be present in the ",
310	!	"authorized snapshot"
311		)
312		)))
313		}
314	60x	included_treatments <- treatment_levels[
315	60x	treatment_levels %in% included_treatments
316		]
317	60x	selected <- selected[
318	60x	!is.na(selected[[treatment]]) &
319	60x	selected[[treatment]] %in% included_treatments, ,
320	60x	drop = FALSE
321		]
322
323	60x	available_visits <- unique(data.frame(
324	60x	AVISIT = as.character(selected$AVISIT),
325	60x	AVISITN = selected$AVISITN,
326	60x	stringsAsFactors = FALSE
327		))
328	60x	requested_visits <- selections$visits
329	60x	if (!is.null(requested_visits)) {
330	60x	if (!checkmate::test_character(
331	60x	requested_visits,
332	60x	any.missing = FALSE,
333	60x	unique = TRUE
334		)) {
335	!	return(.block_profile(result, .new_profile_diagnostic(
336	!	"visit_not_available",
337	!	"Included visits must be unique non-missing labels"
338		)))
339		}
340	60x	selected <- selected[
341	60x	is.na(selected$AVISIT) \| selected$AVISIT %in% requested_visits, ,
342	60x	drop = FALSE
343		]
344	60x	available_visits <- available_visits[
345	60x	!is.na(available_visits$AVISIT) &
346	60x	available_visits$AVISIT %in% requested_visits, ,
347	60x	drop = FALSE
348		]
349		}
350
351	60x	mapping_missing <- any(
352	60x	is.na(selected$AVISIT) \|
353	60x	!nzchar(as.character(selected$AVISIT)) \|
354	60x	is.na(selected$AVISITN)
355		)
356	60x	label_counts <- tapply(
357	60x	selected$AVISITN,
358	60x	selected$AVISIT,
359	60x	function(x) length(unique(x[!is.na(x)]))
360		)
361	60x	order_counts <- tapply(
362	60x	as.character(selected$AVISIT),
363	60x	selected$AVISITN,
364	60x	function(x) length(unique(x[!is.na(x)]))
365		)
366	60x	mapping_conflict <- any(label_counts != 1L) \|\| any(order_counts != 1L)
367	60x	if (mapping_missing \|\| mapping_conflict) {
368	5x	mapping_ref <- canonical_hash(list(
369	5x	missing_count = sum(is.na(selected$AVISIT) \| is.na(selected$AVISITN)),
370	5x	mappings = .normalize_study_data(available_visits)
371		))
372	5x	return(.block_profile(result, .new_profile_diagnostic(
373	5x	"invalid_visit_mapping",
374	5x	paste0(
375	5x	"The selected AVISIT and AVISITN mapping does not provide a ",
376	5x	"deterministic visit order"
377		),
378	5x	nrow(selected),
379	5x	mapping_ref
380		)))
381		}
382
383	55x	mapping <- unique(selected[c("AVISIT", "AVISITN")])
384	55x	mapping <- mapping[
385	55x	order(mapping$AVISITN, mapping$AVISIT, method = "radix"), ,
386	55x	drop = FALSE
387		]
388	55x	available_visit_labels <- as.character(mapping$AVISIT)
389	55x	if (!is.null(requested_visits) &&
390	55x	length(setdiff(requested_visits, available_visit_labels))) {
391	!	return(.block_profile(result, .new_profile_diagnostic(
392	!	"visit_not_available",
393	!	paste0(
394	!	"Every included visit must be present after explicit parameter, ",
395	!	"unit, and treatment selections"
396		)
397		)))
398		}
399	55x	included_visits <- available_visit_labels
400	55x	result$choices$visits <- available_visit_labels
401	55x	result$choices$included_treatment_levels <- included_treatments
402	55x	result$choices$included_visits <- included_visits
403	55x	result$facet_levels <- included_treatments
404	55x	result$visit_levels <- included_visits
405
406	55x	key_columns <- c("USUBJID", "PARAMCD", "AVISIT")
407	55x	duplicate_rows <- duplicated(selected[key_columns]) \|
408	55x	duplicated(selected[key_columns], fromLast = TRUE)
409	55x	if (any(duplicate_rows)) {
410	5x	duplicate_keys <- unique(selected[
411	5x	duplicate_rows, key_columns,
412	5x	drop = FALSE
413		])
414	5x	duplicate_keys <- .sort_profile_data(duplicate_keys, "PARAMCD")
415	5x	additional_keys <- setdiff(snapshot$declared_keys, c(
416	5x	"STUDYID", "USUBJID", "PARAMCD", "AVISIT", "AVISITN"
417		))
418	5x	code <- if (length(additional_keys)) {
419	2x	"unsupported_additional_timepoint_keys"
420		} else {
421	3x	"unsupported_duplicate_visit_key"
422		}
423	5x	message <- if (length(additional_keys)) {
424	2x	paste0(
425	2x	"The ADaM source declares additional legitimate keys and is ",
426	2x	"unsupported by this visit-based cell"
427		)
428		} else {
429	3x	paste0(
430	3x	"Duplicate subject-parameter-visit keys are unsupported by this ",
431	3x	"visit-based cell"
432		)
433		}
434	5x	diagnostic <- .new_profile_diagnostic(
435	5x	code,
436	5x	message,
437	5x	nrow(duplicate_keys),
438	5x	canonical_hash(.normalize_study_data(duplicate_keys))
439		)
440	5x	return(.block_profile(
441	5x	result,
442	5x	diagnostic,
443	5x	list(duplicate_keys = duplicate_keys, additional_keys = additional_keys)
444		))
445		}
446
447	50x	selected <- .sort_profile_data(selected, treatment)
448	50x	display <- selected[!is.na(selected[[y]]), , drop = FALSE]
449	50x	display <- .sort_profile_data(display, treatment)
450	50x	if (nrow(display)) {
451	50x	groups <- split(
452	50x	seq_len(nrow(display)),
453	50x	interaction(
454	50x	display[[treatment]], display$AVISIT,
455	50x	drop = TRUE, lex.order = TRUE
456		)
457		)
458	50x	count_rows <- lapply(groups, function(index) {
459	280x	rows <- display[index, , drop = FALSE]
460	280x	source_rows <- selected[
461	280x	selected[[treatment]] == rows[[treatment]][1] &
462	280x	selected$AVISIT == rows$AVISIT[1], ,
463	280x	drop = FALSE
464		]
465	280x	data.frame(
466	280x	treatment_value = as.character(rows[[treatment]][1]),
467	280x	AVISIT = as.character(rows$AVISIT[1]),
468	280x	AVISITN = rows$AVISITN[1],
469	280x	source_n = length(unique(source_rows$USUBJID)),
470	280x	n = length(unique(rows$USUBJID)),
471	280x	stringsAsFactors = FALSE
472		)
473		})
474	50x	counts <- do.call(rbind, count_rows)
475	50x	names(counts)[1] <- treatment
476	50x	counts$source_n <- as.integer(counts$source_n)
477	50x	counts$n <- as.integer(counts$n)
478	50x	counts$low_n <- counts$n < policy$value
479	50x	counts <- counts[
480	50x	order(counts[[treatment]], counts$AVISITN, method = "radix"), ,
481	50x	drop = FALSE
482		]
483	50x	row.names(counts) <- NULL
484		} else {
485	!	counts <- data.frame()
486		}
487
488	50x	all_combinations <- expand.grid(
489	50x	treatment_value = included_treatments,
490	50x	AVISIT = included_visits,
491	50x	stringsAsFactors = FALSE
492		)
493	50x	displayed_keys <- if (nrow(counts)) {
494	50x	paste(counts[[treatment]], counts$AVISIT, sep = "\u001f")
495		} else {
496	!	character()
497		}
498	50x	empty_combinations <- all_combinations[
499	50x	!paste(
500	50x	all_combinations$treatment_value,
501	50x	all_combinations$AVISIT,
502	50x	sep = "\u001f"
503	50x	) %in% displayed_keys, ,
504	50x	drop = FALSE
505		]
506	50x	warnings <- list()
507	50x	if (nrow(counts) && any(counts$low_n)) {
508	50x	sparse <- counts[
509	50x	counts$low_n, c(treatment, "AVISIT", "AVISITN", "n"),
510	50x	drop = FALSE
511		]
512	50x	warnings[[length(warnings) + 1L]] <- .new_profile_diagnostic(
513	50x	"low_sample_size",
514	50x	paste0(
515	50x	"One or more displayed treatment-visit boxes are below the ",
516	50x	"retained low-N threshold"
517		),
518	50x	nrow(sparse),
519	50x	canonical_hash(sparse)
520		)
521		}
522	50x	if (nrow(empty_combinations)) {
523	4x	warnings[[length(warnings) + 1L]] <- .new_profile_diagnostic(
524	4x	"empty_treatment_visit",
525	4x	paste0(
526	4x	"One or more included treatment-visit combinations have no ",
527	4x	"non-missing selected Y value"
528		),
529	4x	nrow(empty_combinations),
530	4x	canonical_hash(empty_combinations)
531		)
532		}
533	50x	empty_treatments <- setdiff(
534	50x	included_treatments,
535	50x	unique(as.character(display[[treatment]]))
536		)
537	50x	if (length(empty_treatments)) {
538	2x	warnings[[length(warnings) + 1L]] <- .new_profile_diagnostic(
539	2x	"empty_treatment_level",
540	2x	"One or more included treatment levels remain as empty facets",
541	2x	length(empty_treatments),
542	2x	canonical_hash(empty_treatments)
543		)
544		}
545
546	50x	result$selected_data <- selected
547	50x	result$analysis_data <- .minimize_analysis_data(selected, treatment, y)
548	50x	result$display_data <- display
549	50x	result$counts <- counts
550	50x	result$warnings <- warnings
551	50x	result$durable_diagnostics <- warnings
552	50x	result$analytical_input_hash <- canonical_hash(list(
553	50x	data = .normalize_study_data(display),
554	50x	selections = selections,
555	50x	facet_levels = result$facet_levels,
556	50x	visit_levels = result$visit_levels,
557	50x	low_n_policy = policy
558		))
559	50x	result
560		}

1		new_execution_request <- function(
2		spec,
3		script_hash,
4		snapshot_id,
5		snapshot_hash,
6		harness_version
7		) {
8	24x	.validate_plot_spec(spec)
9	24x	values <- list(script_hash, snapshot_id, snapshot_hash, harness_version)
10	24x	if (!all(vapply(values, checkmate::test_string, logical(1), min.chars = 1))) {
11	!	cli::cli_abort(paste0(
12	!	"Execution requests require non-empty script, snapshot, ",
13	!	"and harness identifiers"
14		))
15		}
16	24x	structure(
17	24x	list(
18	24x	manifest_version = "execution-request-v1",
19	24x	spec_hash = spec$hash,
20	24x	script_hash = script_hash,
21	24x	snapshot_id = snapshot_id,
22	24x	snapshot_hash = snapshot_hash,
23	24x	harness_version = harness_version
24		),
25	24x	class = "execution_request"
26		)
27		}
28
29		new_execution_result <- function(
30		request,
31		analytical_hash,
32		image_hash,
33		environment_fingerprint
34		) {
35	20x	if (!inherits(request, "execution_request")) {
36	!	cli::cli_abort("{.arg request} must be an {.cls execution_request}")
37		}
38	20x	values <- list(analytical_hash, image_hash, environment_fingerprint)
39	20x	if (!all(vapply(values, checkmate::test_string, logical(1), min.chars = 1))) {
40	!	cli::cli_abort(paste0(
41	!	"Execution results require analytical, image, ",
42	!	"and environment identifiers"
43		))
44		}
45	20x	manifest <- unclass(request)
46	20x	manifest$manifest_version <- "execution-result-v1"
47	20x	structure(
48	20x	c(manifest, list(
49	20x	analytical_hash = analytical_hash,
50	20x	image_hash = image_hash,
51	20x	environment_fingerprint = environment_fingerprint
52		)),
53	20x	class = "execution_result"
54		)
55		}