# ---------------------------------------------------------------------------
# logic.R - pure operational-risk scoring for the Study Lifecycle Monitor.
# No PHI, no participant-level data. Plain functions shared by the Shiny app,
# the Quarto docs, and the unit tests. The scoring is deliberately transparent:
# a weighted blend of four operational dimensions, all visible.
# ---------------------------------------------------------------------------
lifecycle_load <- function(dir = NULL) {
cand <- c(dir, "data", "../data", "shiny/data", "lifecycle_dashboard/shiny/data")
cand <- Filter(Negate(is.null), cand)
base <- Find(function(d) file.exists(file.path(d, "studies.csv")), cand)
if (is.null(base)) stop("Cannot find studies.csv (run R/gen_data.R first)")
rd <- function(f) utils::read.csv(file.path(base, f), stringsAsFactors = FALSE)
list(studies = rd("studies.csv"), milestones = rd("milestones.csv"),
deliverables = rd("deliverables.csv"), query_trend = rd("query_trend.csv"))
}
clamp <- function(x) pmax(0, pmin(100, x))
dbl_pressure <- function(phase, days_to_dbl) {
if (phase == "Startup") return(0.15)
d <- days_to_dbl
if (d <= 0) 1 else if (d < 14) .85 else if (d < 30) .6 else if (d < 60) .35 else .2
}
rep_pressure <- function(phase)
switch(phase, "Reporting" = 1, "DB Lock" = .6, "Conduct" = .25, "Startup" = .1, .1)
# Score one study. `overdue` = number of milestones past due (status == "risk").
score_study <- function(s, overdue) {
dblp <- dbl_pressure(s$phase, s$days_to_dbl); repp <- rep_pressure(s$phase)
timeline <- clamp(overdue * 22 + dblp * 45)
data <- clamp((min(1, s$open_queries / 120) * 45 + (1 - s$clean_pct) * 30 +
(1 - s$sdv_pct) * 25) * (0.5 + 0.6 * dblp))
tlf <- clamp((1 - s$tlf_finalized / s$tlf_planned) * 100 * (0.3 + 0.8 * repp))
resource <- clamp((1 - s$dbl_prog_pct / 100) * 55 + min(1, s$discrep / 18) * 45 * repp)
overall <- clamp(0.30 * timeline + 0.28 * data + 0.27 * tlf + 0.15 * resource)
list(Timeline = timeline, Data = data, TLF = tlf, Resource = resource, overall = overall)
}
# Attach score columns (Timeline/Data/TLF/Resource/overall) to the studies frame.
score_portfolio <- function(d) {
st <- d$studies
overdue <- vapply(st$id, function(i)
sum(d$milestones$study_id == i & d$milestones$status == "risk"), integer(1))
sc <- lapply(seq_len(nrow(st)), function(j) score_study(st[j, ], overdue[[j]]))
st$overdue <- overdue
st$Timeline <- round(vapply(sc, `[[`, numeric(1), "Timeline"))
st$Data <- round(vapply(sc, `[[`, numeric(1), "Data"))
st$TLF <- round(vapply(sc, `[[`, numeric(1), "TLF"))
st$Resource <- round(vapply(sc, `[[`, numeric(1), "Resource"))
st$overall <- round(vapply(sc, `[[`, numeric(1), "overall"))
st$rag <- ifelse(st$overall > 66, "red", ifelse(st$overall > 33, "amber", "green"))
st[order(-st$overall), ]
}
deliverables_pct <- function(d, study_id) {
x <- d$deliverables[d$deliverables$study_id == study_id, ]
if (!nrow(x)) return(0)
round(100 * sum(x$done) / sum(x$total))
}
lifecycle_kpis <- function(st, d) {
at_risk <- sum(st$overall > 66); watch <- sum(st$overall > 33 & st$overall <= 66)
tot_q <- sum(st$open_queries)
avg_del <- round(mean(vapply(st$id, function(i) deliverables_pct(d, i), numeric(1))))
future <- st[st$days_to_dbl > 0, ]
next_dbl <- if (nrow(future)) future[order(future$days_to_dbl), ][1, ] else NULL
list(n = nrow(st), at_risk = at_risk, watch = watch, open_q = tot_q, avg_del = avg_del,
next_dbl_days = if (is.null(next_dbl)) NA_integer_ else next_dbl$days_to_dbl,
next_dbl_id = if (is.null(next_dbl)) NA_character_ else next_dbl$id)
}
# Operational early-warning signals, ranked (red before amber).
lifecycle_signals <- function(st, d) {
sigs <- list()
add <- function(sev, who, t, m) sigs[[length(sigs) + 1]] <<-
data.frame(sev = sev, who = who, title = t, msg = m, stringsAsFactors = FALSE)
for (j in seq_len(nrow(st))) {
s <- st[j, ]
qt <- d$query_trend[d$query_trend$study_id == s$id, ]; qt <- qt[order(qt$week), ]
if (s$days_to_dbl > 0 && s$days_to_dbl < 21 && s$open_queries > 15)
add(if (s$days_to_dbl < 10) "red" else "amber", s$id, "DB lock at risk",
sprintf("%d open queries with DBL in %d days", s$open_queries, s$days_to_dbl))
if (nrow(qt) >= 8) { qd <- qt$open_queries[8] - qt$open_queries[5]
if (qd > 10) add(if (qd > 25) "red" else "amber", s$id, "Query backlog rising",
sprintf("+%d open queries over the last 3 weeks", qd)) }
if (rep_pressure(s$phase) >= .6 && s$tlf_finalized / s$tlf_planned < .6)
add(if (s$tlf_finalized / s$tlf_planned < .35) "red" else "amber", s$id, "TLF production behind",
sprintf("%d%% finalized while in %s", round(100 * s$tlf_finalized / s$tlf_planned), s$phase))
if (rep_pressure(s$phase) >= .6 && s$dbl_prog_pct < 60)
add("amber", s$id, "Double-programming lag",
sprintf("%d%% double-programmed, %d open discrepancies", s$dbl_prog_pct, s$discrep))
od <- d$milestones[d$milestones$study_id == s$id & d$milestones$status == "risk", ]
if (nrow(od)) add("red", s$id, "Milestone overdue", paste0(paste(od$milestone, collapse = ", "), " past due"))
}
if (!length(sigs)) return(data.frame())
out <- do.call(rbind, sigs)
out[order(out$sev != "red"), ]
}AI for Biometrics
Run and build the Study Lifecycle Monitor
The complete R Shiny console, every line
Run it
The interactive tool is a real R Shiny app. From the package root:
install.packages(c("shiny", "bslib", "DT", "ggplot2")) # once
shiny::runApp("lifecycle_dashboard/shiny")Pick a study, then move the what-if sliders (open queries, double-programmed %) and watch that study’s row in the risk heatmap re-colour. The scoring is transparent, so every number is defensible.
The whole console is three R files, shown here in full, nothing elided:
- shiny/R/logic.R — the pure scoring and signal logic (no Shiny). The visual guide, the dashboard, and the unit tests call these same functions.
- shiny/R/gen_data.R — the deterministic synthetic portfolio, the four CSVs the app reads.
- 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 “risk” means without touching the app, and change how it looks without touching the rules.
The data it reads
Four CSVs are the whole dataset. Edit them to point the app at your study (keep the column names): studies.csv, milestones.csv, deliverables.csv, query_trend.csv. On a real study you replace them with a read-only CTMS / EDC export carrying the same columns; nothing writes back to a source system.
The complete logic core: shiny/R/logic.R
Every line of the scoring. lifecycle_load() reads the four CSVs; score_study() is the transparent per-study blend; score_portfolio() attaches the score columns and the RAG band; lifecycle_kpis() is the KPI row; lifecycle_signals() ranks the early-warning signals. Nothing here depends on Shiny, so you can test it in a plain console.
Read the score: score_study() builds four sub-scores, then blends them as overall <- clamp(0.30 * timeline + 0.28 * data + 0.27 * tlf + 0.15 * resource), and score_portfolio() turns that into a RAG band with st$rag <- ifelse(st$overall > 66, "red", ifelse(st$overall > 33, "amber", "green")). Change those two lines and you have changed what “at risk” means, everywhere, at once.
The complete data generator: shiny/R/gen_data.R
Every line of the synthetic portfolio. gen_portfolio() writes the four CSVs deterministically (fixed seed), and forces CP-108 into a clearly at-risk state so the red gate and the signals are exercised. Swap this out for a real export and the app does not change.
# ---------------------------------------------------------------------------
# gen_data.R - deterministic synthetic study portfolio for the Lifecycle Monitor.
# No PHI, no participant-level data. Writes the CSVs the app reads, so on a real
# study you replace them with a read-only CTMS / EDC export (same columns).
# Run: Rscript R/gen_data.R (writes ../data/*.csv relative to shiny/)
# ---------------------------------------------------------------------------
gen_portfolio <- function(out_dir = "data", today = as.Date("2026-06-21"), seed = 20260621L) {
set.seed(seed)
phases <- c("Startup", "Conduct", "DB Lock", "Reporting")
designs <- c("Parallel SAD", "Parallel MAD", "2x2 Crossover BE",
"Fixed-sequence DDI", "Food-effect", "Single-ascending FIH")
ms_keys <- c("Protocol", "SAP", "FPFV", "LPLV", "DBL", "TLFs", "CSR")
owners <- c("A. Rivera", "J. Okafor", "M. Chen", "S. Patel", "L. Dubois", "K. Novak")
offs <- c(0, 18, 35, 150, 185, 215, 250)
rf <- function(a, b) a + runif(1) * (b - a)
ri <- function(a, b) as.integer(floor(a + runif(1) * (b - a + 1)))
assigned <- c("Startup","Startup","Conduct","Conduct","DB Lock","DB Lock","Reporting","Reporting")
studies <- list(); milestones <- list(); deliverables <- list(); qtrends <- list()
for (i in 0:7) {
id <- paste0("CP-", 101 + i)
phase <- assigned[i + 1]
prog <- switch(phase, "Startup" = rf(.05,.25), "Conduct" = rf(.3,.6),
"DB Lock" = rf(.6,.8), "Reporting" = rf(.8,.98))
design <- designs[(i %% length(designs)) + 1]
target <- sample(c(24,32,40,48,60,16), 1)
enrolled <- if (phase=="Startup") ri(0, round(target*.4))
else if (phase=="Conduct") ri(round(target*.5), target) else target
base <- today - (round(prog*240) + 30)
ms_status <- character(7); ms_date <- as.Date(rep(NA, 7))
for (j in 1:7) {
d <- base + offs[j]; ms_date[j] <- d
done <- d < today && runif(1) < .92
s <- if (done) "done" else if (d < today + 14 && d >= today) "wip" else if (d < today) "risk" else "todo"
if (prog > 0.9 && j < 6) s <- "done"
ms_status[j] <- s
}
days_to_dbl <- as.integer(ms_date[5] - today)
openQ <- switch(phase, "Startup" = ri(0,6), "Conduct" = ri(25,120),
"DB Lock" = ri(10,48), "Reporting" = ri(0,8))
q <- openQ + ri(0,40); qt <- integer(8)
for (t in 1:8) { q <- max(0, round(q + if (phase=="Reporting") -q*.2 else rf(-8,10))); qt[t] <- q }
qt[8] <- openQ
clean_pct <- min(.999, prog*0.7 + rf(.2,.32))
sdv_pct <- min(.999, prog*0.6 + rf(.2,.35))
planned <- sample(c(90,120,150,180,72), 1)
rep_frac <- switch(phase, "Reporting" = rf(.6,1), "DB Lock" = rf(.15,.4),
"Conduct" = rf(0,.15), "Startup" = rf(0,.05))
programmed <- round(planned * min(1, rep_frac + rf(.05,.2)))
qcd <- round(programmed * rf(.55,.85)); finalized <- round(qcd * rf(.55,.95))
dbl_prog_pct <- ri(40,85); discrep <- ri(0,18)
# deliverables register (echoes Protocol->CSR, scaled), 4 phase buckets
dtot <- c(Startup=14, Conduct=26, Analysis=34, Reporting=20)
stagew <- c(1, .85, .55, .2)
for (idx in seq_along(dtot)) {
p <- names(dtot)[idx]; tot <- dtot[[idx]]
done_n <- min(tot, round(tot * max(0, min(1, prog/stagew[idx] - (idx-1)*.15 + rf(-.05,.05)))))
deliverables[[length(deliverables)+1]] <- data.frame(
study_id=id, phase=p, done=as.integer(done_n), total=as.integer(tot), stringsAsFactors=FALSE)
}
for (j in 1:7) milestones[[length(milestones)+1]] <- data.frame(
study_id=id, milestone=ms_keys[j], date=as.character(ms_date[j]), status=ms_status[j], stringsAsFactors=FALSE)
for (t in 1:8) qtrends[[length(qtrends)+1]] <- data.frame(
study_id=id, week=t, open_queries=as.integer(qt[t]), stringsAsFactors=FALSE)
studies[[length(studies)+1]] <- data.frame(
id=id, name=paste0(design, " study"), phase=phase, design=design, owner=sample(owners,1),
target=target, enrolled=enrolled, sites=ri(1,4), days_to_dbl=days_to_dbl,
open_queries=openQ, clean_pct=round(clean_pct,3), sdv_pct=round(sdv_pct,3),
tlf_planned=planned, tlf_programmed=programmed, tlf_qcd=qcd, tlf_finalized=finalized,
dbl_prog_pct=dbl_prog_pct, discrep=discrep, stringsAsFactors=FALSE)
}
studies <- do.call(rbind, studies)
# force CP-108 to be clearly AT RISK so the red state + signals are exercised
k <- studies$id == "CP-108"
studies$phase[k] <- "Reporting"; studies$days_to_dbl[k] <- -24L
studies$tlf_programmed[k] <- round(studies$tlf_planned[k]*0.45)
studies$tlf_qcd[k] <- round(studies$tlf_planned[k]*0.22)
studies$tlf_finalized[k] <- round(studies$tlf_planned[k]*0.10)
studies$dbl_prog_pct[k] <- 42L; studies$discrep[k] <- 16L
studies$open_queries[k] <- 7L; studies$clean_pct[k] <- 0.91; studies$sdv_pct[k] <- 0.86
ms_all <- do.call(rbind, milestones)
ms_all$status[ms_all$study_id=="CP-108" & ms_all$milestone %in% c("TLFs","CSR")] <- "risk"
dir.create(out_dir, showWarnings = FALSE, recursive = TRUE)
utils::write.csv(studies, file.path(out_dir, "studies.csv"), row.names = FALSE)
utils::write.csv(ms_all, file.path(out_dir, "milestones.csv"), row.names = FALSE)
utils::write.csv(do.call(rbind, deliverables), file.path(out_dir, "deliverables.csv"), row.names = FALSE)
utils::write.csv(do.call(rbind, qtrends), file.path(out_dir, "query_trend.csv"), row.names = FALSE)
invisible(studies)
}
if (sys.nframe() == 0) gen_portfolio(out_dir = file.path(dirname(getwd()), "data"))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 - Study Lifecycle Monitor (Shiny)
#
# A runnable, editable operational study-lifecycle console. Portfolio RAG
# heatmap, ranked early-warning signals, portfolio query trend, and a per-study
# detail (milestones, TLF funnel, deliverables). The scoring is transparent:
# nudge a study's open queries or double-programming and watch its risk move.
# No PHI, no participant-level data. Synthetic, deterministic.
#
# Run: shiny::runApp("lifecycle_dashboard/shiny")
# Data: data/*.csv (regenerate with Rscript R/gen_data.R, or swap in a CTMS export).
# ===========================================================================
library(shiny); library(bslib); library(DT); library(ggplot2)
source("R/logic.R")
if (!file.exists("data/studies.csv")) { source("R/gen_data.R"); gen_portfolio("data") }
seed <- lifecycle_load("data")
MS_ORDER <- c("Protocol","SAP","FPFV","LPLV","DBL","TLFs","CSR")
DARK <- theme_minimal(base_size = 12) + theme(
legend.position = "none", plot.background = element_rect(fill="#222630", colour=NA),
panel.background = element_rect(fill="#222630", colour=NA), text = element_text(colour="#e9edf7"),
axis.text = element_text(colour="#c5cee4"), panel.grid = element_line(colour="#3a4157"),
plot.title = element_text(colour="#e9edf7", size=12))
ui <- page_sidebar(
title = "Study Lifecycle Monitor",
theme = bs_theme(version = 5, bootswatch = "darkly", primary = "#5b8cff"),
sidebar = sidebar(
width = 300,
div(class = "small text-muted", "Operational health, protocol to CSR. Synthetic, no PHI. ",
"Pick a study, then nudge the what-if sliders to see the transparent score move."),
selectInput("study", "Study", choices = sort(seed$studies$id), selected = "CP-108"),
hr(),
div(class = "small fw-bold text-muted", "What-if on the selected study"),
sliderInput("openq", "Open queries", min = 0, max = 150, value = 0),
sliderInput("dblprog", "Double-programmed %", min = 0, max = 100, value = 50),
actionButton("reset", "Reset to data", class = "btn-sm btn-outline-warning")
),
layout_columns(
col_widths = c(2,2,2,2,2,2),
value_box("Active studies", textOutput("k_n"), theme="secondary"),
value_box("At risk", textOutput("k_risk"), theme="danger"),
value_box("On watch", textOutput("k_watch"), theme="warning"),
value_box("Open queries", textOutput("k_q"), theme="secondary"),
value_box("Avg deliv.", textOutput("k_del"), theme="info"),
value_box("Next DB lock", textOutput("k_dbl"), theme="secondary")
),
layout_columns(
col_widths = c(7,5),
card(card_header("Portfolio risk heatmap (click a row to select)"), plotOutput("heat", height="300px", click="heat_click")),
card(card_header("Early-warning signals (ranked)"), uiOutput("signals"))
),
layout_columns(
col_widths = c(5,7),
card(card_header("Portfolio open-query trend (8 weeks)"), plotOutput("trend", height="240px")),
card(card_header(textOutput("detail_hdr")),
layout_columns(col_widths = c(6,6),
plotOutput("milestones", height="220px"), plotOutput("funnel", height="220px")))
)
)
server <- function(input, output, session) {
rv <- reactiveValues(studies = seed$studies)
# keep the what-if sliders in sync with the selected study's data
observeEvent(input$study, {
s <- rv$studies[rv$studies$id == input$study, ]
updateSliderInput(session, "openq", value = s$open_queries,
max = max(150, s$open_queries))
updateSliderInput(session, "dblprog", value = s$dbl_prog_pct)
})
observeEvent(list(input$openq, input$dblprog), {
i <- which(rv$studies$id == input$study)
if (length(i) == 1) { rv$studies$open_queries[i] <- input$openq
rv$studies$dbl_prog_pct[i] <- input$dblprog }
})
observeEvent(input$reset, {
rv$studies <- seed$studies
s <- seed$studies[seed$studies$id == input$study, ]
updateSliderInput(session, "openq", value = s$open_queries)
updateSliderInput(session, "dblprog", value = s$dbl_prog_pct)
})
data_now <- reactive(list(studies = rv$studies, milestones = seed$milestones,
deliverables = seed$deliverables, query_trend = seed$query_trend))
st <- reactive(score_portfolio(data_now()))
kpi <- reactive(lifecycle_kpis(st(), data_now()))
output$k_n <- renderText(as.character(kpi()$n))
output$k_risk <- renderText(as.character(kpi()$at_risk))
output$k_watch <- renderText(as.character(kpi()$watch))
output$k_q <- renderText(as.character(kpi()$open_q))
output$k_del <- renderText(sprintf("%d%%", kpi()$avg_del))
output$k_dbl <- renderText(if (is.na(kpi()$next_dbl_days)) "-" else sprintf("%dd", kpi()$next_dbl_days))
heat_long <- reactive({
x <- st(); dims <- c("Timeline","Data","TLF","Resource")
do.call(rbind, lapply(dims, function(dm) data.frame(
id = x$id, dim = dm, value = x[[dm]], stringsAsFactors = FALSE)))
})
output$heat <- renderPlot({
x <- st(); hl <- heat_long()
hl$id <- factor(hl$id, levels = rev(x$id))
hl$dim <- factor(hl$dim, levels = c("Timeline","Data","TLF","Resource"))
ggplot(hl, aes(dim, id, fill = value)) +
geom_tile(colour = "#222630", linewidth = 1.5) +
geom_text(aes(label = value), colour = "#0b1020", fontface = "bold", size = 4) +
scale_fill_gradientn(colours = c("#43c47d","#e0a64c","#e8657a"), limits = c(0,100)) +
labs(x = NULL, y = NULL) + DARK + theme(panel.grid = element_blank())
})
observeEvent(input$heat_click, {
x <- st(); lv <- rev(x$id)
idx <- round(input$heat_click$y)
if (!is.na(idx) && idx >= 1 && idx <= length(lv))
updateSelectInput(session, "study", selected = as.character(lv[idx]))
})
output$signals <- renderUI({
sg <- lifecycle_signals(st(), data_now())
if (!nrow(sg)) return(div(class="text-muted small","No operational signals above threshold."))
rows <- lapply(seq_len(min(9, nrow(sg))), function(j) {
r <- sg[j, ]; col <- if (r$sev == "red") "#e8657a" else "#e0a64c"
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$who), " - ", r$title),
div(class="small text-muted", r$msg)))
})
tagList(rows)
})
output$trend <- renderPlot({
qt <- seed$query_trend
agg <- aggregate(open_queries ~ week, qt, sum)
ggplot(agg, aes(week, open_queries)) +
geom_line(colour = "#5b8cff", linewidth = 1.2) + geom_point(colour = "#5b8cff", size = 2) +
labs(x = "Week", y = "Open queries (portfolio)") + DARK
})
output$detail_hdr <- renderText({ s <- rv$studies[rv$studies$id == input$study, ]
sprintf("%s - %s (%s) · %d%% deliverables complete", s$id, s$name, s$phase,
deliverables_pct(data_now(), s$id)) })
output$milestones <- renderPlot({
m <- seed$milestones[seed$milestones$study_id == input$study, ]
m$milestone <- factor(m$milestone, levels = rev(MS_ORDER))
m$date <- as.Date(m$date)
cols <- c(done="#43c47d", wip="#5b8cff", risk="#e8657a", todo="#6b7794")
ggplot(m, aes(date, milestone, colour = status)) +
geom_point(size = 5) + geom_text(aes(label = milestone), colour="#c5cee4", hjust=-0.25, size=3.3) +
scale_colour_manual(values = cols) +
labs(x = NULL, y = NULL, title = "Milestone track") + DARK +
theme(axis.text.y = element_blank(), panel.grid.major.y = element_blank())
})
output$funnel <- renderPlot({
s <- rv$studies[rv$studies$id == input$study, ]
f <- data.frame(stage = factor(c("Planned","Programmed","QC'd","Finalized"),
levels = rev(c("Planned","Programmed","QC'd","Finalized"))),
n = c(s$tlf_planned, s$tlf_programmed, s$tlf_qcd, s$tlf_finalized))
ggplot(f, aes(n, stage)) + geom_col(fill = "#3fd0c9", width = 0.7) +
geom_text(aes(label = n), hjust = -0.2, colour = "#e9edf7", size = 3.5) +
labs(x = NULL, y = NULL, title = "TLF production funnel") + DARK +
xlim(0, max(s$tlf_planned) * 1.15)
})
}
shinyApp(ui, server)How the reactivity works, part by part
Follow the data, not the layout. Here is the chain that makes a slider re-colour the heatmap.
The editable state lives in one place. rv <- reactiveValues(studies = seed$studies) holds the one frame the user can change. Every output reads from a reactive built on rv, so when rv$studies changes, everything that depends on it recomputes. That is the entire trick.
The what-if writes back to that state. The observer on list(input$openq, input$dblprog) finds the selected study’s row with which(rv$studies$id == input$study) and writes the slider values into rv$studies$open_queries[i] and rv$studies$dbl_prog_pct[i]. A second observer on input$study keeps the sliders in sync when you switch studies, and input$reset restores seed$studies.
The rules are reactive expressions. The data_now reactive reassembles the portfolio (studies from rv$studies, plus the seed milestones, deliverables, and query trend), st <- reactive(score_portfolio(data_now())) re-scores it, and kpi <- reactive(lifecycle_kpis(st(), data_now())) rolls it up. These re-run automatically whenever rv$studies changes. You never call the scorer by hand.
Every output just reads the reactives. The value boxes read kpi(), the heatmap reads st() through heat_long(), the ranked signals read lifecycle_signals(st(), data_now()), and the per-study milestone track and TLF funnel read rv$studies for the selected input$study.
Clicking the heatmap selects a study. The observer on input$heat_click rounds the click y-position to a row index into rev(x$id) and calls updateSelectInput() so the detail panels follow. Nothing recomputes by hand; changing rv (or the selection) triggers the reactive that does.
Verify it without a browser
You can drive the reactive graph headless, which is how this app was checked before it was ever opened in a browser:
shiny::testServer("lifecycle_dashboard/shiny", {
# push a study's open queries to the top of the slider and watch its risk rise
session$setInputs(study = "CP-108", openq = 150)
st()$overall[st()$id == "CP-108"] # rises as open queries climb
})The unit tests: shiny is not involved
The scoring 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 Study Lifecycle Monitor scoring. Base R only.
# Run: Rscript lifecycle_dashboard/tests/test-logic.R
lp <- Find(file.exists, c("../shiny/R/logic.R", "lifecycle_dashboard/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, "studies.csv")),
c("../shiny/data", "lifecycle_dashboard/shiny/data", "shiny/data"))
d <- lifecycle_load(dir)
st <- score_portfolio(d)
k <- lifecycle_kpis(st, d)
sg <- lifecycle_signals(st, d)
stopifnot(
"8 studies" = nrow(st) == 8,
"scores in 0..100" = all(st$overall >= 0 & st$overall <= 100),
"CP-108 is at risk (red)" = st$rag[st$id == "CP-108"] == "red",
"at least one at-risk" = k$at_risk >= 1,
"portfolio open queries positive" = k$open_q > 0,
"signals ranked red-first" = nrow(sg) == 0 || sg$sev[1] == "red"
)
# scoring monotonic: more open queries never lowers the Data score
s <- d$studies[d$studies$id == "CP-103", ]
lo <- score_study(within(s, open_queries <- 5), 0)$Data
hi <- score_study(within(s, open_queries <- 120), 0)$Data
stopifnot("more open queries -> higher data risk" = hi >= lo)
cat("Lifecycle logic: all tests passed\n")Run it:
Rscript lifecycle_dashboard/tests/test-logic.R # prints: Lifecycle logic: all tests passedMake it yours
- Change the rule: edit
score_study()(or the signal rules inlifecycle_signals()) inshiny/R/logic.R. Nothing else changes, because everything calls those functions. - Change the data: swap the four CSVs in
shiny/data/for a CTMS export with the same columns. - Add a dimension: add a sub-score in
score_study(), add its column toscore_portfolio(), and add it to the heatmap’sdimsvector. - Add a panel: another
card()in the UI and a matchingrender*in the server.
The same skeleton, a logic core plus reactiveValues plus reactive rules plus outputs, builds the UAT tracker and the find-hours app too.