AI for Biometrics

Run and build the Trial-Termination Early-Warning console

The complete R Shiny console, every line

Run it

The interactive tool is a real R Shiny app you own. From the package root:

install.packages(c("shiny", "bslib", "DT"))   # once
shiny::runApp("risk_monitor/shiny")

Select a signal, set its level (green / amber / red), and watch the tier RAG and the overall termination-risk index re-colour. Use “Reset to feed” to return to the seed state. The AI flags and drafts; the SRC / DSMB / medical monitor / PM / account lead decide. Synthetic, no PHI, no participant records.

The whole console is two files, shown here in full, nothing elided:

shiny/R/logic.R — the pure roll-up scoring (no Shiny). The visual guide, the dashboard, and the unit tests call these same functions.
shiny/app.R — the UI and the reactive server.

The one idea to hold onto: the rules live in logic.R, the screen lives in app.R. You can change what a tier RAG means without touching the app, and change how it looks without touching the rules.

The data it reads

One CSV is the whole dataset. Edit it to point the console at your study (keep the column names): signals.csv. It carries tier, id, signal, category, engine, level, weight, advanced, detail, a representative subset of the 65-signal catalog. The advanced = TRUE rows are the continuous signals from the published-method engine (Optimal Transport / Wasserstein drift, Active Inference / free-energy).

The complete logic core: shiny/R/logic.R

Every line of the roll-up. risk_load() reads the CSV and levels the RAG factor; tier_score() is the severity-weighted blend of one tier; risk_overall() weights the tiers (participant safety heaviest); risk_feed() is the firing-only, red-first list; risk_counts() is the tally. Nothing here depends on Shiny, so you can test it in a plain console.

# ---------------------------------------------------------------------------
# logic.R - pure roll-up scoring for the 3-tier Trial-Termination Early-Warning
# console. Operations-only, synthetic, no PHI, no participant-level data (the
# "participant tier" holds de-identified signal states, never records).
#
# The AI flags; the SRC / DSMB / medical monitor / PM / account lead decide.
# Reported safety numbers come from the validated safety database, never here.
# The advanced-engine signals use published methods (Optimal Transport /
# Wasserstein drift, Active Inference / free-energy) - flagged `advanced`.
# ---------------------------------------------------------------------------

TIERS <- c("Participant", "Study", "Client")
SEVERITY <- c(green = 0, amber = 50, red = 100)
TIER_WEIGHT <- c(Participant = 0.50, Study = 0.30, Client = 0.20)

risk_load <- function(dir = NULL) {
  cand <- c(dir, "data", "../data", "shiny/data", "risk_monitor/shiny/data")
  cand <- Filter(Negate(is.null), cand)
  base <- Find(function(d) file.exists(file.path(d, "signals.csv")), cand)
  if (is.null(base)) stop("Cannot find signals.csv")
  s <- utils::read.csv(file.path(base, "signals.csv"), stringsAsFactors = FALSE)
  s$level <- factor(s$level, levels = c("green", "amber", "red"))
  s$weight <- as.numeric(s$weight)
  s
}

rag_of <- function(score) ifelse(score > 55, "red", ifelse(score > 25, "amber", "green"))

# Weighted roll-up of one tier's signals to a 0..100 score + a RAG.
tier_score <- function(signals, tier) {
  x <- signals[signals$tier == tier, ]
  if (!nrow(x)) return(list(score = 0, rag = "green", n = 0, red = 0, amber = 0))
  sev <- SEVERITY[as.character(x$level)]
  score <- sum(sev * x$weight) / sum(x$weight)
  list(score = round(score), rag = rag_of(score), n = nrow(x),
       red = sum(x$level == "red"), amber = sum(x$level == "amber"))
}

risk_overall <- function(signals) {
  ts <- vapply(TIERS, function(t) tier_score(signals, t)$score, numeric(1))
  w <- TIER_WEIGHT[TIERS]
  score <- round(sum(ts * w) / sum(w))
  list(score = score, rag = rag_of(score),
       tiers = setNames(lapply(TIERS, function(t) tier_score(signals, t)), TIERS))
}

# The early-warning feed: every firing (non-green) signal, ranked red-first.
risk_feed <- function(signals) {
  f <- signals[signals$level != "green", ]
  if (!nrow(f)) return(f)
  f <- f[order(f$level != "red", f$tier), ]
  f
}

risk_counts <- function(signals) {
  list(total = nrow(signals),
       red = sum(signals$level == "red"),
       amber = sum(signals$level == "amber"),
       green = sum(signals$level == "green"),
       advanced = sum(as.logical(signals$advanced)))
}

Read the roll-up: each signal has a level mapped to a severity in SEVERITY (green 0, amber 50, red 100) and a per-signal weight. A tier score is the weight-weighted mean of its signals’ severities, and risk_overall() blends the three tier scores with TIER_WEIGHT (Participant 0.50, Study 0.30, Client 0.20). rag_of() turns any score into a colour at the thresholds 25 and 55. Change a weight or a threshold on that one line and every surface, the guide, the dashboard, and the app, updates at once.

The complete app: shiny/app.R

Every line of the UI and server. Read it top to bottom; the walk-through below points at the parts that matter.

# ===========================================================================
# app.R - Trial-Termination Early-Warning console (Shiny), 3 tiers.
#
# Participant / Study / Client signals roll up to a tier RAG and an overall
# termination-risk index. Select a signal and change its level to watch the
# tier and overall risk move - the roll-up is transparent. The AI flags; the
# SRC / DSMB / medical monitor / PM / account lead decide. Synthetic, no PHI.
#
# Run:  shiny::runApp("risk_monitor/shiny")
# Data: data/signals.csv (a representative subset; swap in your KRI feed).
# ===========================================================================
library(shiny); library(bslib); library(DT)
source("R/logic.R")
seed <- risk_load("data")
RAG_THEME <- c(green = "success", amber = "warning", red = "danger")

ui <- page_sidebar(
  title = "Trial-Termination Early-Warning",
  theme = bs_theme(version = 5, bootswatch = "darkly", primary = "#5b8cff"),
  sidebar = sidebar(
    width = 320,
    div(class = "small text-muted",
        "3 tiers of early-termination risk. The AI flags and drafts; the SRC / DSMB / ",
        "medical monitor / PM / account lead decide. Synthetic, no PHI, no participant records."),
    selectInput("tier", "Show tier", choices = c("All", TIERS), selected = "All"),
    hr(),
    div(class = "small fw-bold text-muted", "Set a signal's level (what-if)"),
    selectInput("sig", "Signal", choices = setNames(seed$id, paste0(seed$id, " - ", seed$signal))),
    radioButtons("level", NULL, choices = c("green","amber","red"), inline = TRUE),
    actionButton("reset", "Reset to feed", class = "btn-sm btn-outline-warning")
  ),
  layout_columns(
    col_widths = c(3,3,3,3),
    value_box("Overall termination risk", uiOutput("v_overall"), theme = "secondary"),
    value_box("Participant tier", uiOutput("v_part"), theme = "secondary"),
    value_box("Study tier", uiOutput("v_study"), theme = "secondary"),
    value_box("Client tier", uiOutput("v_client"), theme = "secondary")
  ),
  layout_columns(
    col_widths = c(7,5),
    card(card_header("Signals (select a row, then set its level at left)"), DTOutput("signals")),
    card(card_header("Early-warning feed (firing, ranked)"), uiOutput("feed"))
  )
)

server <- function(input, output, session) {
  rv <- reactiveValues(signals = seed)

  observeEvent(input$sig, {
    lvl <- as.character(rv$signals$level[rv$signals$id == input$sig])
    updateRadioButtons(session, "level", selected = lvl)
  })
  observeEvent(input$level, {
    i <- which(rv$signals$id == input$sig)
    if (length(i) == 1 && as.character(rv$signals$level[i]) != input$level)
      rv$signals$level[i] <- factor(input$level, levels = c("green","amber","red"))
  })
  observeEvent(input$signals_rows_selected, {
    r <- input$signals_rows_selected
    view <- if (input$tier == "All") rv$signals else rv$signals[rv$signals$tier == input$tier, ]
    if (length(r) == 1) updateSelectInput(session, "sig", selected = view$id[r])
  })
  observeEvent(input$reset, { rv$signals <- seed
    updateRadioButtons(session, "level",
      selected = as.character(seed$level[seed$id == input$sig])) })

  ov <- reactive(risk_overall(rv$signals))

  vb <- function(id, tier) {
    o <- ov(); ts <- if (tier == "overall") list(score=o$score, rag=o$rag) else o$tiers[[tier]]
    col <- c(green="#43c47d", amber="#e0a64c", red="#e8657a")[ts$rag]
    span(style = sprintf("color:%s", col), sprintf("%d  ·  %s", ts$score, toupper(ts$rag)))
  }
  output$v_overall <- renderUI(vb("overall","overall"))
  output$v_part    <- renderUI(vb("part","Participant"))
  output$v_study   <- renderUI(vb("study","Study"))
  output$v_client  <- renderUI(vb("client","Client"))

  output$signals <- renderDT({
    v <- if (input$tier == "All") rv$signals else rv$signals[rv$signals$tier == input$tier, ]
    d <- v[, c("tier","id","signal","category","engine","level","weight","advanced")]
    d$advanced <- ifelse(as.logical(d$advanced), "ADV", "")
    datatable(d, rownames = FALSE, selection = "single",
              colnames = c("Tier","ID","Signal","Category","Engine","Level","Wt","Adv"),
              options = list(pageLength = 12, dom = "tp", scrollX = TRUE)) |>
      formatStyle("level", fontWeight = "bold",
        color = styleEqual(c("green","amber","red"), c("#43c47d","#e0a64c","#e8657a")))
  }, server = TRUE)

  output$feed <- renderUI({
    f <- risk_feed(rv$signals)
    if (!nrow(f)) return(div(class="text-muted small","No signals firing - all within limits."))
    tagList(lapply(seq_len(nrow(f)), function(j) {
      r <- f[j, ]; col <- if (r$level == "red") "#e8657a" else "#e0a64c"
      adv <- if (as.logical(r$advanced)) span(class="badge bg-secondary ms-1", "ADV") else NULL
      div(class = "d-flex gap-2 py-1", style = "border-bottom:1px solid #2b3350",
        div(style = sprintf("flex:0 0 8px;height:8px;border-radius:50%%;background:%s;margin-top:6px", col)),
        div(div(class="small", tags$b(r$tier), " · ", tags$code(r$id), " ", r$signal, adv),
            div(class="small text-muted", r$detail)))
    }))
  })
}

shinyApp(ui, server)

How the reactivity works, part by part

Follow the data, not the layout. Here is the chain that makes a click re-colour the risk index.

The editable state lives in one place. rv <- reactiveValues(signals = seed) holds the one frame the user can change. Every output reads from rv$signals, so when it changes, everything that depends on it recomputes. That is the entire trick.

The what-if writes into that state. The observer on input$level finds the selected signal by input$sig, and if the chosen level differs, it writes a new factor into rv$signals$level for that row. Selecting a row in the table calls updateSelectInput so the sidebar input$sig follows your click, and switching input$sig calls updateRadioButtons so the level control shows that signal’s current level.

The rule is a reactive expression. ov <- reactive(risk_overall(rv$signals)) re-runs automatically whenever rv$signals changes. You never call risk_overall() by hand.

The value boxes just read the reactive. The helper vb() reads ov(), pulls either the overall score or a named tier from o$tiers, colours the span by its RAG, and each of output$v_overall, output$v_part, output$v_study, and output$v_client renders it. When rv$signals changes, ov() recomputes and all four boxes re-colour.

The table and the feed read the state directly. output$signals renders rv$signals (filtered by input$tier) as a single-select DT; output$feed calls risk_feed(rv$signals) and lays out the firing signals red-first, badging the advanced ones “ADV”. Nothing recomputes by hand; changing rv$signals drives it all.

Reset restores the seed. The observer on input$reset assigns rv$signals <- seed and re-points the level control at the seed level of the current signal.

Verify it without a browser

You can drive the reactive graph headless, which is how this console was checked before it was ever opened in a browser:

shiny::testServer("risk_monitor/shiny", {
  # escalate a Study-tier signal and watch that tier rise
  session$setInputs(sig = "ESC-33", level = "red")
  ov()$tiers$Study$score      # higher than the seed value
  ov()$score                  # the overall index moves with it
})

The unit tests: shiny is not involved

The roll-up is covered by a zero-dependency test you run with Rscript. It is the same file the guide and dashboard trust:

#!/usr/bin/env Rscript
# Unit tests for the 3-tier termination-risk roll-up. Base R only.
# Run:  Rscript risk_monitor/tests/test-logic.R

lp <- Find(file.exists, c("../shiny/R/logic.R", "risk_monitor/shiny/R/logic.R", "shiny/R/logic.R"))
stopifnot("found logic.R" = !is.null(lp)); source(lp)
dir <- Find(function(d) file.exists(file.path(d, "signals.csv")),
            c("../shiny/data", "risk_monitor/shiny/data", "shiny/data"))
s <- risk_load(dir)
o <- risk_overall(s)
f <- risk_feed(s)
cn <- risk_counts(s)

stopifnot(
  "signals loaded"        = nrow(s) == 21,
  "three tiers"           = setequal(unique(s$tier), TIERS),
  "overall in 0..100"     = o$score >= 0 && o$score <= 100,
  "rag valid"             = o$rag %in% c("green","amber","red"),
  "feed is firing only"   = all(f$level != "green"),
  "feed ranked red-first" = nrow(f) == 0 || f$level[1] == "red",
  "counts add up"         = cn$red + cn$amber + cn$green == cn$total
)

# roll-up monotonic: escalating a signal never lowers its tier score
s2 <- s; s2$level[s2$id == "ESC-33"] <- factor("red", levels = c("green","amber","red"))
stopifnot("escalation raises tier score" =
  tier_score(s2, "Study")$score >= tier_score(s, "Study")$score)

cat("Risk logic: all tests passed\n")

Run it:

Rscript risk_monitor/tests/test-logic.R      # prints: Risk logic: all tests passed

Make it yours

Change the rule: edit rag_of() or the TIER_WEIGHT weights in shiny/R/logic.R. Nothing else changes, because everything calls those functions.
Change the data: swap data/signals.csv for your live KRI / stopping-rule feed (same columns).
Add a tier or a signal: add rows to the CSV and, for a new tier, add a TIER_WEIGHT entry and a value box in app.R.

The same skeleton, a logic core plus reactiveValues plus a reactive rule plus outputs, builds the lifecycle monitor, the UAT tracker, and the find-hours app too.