Setup
Package Installation
install.packages("tibble", type = "binary")
install.packages("dplyr", type = "binary")
install.packages("ggplot2", type = "binary")
install.packages("plotly", type = "binary")
install.packages("DT", type = "binary")
install.packages("htmlwidgets", type = "binary")
install.packages("pharmaverseadamjnj")Package Load
library(dplyr)
library(ggplot2)
library(plotly)
library(DT)
library(htmlwidgets)
library(pharmaverseadamjnj)Read in ADSL and carry out some data preparation
adsl <- pharmaverseadamjnj::adsl
adsl2 <- adsl %>%
select(USUBJID, TRT01P, TRTDURD, WEIGHTBL, HEIGHTBL) %>%
filter(!is.na(TRT01P) & !is.na(TRTDURD))
adsl3 <- adsl2 %>%
mutate_if(is.character, as.factor)
tf_colors <- c(
"Placebo" = "#0072B2",
"Xanomeline High Dose" = "#D55E00",
"Xanomeline Low Dose" = "#CC79A7"
)Recipe 1: Make A Figure Interactive
Boxplot: Create The Static Figure
f1 <- ggplot(data = adsl3, aes(x = TRT01P, y = TRTDURD, fill = TRT01P)) +
geom_boxplot() +
scale_x_discrete(name = "Treatment Group") +
scale_y_continuous(
limits = c(0, 250),
breaks = seq(0, 250, 50),
expand = c(0.05, 0.05),
name = "Treatment Duration (Days)"
) +
scale_fill_manual(
values = tf_colors,
name = "Treatment Group"
)Boxplot: Make It Interactive
g1 <- ggplotly(f1)
saveWidget(g1, "boxplotly.html", selfcontained = TRUE)Scatterplot: Create The Static Figure
f2 <- ggplot(data = adsl3, aes(x = HEIGHTBL, y = WEIGHTBL, shape = TRT01P, colour = TRT01P)) +
geom_point() +
scale_x_continuous(
limits = c(0, 150),
breaks = seq(0, 150, 10),
name = "Baseline Height (cm)"
) +
scale_y_continuous(
limits = c(0, 150),
breaks = seq(0, 150, 10),
name = "Baseline Weight (kg)"
) +
scale_shape_manual(
values = c(16, 17, 15),
name = "Treatment Group"
) +
scale_colour_manual(
values = tf_colors,
name = "Treatment Group"
)
Scatterplot: Make It Interactive
g2 <- ggplotly(f2)
saveWidget(g2, "scatterplotly.html", selfcontained = TRUE)Recipe 2: Make A Table Explorable
Prepare The Table
my_table <- adsl3
my_table_2 <- my_table %>%
rename(
"Unique Subject Identifier" = USUBJID,
"Treatment Group" = TRT01P,
"Total Treatment Duration (Days)" = TRTDURD,
"Baseline Weight (kg)" = WEIGHTBL,
"Baseline Height (cm)" = HEIGHTBL
)Make It Interactive
d <- datatable(
my_table_2,
extensions = c("ColReorder"),
rownames = FALSE,
filter = "top",
class = "stripe hover compact",
options = list(
colReorder = TRUE,
pageLength = 5,
lengthMenu = c(5, 10, 12, 20, 50, 100)
)
)
saveWidget(d, "datatable.html", selfcontained = TRUE)Recipe 3: Bring Outputs Together
The final dashboard uses the same building blocks from the recipes above, but places them inside a Quarto dashboard layout.
The main Quarto ideas are:
- YAML: the block at the top between
---lines controls the document type. For the dashboard,format: dashboardtells Quarto to create a dashboard rather than a standard web page. - Code chunks: R code is placed between triple backticks, for example
```{r}and```. Quarto runs these chunks when the page is rendered. - Rows: second-level headings such as
## Row {height="48%"}create horizontal dashboard rows. - Cards: each output chunk inside a row becomes a dashboard card.
- Card titles: chunk options such as
#| title: "Subject-Level Data"give cards their titles. - Same recipe objects: the dashboard reuses the same
f1,g1,f2,g2, anddpattern from Recipes 1 and 2.
Quarto Dashboard Full Code
---
title: "Quarto Dashboard"
output-file: psi-conf-2026-dashboard.html
format:
dashboard:
theme: cosmo
embed-resources: true
execute:
echo: false
warning: false
message: false
---
```{r}
# Run once if needed:
# install.packages("rmarkdown")
# install.packages("tibble")
# install.packages("dplyr")
# install.packages("ggplot2")
# install.packages("plotly")
# install.packages("DT")
# install.packages("htmlwidgets")
# install.packages("pharmaverseadamjnj")
library(dplyr)
library(ggplot2)
library(plotly)
library(DT)
library(htmlwidgets)
library(pharmaverseadamjnj)
adsl <- pharmaverseadamjnj::adsl
adsl2 <- adsl %>%
select(USUBJID, TRT01P, TRTDURD, WEIGHTBL, HEIGHTBL) %>%
filter(!is.na(TRT01P) & !is.na(TRTDURD))
adsl3 <- adsl2 %>%
mutate_if(is.character, as.factor)
tf_colors <- c(
"Placebo" = "#0072B2",
"Xanomeline High Dose" = "#D55E00",
"Xanomeline Low Dose" = "#CC79A7"
)
```
## Row {height="48%"}
```{r}
#| title: "Treatment Duration (Days) by Treatment Group"
f1 <- ggplot(data = adsl3, aes(x = TRT01P, y = TRTDURD, fill = TRT01P)) +
geom_boxplot() +
scale_x_discrete(name = "Treatment Group") +
scale_y_continuous(
limits = c(0, 250),
breaks = seq(0, 250, 50),
expand = c(0.05, 0.05),
name = "Treatment Duration (Days)"
) +
scale_fill_manual(
values = tf_colors,
name = "Treatment Group"
) +
theme_bw() +
theme(legend.position = "top")
g1 <- ggplotly(f1) %>%
layout(
legend = list(
orientation = "h",
x = 0.5,
xanchor = "center",
y = 1.02,
yanchor = "bottom"
),
margin = list(t = 45)
)
g1
```
```{r}
#| title: "Baseline Weight (kg) vs Baseline Height (cm)"
f2 <- ggplot(
data = adsl3,
aes(x = HEIGHTBL, y = WEIGHTBL, shape = TRT01P, colour = TRT01P)
) +
geom_point() +
scale_x_continuous(
limits = c(0, 150),
breaks = seq(0, 150, 10),
name = "Baseline Height (cm)"
) +
scale_y_continuous(
limits = c(0, 150),
breaks = seq(0, 150, 10),
name = "Baseline Weight (kg)"
) +
scale_shape_manual(
values = c(16, 17, 15),
name = "Treatment Group"
) +
scale_colour_manual(
values = tf_colors,
name = "Treatment Group"
) +
theme_bw() +
theme(legend.position = "top")
g2 <- ggplotly(f2) %>%
layout(
legend = list(
orientation = "h",
x = 0.5,
xanchor = "center",
y = 1.02,
yanchor = "bottom"
),
margin = list(t = 45)
)
g2
```
## Row {height="52%"}
```{r}
#| title: "Subject-Level Data"
my_table <- adsl3
my_table_2 <- my_table %>%
rename(
"Unique Subject Identifier" = USUBJID,
"Treatment Group" = TRT01P,
"Total Treatment Duration (Days)" = TRTDURD,
"Baseline Weight (kg)" = WEIGHTBL,
"Baseline Height (cm)" = HEIGHTBL
)
d <- datatable(
my_table_2,
extensions = c("ColReorder"),
rownames = FALSE,
filter = "top",
class = "stripe hover compact",
fillContainer = FALSE,
autoHideNavigation = FALSE,
options = list(
colReorder = TRUE,
bPaginate = TRUE,
paging = TRUE,
lengthChange = TRUE,
searching = TRUE,
info = TRUE,
pageLength = 5,
lengthMenu = c(5, 10, 12, 20, 50, 100),
dom = '<"top"lf>rt<"bottom"ip>',
language = list(
info = "Showing _START_ to _END_ of _TOTAL_ entries"
)
)
)
d
```- To see more Quarto examples, please visit: https://quarto.org/docs/gallery/
Recipe 4: From Quarto dashboard to Shiny app using AI prompts
This recipe shows how the same dashboard code can become the starting point for a Shiny app. The prompts are deliberately iterative: first convert the Quarto dashboard, then add filters, then add more polished controls and downloads, then improve the visual design.
Each prompt asks for the full app.R code so the result can be copied into RStudio and run as a Shiny app.
Prompt 1: Convert The Quarto Dashboard To Shiny
I have already created a Quarto dashboard using the code below. Please convert this into a simple Shiny app that keeps the same data, plots, table, and overall purpose.
At the top of the script, include robust package setup code that:
- sets the CRAN repository to Posit Package Manager: https://packagemanager.posit.co/cran/latest
- installs required packages as binaries where possible using type = "binary"
- avoids reinstalling packages that are already installed
- does not load packages until all package checks are complete
- have library calls for all required packages after package install.
Please reuse as much of the existing Quarto logic as possible, but restructure it into standard Shiny ui and server code.
Here is the Quarto dashboard code:
<PASTE QUARTO DASHBOARD CODE FROM BEFORE HERE>Generated app code: basic Shiny app
Preview
Prompt 2: Add Sidebar Filters
Prompt builder request:
Give me a prompt to update this Shiny app:
- giving the full code
- just updating the first version of the code that was given previously
- Add a sidebar with:
- treatment group filter dropdown menu (multiple choice)
- subject filter dropdown menu (multiple choice)
- sliders for duration, weight, and height
- Ensure all plots and the table respond to these filtersPrompt used:
Please update the first Shiny app version you gave me previously.
Give me the full updated `app.R` code, not just snippets.
Keep the same data source, plots, table, package setup section, colors, and overall app purpose.
Add a sidebar containing these filters:
* Treatment group filter dropdown menu, allowing multiple selections
* Subject filter dropdown menu, allowing multiple selections
* Treatment duration slider
* Baseline weight slider
* Baseline height slider
Requirements:
* The filters should be based on the available values in `adsl3`.
* All filters should have sensible defaults that include all available data.
* The treatment group and subject dropdowns should support multiple selections.
* The duration, weight, and height sliders should use the observed data ranges.
* The two Plotly plots and the DT table must all respond to every filter.
* Reuse as much of the original Shiny app logic as possible.
* Keep the standard Shiny `ui` and `server` structure.
* Include robust package setup at the top exactly as before:
* Set CRAN repository to Posit Package Manager: `https://packagemanager.posit.co/cran/latest`
* Install required packages as binaries where possible using `type = "binary"`
* Avoid reinstalling packages that are already installed
* Do not load packages until all package checks are complete
* Include `library()` calls for all required packages after package installationGenerated app code: Shiny app with filters
Preview
Prompt 3: Improve The Filters And Add Downloads
Prompt builder request:
Give me a prompt to update this Shiny app:
- giving the full code
- just updating the first version of the code that was given previously
- Change the treatment and subject filters to be like this image where we can still choose multiple values
- Add buttons in the sidebar for the user to be able to download static files
Prompt used:
Please update the first Shiny app version you gave me previously.
Give me the full updated `app.R` code, not just a patch.
Keep the same data source, plots, table, colors, and overall app purpose.
Update only the first Shiny app code from earlier, incorporating the existing sidebar filter version where appropriate.
Change the Treatment Group and Subject filters so they look and behave like the screenshot:
* Use multi-select dropdowns that support selecting multiple values.
* Show selected values in the collapsed input as comma-separated text.
* Include a search box inside each dropdown.
* Include Select All and Deselect All controls.
* Show checkmarks for selected items.
* Keep all treatment groups and all subjects selected by default.
Add sidebar buttons that allow the user to download static files:
* Download the Treatment Duration plot as a static image file.
* Download the Baseline Weight vs Baseline Height plot as a static image file.
* Download the filtered subject-level table as a CSV file.
Requirements:
* Keep the existing robust package setup at the top:
* Set CRAN repository to `https://packagemanager.posit.co/cran/latest`
* Install missing required packages using `type = "binary"`
* Avoid reinstalling already installed packages
* Do not load packages until all package checks are complete
* Include `library()` calls after package installation
* Add any additional packages needed for the improved multi-select inputs or static downloads to the package setup.
* Use a reactive filtered dataset in the server.
* All plots and the DT table must respond to all filters.
* The static download buttons should download the currently filtered outputs.
* Reuse as much of the existing Shiny app logic as possible.
* Return only the complete updated `app.R` code.Generated app code: Shiny app with improved filters and downloads
Preview
Prompt 4: Improve The Name And Design
Prompt builder request:
Give me a prompt to update this Shiny app:
- giving the full code
- just updating the first version of the code that was given previously
- Give the dashboard a meaningful name
- Improve the lookPrompt used:
Please update the first Shiny app version you gave me previously.
Give me the full updated `app.R` code, not just a patch.
Keep the same data source, plots, table, colors, filters, downloads, and overall purpose.
Update only the first Shiny app code from earlier, incorporating the current sidebar filter and download-button version where appropriate.
Changes requested:
* Give the dashboard a meaningful clinical-style name instead of "Quarto Dashboard".
* Improve the visual design of the app while keeping it simple and professional.
* Use a cleaner layout with a clear title/header area.
* Improve spacing, alignment, and section headings.
* Make the sidebar visually cleaner and easier to scan.
* Make the plot and table areas look more polished, for example by using card-style containers or similar Shiny/bslib layout elements.
* Keep the app appropriate for a clinical subject-level exploratory dashboard.
Requirements:
* Keep the robust package setup at the top.
* Reuse as much of the existing Shiny app logic as possible.
* All filters, plots, table, and download buttons must continue to work.
* Return only the complete updated `app.R` code.Generated app code: polished Shiny app
Preview
Recipe 5: Build A Survival Dashboard Using Shiny Assistant
This recipe uses Posit’s Shiny Assistant to generate and then iteratively improve a Shiny app from natural-language prompts.
Links:
Prompt 1: Create The Initial Survival Dashboard
Create a polished R Shiny dashboard for exploring simulated clinical trial survival data.
Include:
treatment group filter
subgroup filter
censoring rate slider
Display:
Kaplan-Meier plot
number at risk table
hazard ratio summary
downloadable survival dataset
Use a modern dashboard layout with reactive updates.
Keep the code concise and runnable as a single app.R file.Generated app code: Shiny Assistant version 1
Preview
Prompt 2: Add A Dataset Tab
Can I have the dataset on a second tab?Generated app code: Shiny Assistant version 2
Preview
Prompt 3: Add Zoomable Cards
Can I have zoom in capabilities on each card?Generated app code: Shiny Assistant version 3
Preview
Prompt 4: Add An Adjusted Cox Model Option
Add a checkbox called "Adjust Cox model for age and sex".Generated app code: Shiny Assistant version 4
Preview
Recipe Book 1: Explore teal Apps
teal is a Shiny-based framework for interactive data exploration, with a particular focus on clinical trial data. It gives developers a standard structure for bringing in data, applying filters, adding analysis modules, and producing reproducible outputs.
In a teal app, the main building blocks are:
- data: passed into the app with
teal_data()or clinical data helpers. - modules: analysis components added with
modules(). - filters: shared filtering controls that can be applied across modules.
- app wrapper:
init()brings the data and modules together into a Shiny app.
Useful links:
Example 1: Basic teal App
This is the smallest useful pattern: load example data, pass it into teal_data(), add a simple module, then start the app.
Code: basic teal app
Preview
Example 2: Pre-Built teal Module
This example uses a pre-built clinical module. The app structure stays simple, but the module gives you a clinical-style output without writing the table logic from scratch.
Code: pre-built teal app
Preview
Example 3: Custom teal Module
This example shows the next step: defining a custom module with its own UI and server logic, while still using the standard teal application wrapper.
Code: custom teal app
Preview
Recipe Book 2: Explore AI Coding Tools
These tools show different ways to bring AI assistance into coding and app development workflows.
Full Code
Boxplot Full Code
# PSI Conf 2026 interactivity recipes
install.packages("tibble", type = "binary")
install.packages("dplyr", type = "binary")
install.packages("ggplot2", type = "binary")
install.packages("plotly", type = "binary")
install.packages("htmlwidgets", type = "binary")
install.packages("pharmaverseadamjnj")
library(dplyr)
library(ggplot2)
library(plotly)
library(htmlwidgets)
library(pharmaverseadamjnj)
adsl <- pharmaverseadamjnj::adsl
adsl2 <- adsl %>%
select(USUBJID, TRT01P, TRTDURD, WEIGHTBL, HEIGHTBL) %>%
filter(!is.na(TRT01P) & !is.na(TRTDURD))
adsl3 <- adsl2 %>%
mutate_if(is.character, as.factor)
tf_colors <- c(
"Placebo" = "#0072B2",
"Xanomeline High Dose" = "#D55E00",
"Xanomeline Low Dose" = "#CC79A7"
)
f1 <- ggplot(data = adsl3, aes(x = TRT01P, y = TRTDURD, fill = TRT01P)) +
geom_boxplot() +
scale_x_discrete(name = "Treatment Group") +
scale_y_continuous(
limits = c(0, 250),
breaks = seq(0, 250, 50),
expand = c(0.05, 0.05),
name = "Treatment Duration (Days)"
) +
scale_fill_manual(
values = tf_colors,
name = "Treatment Group"
)
g1 <- ggplotly(f1)
saveWidget(g1, "boxplotly.html", selfcontained = TRUE)Scatterplot Full Code
# PSI Conf 2026 interactivity recipes
install.packages("tibble", type = "binary")
install.packages("dplyr", type = "binary")
install.packages("ggplot2", type = "binary")
install.packages("plotly", type = "binary")
install.packages("htmlwidgets", type = "binary")
install.packages("pharmaverseadamjnj")
library(dplyr)
library(ggplot2)
library(plotly)
library(htmlwidgets)
library(pharmaverseadamjnj)
adsl <- pharmaverseadamjnj::adsl
adsl2 <- adsl %>%
select(USUBJID, TRT01P, TRTDURD, WEIGHTBL, HEIGHTBL) %>%
filter(!is.na(TRT01P) & !is.na(TRTDURD))
adsl3 <- adsl2 %>%
mutate_if(is.character, as.factor)
tf_colors <- c(
"Placebo" = "#0072B2",
"Xanomeline High Dose" = "#D55E00",
"Xanomeline Low Dose" = "#CC79A7"
)
f2 <- ggplot(data = adsl3, aes(x = HEIGHTBL, y = WEIGHTBL, shape = TRT01P, colour = TRT01P)) +
geom_point() +
scale_x_continuous(
limits = c(0, 150),
breaks = seq(0, 150, 10),
name = "Baseline Height (cm)"
) +
scale_y_continuous(
limits = c(0, 150),
breaks = seq(0, 150, 10),
name = "Baseline Weight (kg)"
) +
scale_shape_manual(
values = c(16, 17, 15),
name = "Treatment Group"
) +
scale_colour_manual(
values = tf_colors,
name = "Treatment Group"
)
g2 <- ggplotly(f2)
saveWidget(g2, "scatterplotly.html", selfcontained = TRUE)Table Full Code
# PSI Conf 2026 interactivity recipes
install.packages("tibble", type = "binary")
install.packages("dplyr", type = "binary")
install.packages("DT", type = "binary")
install.packages("htmlwidgets", type = "binary")
install.packages("pharmaverseadamjnj")
library(dplyr)
library(DT)
library(htmlwidgets)
library(pharmaverseadamjnj)
adsl <- pharmaverseadamjnj::adsl
adsl2 <- adsl %>%
select(USUBJID, TRT01P, TRTDURD, WEIGHTBL, HEIGHTBL) %>%
filter(!is.na(TRT01P) & !is.na(TRTDURD))
adsl3 <- adsl2 %>%
mutate_if(is.character, as.factor)
my_table <- adsl3
my_table_2 <- my_table %>%
rename(
"Unique Subject Identifier" = USUBJID,
"Treatment Group" = TRT01P,
"Total Treatment Duration (Days)" = TRTDURD,
"Baseline Weight (kg)" = WEIGHTBL,
"Baseline Height (cm)" = HEIGHTBL
)
d <- datatable(
my_table_2,
extensions = c("ColReorder"),
rownames = FALSE,
filter = "top",
class = "stripe hover compact",
options = list(
colReorder = TRUE,
pageLength = 5,
lengthMenu = c(5, 10, 12, 20, 50, 100)
)
)
saveWidget(d, "datatable.html", selfcontained = TRUE)Quarto Dashboard Full Code
---
title: "Quarto Dashboard"
output-file: psi-conf-2026-dashboard.html
format:
dashboard:
theme: cosmo
embed-resources: true
execute:
echo: false
warning: false
message: false
---
```{r}
# Run once if needed:
# install.packages("rmarkdown")
# install.packages("tibble")
# install.packages("dplyr")
# install.packages("ggplot2")
# install.packages("plotly")
# install.packages("DT")
# install.packages("htmlwidgets")
# install.packages("pharmaverseadamjnj")
library(dplyr)
library(ggplot2)
library(plotly)
library(DT)
library(htmlwidgets)
library(pharmaverseadamjnj)
adsl <- pharmaverseadamjnj::adsl
adsl2 <- adsl %>%
select(USUBJID, TRT01P, TRTDURD, WEIGHTBL, HEIGHTBL) %>%
filter(!is.na(TRT01P) & !is.na(TRTDURD))
adsl3 <- adsl2 %>%
mutate_if(is.character, as.factor)
tf_colors <- c(
"Placebo" = "#0072B2",
"Xanomeline High Dose" = "#D55E00",
"Xanomeline Low Dose" = "#CC79A7"
)
```
## Row {height="48%"}
```{r}
#| title: "Treatment Duration (Days) by Treatment Group"
f1 <- ggplot(data = adsl3, aes(x = TRT01P, y = TRTDURD, fill = TRT01P)) +
geom_boxplot() +
scale_x_discrete(name = "Treatment Group") +
scale_y_continuous(
limits = c(0, 250),
breaks = seq(0, 250, 50),
expand = c(0.05, 0.05),
name = "Treatment Duration (Days)"
) +
scale_fill_manual(
values = tf_colors,
name = "Treatment Group"
) +
theme_bw() +
theme(legend.position = "top")
g1 <- ggplotly(f1) %>%
layout(
legend = list(
orientation = "h",
x = 0.5,
xanchor = "center",
y = 1.02,
yanchor = "bottom"
),
margin = list(t = 45)
)
g1
```
```{r}
#| title: "Baseline Weight (kg) vs Baseline Height (cm)"
f2 <- ggplot(
data = adsl3,
aes(x = HEIGHTBL, y = WEIGHTBL, shape = TRT01P, colour = TRT01P)
) +
geom_point() +
scale_x_continuous(
limits = c(0, 150),
breaks = seq(0, 150, 10),
name = "Baseline Height (cm)"
) +
scale_y_continuous(
limits = c(0, 150),
breaks = seq(0, 150, 10),
name = "Baseline Weight (kg)"
) +
scale_shape_manual(
values = c(16, 17, 15),
name = "Treatment Group"
) +
scale_colour_manual(
values = tf_colors,
name = "Treatment Group"
) +
theme_bw() +
theme(legend.position = "top")
g2 <- ggplotly(f2) %>%
layout(
legend = list(
orientation = "h",
x = 0.5,
xanchor = "center",
y = 1.02,
yanchor = "bottom"
),
margin = list(t = 45)
)
g2
```
## Row {height="52%"}
```{r}
#| title: "Subject-Level Data"
my_table <- adsl3
my_table_2 <- my_table %>%
rename(
"Unique Subject Identifier" = USUBJID,
"Treatment Group" = TRT01P,
"Total Treatment Duration (Days)" = TRTDURD,
"Baseline Weight (kg)" = WEIGHTBL,
"Baseline Height (cm)" = HEIGHTBL
)
d <- datatable(
my_table_2,
extensions = c("ColReorder"),
rownames = FALSE,
filter = "top",
class = "stripe hover compact",
fillContainer = FALSE,
autoHideNavigation = FALSE,
options = list(
colReorder = TRUE,
bPaginate = TRUE,
paging = TRUE,
lengthChange = TRUE,
searching = TRUE,
info = TRUE,
pageLength = 5,
lengthMenu = c(5, 10, 12, 20, 50, 100),
dom = '<"top"lf>rt<"bottom"ip>',
language = list(
info = "Showing _START_ to _END_ of _TOTAL_ entries"
)
)
)
d
```Shiny App 1: Basic App
# app.R
# ---- Robust package setup ----
options(repos = c(CRAN = "https://packagemanager.posit.co/cran/latest"))
required_packages <- c(
"shiny",
"dplyr",
"ggplot2",
"plotly",
"DT",
"htmlwidgets",
"pharmaverseadamjnj"
)
installed_packages <- rownames(installed.packages())
missing_packages <- setdiff(required_packages, installed_packages)
if (length(missing_packages) > 0) {
install.packages(
missing_packages,
type = "binary",
dependencies = TRUE
)
}
# ---- Load packages only after all checks/installations are complete ----
library(shiny)
library(dplyr)
library(ggplot2)
library(plotly)
library(DT)
library(htmlwidgets)
library(pharmaverseadamjnj)
# ---- Data preparation ----
adsl <- pharmaverseadamjnj::adsl
adsl2 <- adsl %>%
select(USUBJID, TRT01P, TRTDURD, WEIGHTBL, HEIGHTBL) %>%
filter(!is.na(TRT01P) & !is.na(TRTDURD))
adsl3 <- adsl2 %>%
mutate_if(is.character, as.factor)
tf_colors <- c(
"Placebo" = "#0072B2",
"Xanomeline High Dose" = "#D55E00",
"Xanomeline Low Dose" = "#CC79A7"
)
# ---- UI ----
ui <- fluidPage(
theme = bslib::bs_theme(bootswatch = "cosmo"),
titlePanel("Quarto Dashboard"),
fluidRow(
column(
width = 6,
h4("Treatment Duration (Days) by Treatment Group"),
plotlyOutput("duration_plot", height = "420px")
),
column(
width = 6,
h4("Baseline Weight (kg) vs Baseline Height (cm)"),
plotlyOutput("height_weight_plot", height = "420px")
)
),
fluidRow(
column(
width = 12,
h4("Subject-Level Data"),
DTOutput("subject_table")
)
)
)
# ---- Server ----
server <- function(input, output, session) {
output$duration_plot <- renderPlotly({
f1 <- ggplot(
data = adsl3,
aes(x = TRT01P, y = TRTDURD, fill = TRT01P)
) +
geom_boxplot() +
scale_x_discrete(name = "Treatment Group") +
scale_y_continuous(
limits = c(0, 250),
breaks = seq(0, 250, 50),
expand = c(0.05, 0.05),
name = "Treatment Duration (Days)"
) +
scale_fill_manual(
values = tf_colors,
name = "Treatment Group"
) +
theme_bw() +
theme(legend.position = "top")
ggplotly(f1) %>%
layout(
legend = list(
orientation = "h",
x = 0.5,
xanchor = "center",
y = 1.02,
yanchor = "bottom"
),
margin = list(t = 45)
)
})
output$height_weight_plot <- renderPlotly({
f2 <- ggplot(
data = adsl3,
aes(
x = HEIGHTBL,
y = WEIGHTBL,
shape = TRT01P,
colour = TRT01P
)
) +
geom_point() +
scale_x_continuous(
limits = c(0, 150),
breaks = seq(0, 150, 10),
name = "Baseline Height (cm)"
) +
scale_y_continuous(
limits = c(0, 150),
breaks = seq(0, 150, 10),
name = "Baseline Weight (kg)"
) +
scale_shape_manual(
values = c(16, 17, 15),
name = "Treatment Group"
) +
scale_colour_manual(
values = tf_colors,
name = "Treatment Group"
) +
theme_bw() +
theme(legend.position = "top")
ggplotly(f2) %>%
layout(
legend = list(
orientation = "h",
x = 0.5,
xanchor = "center",
y = 1.02,
yanchor = "bottom"
),
margin = list(t = 45)
)
})
output$subject_table <- renderDT({
my_table_2 <- adsl3 %>%
rename(
"Unique Subject Identifier" = USUBJID,
"Treatment Group" = TRT01P,
"Total Treatment Duration (Days)" = TRTDURD,
"Baseline Weight (kg)" = WEIGHTBL,
"Baseline Height (cm)" = HEIGHTBL
)
datatable(
my_table_2,
extensions = c("ColReorder"),
rownames = FALSE,
filter = "top",
class = "stripe hover compact",
fillContainer = FALSE,
autoHideNavigation = FALSE,
options = list(
colReorder = TRUE,
bPaginate = TRUE,
paging = TRUE,
lengthChange = TRUE,
searching = TRUE,
info = TRUE,
pageLength = 5,
lengthMenu = c(5, 10, 12, 20, 50, 100),
dom = '<"top"lf>rt<"bottom"ip>',
language = list(
info = "Showing _START_ to _END_ of _TOTAL_ entries"
)
)
)
})
}
# ---- Run app ----
shinyApp(ui = ui, server = server)Shiny App 2: Sidebar Filters
# app.R
# ---- Robust package setup ----
options(repos = c(CRAN = "https://packagemanager.posit.co/cran/latest"))
required_packages <- c(
"shiny",
"bslib",
"dplyr",
"ggplot2",
"plotly",
"DT",
"htmlwidgets",
"pharmaverseadamjnj"
)
installed_packages <- rownames(installed.packages())
missing_packages <- setdiff(required_packages, installed_packages)
if (length(missing_packages) > 0) {
install.packages(
missing_packages,
type = "binary",
dependencies = TRUE
)
}
# ---- Load packages only after all checks/installations are complete ----
library(shiny)
library(bslib)
library(dplyr)
library(ggplot2)
library(plotly)
library(DT)
library(htmlwidgets)
library(pharmaverseadamjnj)
# ---- Data preparation ----
adsl <- pharmaverseadamjnj::adsl
adsl2 <- adsl %>%
select(USUBJID, TRT01P, TRTDURD, WEIGHTBL, HEIGHTBL) %>%
filter(
!is.na(TRT01P),
!is.na(TRTDURD),
!is.na(WEIGHTBL),
!is.na(HEIGHTBL)
)
adsl3 <- adsl2 %>%
mutate_if(is.character, as.factor)
tf_colors <- c(
"Placebo" = "#0072B2",
"Xanomeline High Dose" = "#D55E00",
"Xanomeline Low Dose" = "#CC79A7"
)
duration_range <- range(adsl3$TRTDURD, na.rm = TRUE)
weight_range <- range(adsl3$WEIGHTBL, na.rm = TRUE)
height_range <- range(adsl3$HEIGHTBL, na.rm = TRUE)
# ---- UI ----
ui <- fluidPage(
theme = bs_theme(bootswatch = "cosmo"),
titlePanel("Quarto Dashboard"),
sidebarLayout(
sidebarPanel(
selectInput(
inputId = "treatment_filter",
label = "Treatment Group",
choices = levels(adsl3$TRT01P),
selected = levels(adsl3$TRT01P),
multiple = TRUE
),
selectInput(
inputId = "subject_filter",
label = "Subject",
choices = levels(adsl3$USUBJID),
selected = levels(adsl3$USUBJID),
multiple = TRUE
),
sliderInput(
inputId = "duration_filter",
label = "Total Treatment Duration (Days)",
min = floor(duration_range[1]),
max = ceiling(duration_range[2]),
value = c(floor(duration_range[1]), ceiling(duration_range[2])),
step = 1
),
sliderInput(
inputId = "weight_filter",
label = "Baseline Weight (kg)",
min = floor(weight_range[1]),
max = ceiling(weight_range[2]),
value = c(floor(weight_range[1]), ceiling(weight_range[2])),
step = 1
),
sliderInput(
inputId = "height_filter",
label = "Baseline Height (cm)",
min = floor(height_range[1]),
max = ceiling(height_range[2]),
value = c(floor(height_range[1]), ceiling(height_range[2])),
step = 1
)
),
mainPanel(
fluidRow(
column(
width = 6,
h4("Treatment Duration (Days) by Treatment Group"),
plotlyOutput("duration_plot", height = "420px")
),
column(
width = 6,
h4("Baseline Weight (kg) vs Baseline Height (cm)"),
plotlyOutput("height_weight_plot", height = "420px")
)
),
fluidRow(
column(
width = 12,
h4("Subject-Level Data"),
DTOutput("subject_table")
)
)
)
)
)
# ---- Server ----
server <- function(input, output, session) {
filtered_data <- reactive({
adsl3 %>%
filter(
TRT01P %in% input$treatment_filter,
USUBJID %in% input$subject_filter,
TRTDURD >= input$duration_filter[1],
TRTDURD <= input$duration_filter[2],
WEIGHTBL >= input$weight_filter[1],
WEIGHTBL <= input$weight_filter[2],
HEIGHTBL >= input$height_filter[1],
HEIGHTBL <= input$height_filter[2]
)
})
output$duration_plot <- renderPlotly({
f1 <- ggplot(
data = filtered_data(),
aes(x = TRT01P, y = TRTDURD, fill = TRT01P)
) +
geom_boxplot() +
scale_x_discrete(name = "Treatment Group") +
scale_y_continuous(
limits = c(0, 250),
breaks = seq(0, 250, 50),
expand = c(0.05, 0.05),
name = "Treatment Duration (Days)"
) +
scale_fill_manual(
values = tf_colors,
name = "Treatment Group"
) +
theme_bw() +
theme(legend.position = "top")
ggplotly(f1) %>%
layout(
legend = list(
orientation = "h",
x = 0.5,
xanchor = "center",
y = 1.02,
yanchor = "bottom"
),
margin = list(t = 45)
)
})
output$height_weight_plot <- renderPlotly({
f2 <- ggplot(
data = filtered_data(),
aes(
x = HEIGHTBL,
y = WEIGHTBL,
shape = TRT01P,
colour = TRT01P
)
) +
geom_point() +
scale_x_continuous(
limits = c(0, 150),
breaks = seq(0, 150, 10),
name = "Baseline Height (cm)"
) +
scale_y_continuous(
limits = c(0, 150),
breaks = seq(0, 150, 10),
name = "Baseline Weight (kg)"
) +
scale_shape_manual(
values = c(16, 17, 15),
name = "Treatment Group"
) +
scale_colour_manual(
values = tf_colors,
name = "Treatment Group"
) +
theme_bw() +
theme(legend.position = "top")
ggplotly(f2) %>%
layout(
legend = list(
orientation = "h",
x = 0.5,
xanchor = "center",
y = 1.02,
yanchor = "bottom"
),
margin = list(t = 45)
)
})
output$subject_table <- renderDT({
my_table_2 <- filtered_data() %>%
rename(
"Unique Subject Identifier" = USUBJID,
"Treatment Group" = TRT01P,
"Total Treatment Duration (Days)" = TRTDURD,
"Baseline Weight (kg)" = WEIGHTBL,
"Baseline Height (cm)" = HEIGHTBL
)
datatable(
my_table_2,
extensions = c("ColReorder"),
rownames = FALSE,
filter = "top",
class = "stripe hover compact",
fillContainer = FALSE,
autoHideNavigation = FALSE,
options = list(
colReorder = TRUE,
bPaginate = TRUE,
paging = TRUE,
lengthChange = TRUE,
searching = TRUE,
info = TRUE,
pageLength = 5,
lengthMenu = c(5, 10, 12, 20, 50, 100),
dom = '<"top"lf>rt<"bottom"ip>',
language = list(
info = "Showing _START_ to _END_ of _TOTAL_ entries"
)
)
)
})
}
# ---- Run app ----
shinyApp(ui = ui, server = server)Shiny App 3: Improved Filters And Downloads
# app.R
# ---- Robust package setup ----
options(repos = c(CRAN = "https://packagemanager.posit.co/cran/latest"))
required_packages <- c(
"shiny",
"bslib",
"shinyWidgets",
"dplyr",
"ggplot2",
"plotly",
"DT",
"htmlwidgets",
"pharmaverseadamjnj"
)
installed_packages <- rownames(installed.packages())
missing_packages <- setdiff(required_packages, installed_packages)
if (length(missing_packages) > 0) {
install.packages(
missing_packages,
type = "binary",
dependencies = TRUE
)
}
# ---- Load packages only after all checks/installations are complete ----
library(shiny)
library(bslib)
library(shinyWidgets)
library(dplyr)
library(ggplot2)
library(plotly)
library(DT)
library(htmlwidgets)
library(pharmaverseadamjnj)
# ---- Data preparation ----
adsl <- pharmaverseadamjnj::adsl
adsl2 <- adsl %>%
select(USUBJID, TRT01P, TRTDURD, WEIGHTBL, HEIGHTBL) %>%
filter(
!is.na(TRT01P),
!is.na(TRTDURD),
!is.na(WEIGHTBL),
!is.na(HEIGHTBL)
)
adsl3 <- adsl2 %>%
mutate_if(is.character, as.factor)
tf_colors <- c(
"Placebo" = "#0072B2",
"Xanomeline High Dose" = "#D55E00",
"Xanomeline Low Dose" = "#CC79A7"
)
duration_range <- range(adsl3$TRTDURD, na.rm = TRUE)
weight_range <- range(adsl3$WEIGHTBL, na.rm = TRUE)
height_range <- range(adsl3$HEIGHTBL, na.rm = TRUE)
# ---- Reusable plot functions ----
make_duration_plot <- function(data) {
ggplot(
data = data,
aes(x = TRT01P, y = TRTDURD, fill = TRT01P)
) +
geom_boxplot() +
scale_x_discrete(name = "Treatment Group") +
scale_y_continuous(
limits = c(0, 250),
breaks = seq(0, 250, 50),
expand = c(0.05, 0.05),
name = "Treatment Duration (Days)"
) +
scale_fill_manual(
values = tf_colors,
name = "Treatment Group"
) +
theme_bw() +
theme(legend.position = "top")
}
make_height_weight_plot <- function(data) {
ggplot(
data = data,
aes(
x = HEIGHTBL,
y = WEIGHTBL,
shape = TRT01P,
colour = TRT01P
)
) +
geom_point() +
scale_x_continuous(
limits = c(0, 150),
breaks = seq(0, 150, 10),
name = "Baseline Height (cm)"
) +
scale_y_continuous(
limits = c(0, 150),
breaks = seq(0, 150, 10),
name = "Baseline Weight (kg)"
) +
scale_shape_manual(
values = c(16, 17, 15),
name = "Treatment Group"
) +
scale_colour_manual(
values = tf_colors,
name = "Treatment Group"
) +
theme_bw() +
theme(legend.position = "top")
}
make_subject_table <- function(data) {
data %>%
rename(
"Unique Subject Identifier" = USUBJID,
"Treatment Group" = TRT01P,
"Total Treatment Duration (Days)" = TRTDURD,
"Baseline Weight (kg)" = WEIGHTBL,
"Baseline Height (cm)" = HEIGHTBL
)
}
# ---- UI ----
ui <- fluidPage(
theme = bs_theme(bootswatch = "cosmo"),
titlePanel("Quarto Dashboard"),
sidebarLayout(
sidebarPanel(
pickerInput(
inputId = "treatment_filter",
label = "Treatment Group",
choices = levels(adsl3$TRT01P),
selected = levels(adsl3$TRT01P),
multiple = TRUE,
options = pickerOptions(
actionsBox = TRUE,
liveSearch = TRUE,
selectedTextFormat = "values",
noneSelectedText = "No treatment groups selected",
selectAllText = "Select All",
deselectAllText = "Deselect All",
iconBase = "glyphicon",
tickIcon = "glyphicon-ok"
)
),
pickerInput(
inputId = "subject_filter",
label = "Subject",
choices = levels(adsl3$USUBJID),
selected = levels(adsl3$USUBJID),
multiple = TRUE,
options = pickerOptions(
actionsBox = TRUE,
liveSearch = TRUE,
selectedTextFormat = "values",
noneSelectedText = "No subjects selected",
selectAllText = "Select All",
deselectAllText = "Deselect All",
iconBase = "glyphicon",
tickIcon = "glyphicon-ok"
)
),
sliderInput(
inputId = "duration_filter",
label = "Total Treatment Duration (Days)",
min = floor(duration_range[1]),
max = ceiling(duration_range[2]),
value = c(floor(duration_range[1]), ceiling(duration_range[2])),
step = 1
),
sliderInput(
inputId = "weight_filter",
label = "Baseline Weight (kg)",
min = floor(weight_range[1]),
max = ceiling(weight_range[2]),
value = c(floor(weight_range[1]), ceiling(weight_range[2])),
step = 1
),
sliderInput(
inputId = "height_filter",
label = "Baseline Height (cm)",
min = floor(height_range[1]),
max = ceiling(height_range[2]),
value = c(floor(height_range[1]), ceiling(height_range[2])),
step = 1
),
hr(),
downloadButton(
outputId = "download_duration_plot",
label = "Download Treatment Duration Plot"
),
br(),
br(),
downloadButton(
outputId = "download_height_weight_plot",
label = "Download Height vs Weight Plot"
),
br(),
br(),
downloadButton(
outputId = "download_subject_table",
label = "Download Filtered Table CSV"
)
),
mainPanel(
fluidRow(
column(
width = 6,
h4("Treatment Duration (Days) by Treatment Group"),
plotlyOutput("duration_plot", height = "420px")
),
column(
width = 6,
h4("Baseline Weight (kg) vs Baseline Height (cm)"),
plotlyOutput("height_weight_plot", height = "420px")
)
),
fluidRow(
column(
width = 12,
h4("Subject-Level Data"),
DTOutput("subject_table")
)
)
)
)
)
# ---- Server ----
server <- function(input, output, session) {
filtered_data <- reactive({
req(input$treatment_filter)
req(input$subject_filter)
adsl3 %>%
filter(
TRT01P %in% input$treatment_filter,
USUBJID %in% input$subject_filter,
TRTDURD >= input$duration_filter[1],
TRTDURD <= input$duration_filter[2],
WEIGHTBL >= input$weight_filter[1],
WEIGHTBL <= input$weight_filter[2],
HEIGHTBL >= input$height_filter[1],
HEIGHTBL <= input$height_filter[2]
)
})
output$duration_plot <- renderPlotly({
f1 <- make_duration_plot(filtered_data())
ggplotly(f1) %>%
layout(
legend = list(
orientation = "h",
x = 0.5,
xanchor = "center",
y = 1.02,
yanchor = "bottom"
),
margin = list(t = 45)
)
})
output$height_weight_plot <- renderPlotly({
f2 <- make_height_weight_plot(filtered_data())
ggplotly(f2) %>%
layout(
legend = list(
orientation = "h",
x = 0.5,
xanchor = "center",
y = 1.02,
yanchor = "bottom"
),
margin = list(t = 45)
)
})
output$subject_table <- renderDT({
datatable(
make_subject_table(filtered_data()),
extensions = c("ColReorder"),
rownames = FALSE,
filter = "top",
class = "stripe hover compact",
fillContainer = FALSE,
autoHideNavigation = FALSE,
options = list(
colReorder = TRUE,
bPaginate = TRUE,
paging = TRUE,
lengthChange = TRUE,
searching = TRUE,
info = TRUE,
pageLength = 5,
lengthMenu = c(5, 10, 12, 20, 50, 100),
dom = '<"top"lf>rt<"bottom"ip>',
language = list(
info = "Showing _START_ to _END_ of _TOTAL_ entries"
)
)
)
})
output$download_duration_plot <- downloadHandler(
filename = function() {
paste0("treatment_duration_plot_", Sys.Date(), ".png")
},
content = function(file) {
ggsave(
filename = file,
plot = make_duration_plot(filtered_data()),
device = "png",
width = 8,
height = 6,
dpi = 300
)
}
)
output$download_height_weight_plot <- downloadHandler(
filename = function() {
paste0("height_weight_plot_", Sys.Date(), ".png")
},
content = function(file) {
ggsave(
filename = file,
plot = make_height_weight_plot(filtered_data()),
device = "png",
width = 8,
height = 6,
dpi = 300
)
}
)
output$download_subject_table <- downloadHandler(
filename = function() {
paste0("filtered_subject_level_data_", Sys.Date(), ".csv")
},
content = function(file) {
write.csv(
make_subject_table(filtered_data()),
file,
row.names = FALSE
)
}
)
}
# ---- Run app ----
shinyApp(ui = ui, server = server)Shiny App 4: Polished App
# app.R
# ---- Robust package setup ----
options(repos = c(CRAN = "https://packagemanager.posit.co/cran/latest"))
required_packages <- c(
"shiny",
"bslib",
"shinyWidgets",
"dplyr",
"ggplot2",
"plotly",
"DT",
"htmlwidgets",
"pharmaverseadamjnj"
)
installed_packages <- rownames(installed.packages())
missing_packages <- setdiff(required_packages, installed_packages)
if (length(missing_packages) > 0) {
install.packages(
missing_packages,
type = "binary",
dependencies = TRUE
)
}
# ---- Load packages only after all checks/installations are complete ----
library(shiny)
library(bslib)
library(shinyWidgets)
library(dplyr)
library(ggplot2)
library(plotly)
library(DT)
library(htmlwidgets)
library(pharmaverseadamjnj)
# ---- Data preparation ----
adsl <- pharmaverseadamjnj::adsl
adsl2 <- adsl %>%
select(USUBJID, TRT01P, TRTDURD, WEIGHTBL, HEIGHTBL) %>%
filter(
!is.na(TRT01P),
!is.na(TRTDURD),
!is.na(WEIGHTBL),
!is.na(HEIGHTBL)
)
adsl3 <- adsl2 %>%
mutate_if(is.character, as.factor)
tf_colors <- c(
"Placebo" = "#0072B2",
"Xanomeline High Dose" = "#D55E00",
"Xanomeline Low Dose" = "#CC79A7"
)
duration_range <- range(adsl3$TRTDURD, na.rm = TRUE)
weight_range <- range(adsl3$WEIGHTBL, na.rm = TRUE)
height_range <- range(adsl3$HEIGHTBL, na.rm = TRUE)
# ---- Reusable plot functions ----
make_duration_plot <- function(data) {
ggplot(
data = data,
aes(x = TRT01P, y = TRTDURD, fill = TRT01P)
) +
geom_boxplot() +
scale_x_discrete(name = "Treatment Group") +
scale_y_continuous(
limits = c(0, 250),
breaks = seq(0, 250, 50),
expand = c(0.05, 0.05),
name = "Treatment Duration (Days)"
) +
scale_fill_manual(
values = tf_colors,
name = "Treatment Group"
) +
theme_bw() +
theme(
legend.position = "top",
plot.title = element_text(face = "bold"),
axis.title = element_text(face = "bold")
)
}
make_height_weight_plot <- function(data) {
ggplot(
data = data,
aes(
x = HEIGHTBL,
y = WEIGHTBL,
shape = TRT01P,
colour = TRT01P
)
) +
geom_point(size = 2.3, alpha = 0.85) +
scale_x_continuous(
limits = c(0, 150),
breaks = seq(0, 150, 10),
name = "Baseline Height (cm)"
) +
scale_y_continuous(
limits = c(0, 150),
breaks = seq(0, 150, 10),
name = "Baseline Weight (kg)"
) +
scale_shape_manual(
values = c(16, 17, 15),
name = "Treatment Group"
) +
scale_colour_manual(
values = tf_colors,
name = "Treatment Group"
) +
theme_bw() +
theme(
legend.position = "top",
plot.title = element_text(face = "bold"),
axis.title = element_text(face = "bold")
)
}
make_subject_table <- function(data) {
data %>%
rename(
"Unique Subject Identifier" = USUBJID,
"Treatment Group" = TRT01P,
"Total Treatment Duration (Days)" = TRTDURD,
"Baseline Weight (kg)" = WEIGHTBL,
"Baseline Height (cm)" = HEIGHTBL
)
}
# ---- UI ----
ui <- page_sidebar(
title = "Clinical Subject-Level Explorer",
theme = bs_theme(
bootswatch = "cosmo",
base_font = font_google("Source Sans 3"),
heading_font = font_google("Source Sans 3")
),
sidebar = sidebar(
title = "Dashboard Controls",
width = 340,
div(
class = "text-muted",
"Filter the subject-level dataset and download the current filtered outputs."
),
hr(),
h5("Subject Selection"),
pickerInput(
inputId = "treatment_filter",
label = "Treatment Group",
choices = levels(adsl3$TRT01P),
selected = levels(adsl3$TRT01P),
multiple = TRUE,
options = pickerOptions(
actionsBox = TRUE,
liveSearch = TRUE,
selectedTextFormat = "values",
noneSelectedText = "No treatment groups selected",
selectAllText = "Select All",
deselectAllText = "Deselect All",
iconBase = "glyphicon",
tickIcon = "glyphicon-ok"
)
),
pickerInput(
inputId = "subject_filter",
label = "Subject",
choices = levels(adsl3$USUBJID),
selected = levels(adsl3$USUBJID),
multiple = TRUE,
options = pickerOptions(
actionsBox = TRUE,
liveSearch = TRUE,
selectedTextFormat = "values",
noneSelectedText = "No subjects selected",
selectAllText = "Select All",
deselectAllText = "Deselect All",
iconBase = "glyphicon",
tickIcon = "glyphicon-ok"
)
),
hr(),
h5("Clinical Measures"),
sliderInput(
inputId = "duration_filter",
label = "Total Treatment Duration (Days)",
min = floor(duration_range[1]),
max = ceiling(duration_range[2]),
value = c(floor(duration_range[1]), ceiling(duration_range[2])),
step = 1
),
sliderInput(
inputId = "weight_filter",
label = "Baseline Weight (kg)",
min = floor(weight_range[1]),
max = ceiling(weight_range[2]),
value = c(floor(weight_range[1]), ceiling(weight_range[2])),
step = 1
),
sliderInput(
inputId = "height_filter",
label = "Baseline Height (cm)",
min = floor(height_range[1]),
max = ceiling(height_range[2]),
value = c(floor(height_range[1]), ceiling(height_range[2])),
step = 1
),
hr(),
h5("Downloads"),
downloadButton(
outputId = "download_duration_plot",
label = "Treatment Duration PNG",
class = "btn-primary btn-sm w-100"
),
br(),
br(),
downloadButton(
outputId = "download_height_weight_plot",
label = "Height vs Weight PNG",
class = "btn-primary btn-sm w-100"
),
br(),
br(),
downloadButton(
outputId = "download_subject_table",
label = "Filtered Table CSV",
class = "btn-secondary btn-sm w-100"
)
),
div(
class = "mb-4",
h2("Clinical Subject-Level Explorer"),
p(
class = "text-muted",
"Interactive review of treatment duration and baseline subject characteristics by treatment group."
)
),
layout_columns(
col_widths = c(6, 6),
card(
full_screen = TRUE,
card_header("Treatment Duration by Treatment Group"),
plotlyOutput("duration_plot", height = "420px")
),
card(
full_screen = TRUE,
card_header("Baseline Weight vs Baseline Height"),
plotlyOutput("height_weight_plot", height = "420px")
)
),
br(),
card(
full_screen = TRUE,
card_header("Filtered Subject-Level Data"),
DTOutput("subject_table")
)
)
# ---- Server ----
server <- function(input, output, session) {
filtered_data <- reactive({
req(input$treatment_filter)
req(input$subject_filter)
adsl3 %>%
filter(
TRT01P %in% input$treatment_filter,
USUBJID %in% input$subject_filter,
TRTDURD >= input$duration_filter[1],
TRTDURD <= input$duration_filter[2],
WEIGHTBL >= input$weight_filter[1],
WEIGHTBL <= input$weight_filter[2],
HEIGHTBL >= input$height_filter[1],
HEIGHTBL <= input$height_filter[2]
)
})
output$duration_plot <- renderPlotly({
f1 <- make_duration_plot(filtered_data())
ggplotly(f1) %>%
layout(
legend = list(
orientation = "h",
x = 0.5,
xanchor = "center",
y = 1.02,
yanchor = "bottom"
),
margin = list(t = 45)
)
})
output$height_weight_plot <- renderPlotly({
f2 <- make_height_weight_plot(filtered_data())
ggplotly(f2) %>%
layout(
legend = list(
orientation = "h",
x = 0.5,
xanchor = "center",
y = 1.02,
yanchor = "bottom"
),
margin = list(t = 45)
)
})
output$subject_table <- renderDT({
datatable(
make_subject_table(filtered_data()),
extensions = c("ColReorder"),
rownames = FALSE,
filter = "top",
class = "stripe hover compact",
fillContainer = FALSE,
autoHideNavigation = FALSE,
options = list(
colReorder = TRUE,
bPaginate = TRUE,
paging = TRUE,
lengthChange = TRUE,
searching = TRUE,
info = TRUE,
pageLength = 5,
lengthMenu = c(5, 10, 12, 20, 50, 100),
dom = '<"top"lf>rt<"bottom"ip>',
language = list(
info = "Showing _START_ to _END_ of _TOTAL_ entries"
)
)
)
})
output$download_duration_plot <- downloadHandler(
filename = function() {
paste0("treatment_duration_plot_", Sys.Date(), ".png")
},
content = function(file) {
ggsave(
filename = file,
plot = make_duration_plot(filtered_data()),
device = "png",
width = 8,
height = 6,
dpi = 300
)
}
)
output$download_height_weight_plot <- downloadHandler(
filename = function() {
paste0("height_weight_plot_", Sys.Date(), ".png")
},
content = function(file) {
ggsave(
filename = file,
plot = make_height_weight_plot(filtered_data()),
device = "png",
width = 8,
height = 6,
dpi = 300
)
}
)
output$download_subject_table <- downloadHandler(
filename = function() {
paste0("filtered_subject_level_data_", Sys.Date(), ".csv")
},
content = function(file) {
write.csv(
make_subject_table(filtered_data()),
file,
row.names = FALSE
)
}
)
}
# ---- Run app ----
shinyApp(ui = ui, server = server)Shiny Assistant 1: Survival Dashboard
# app.R
# ---- Robust package setup ----
options(repos = c(CRAN = "https://packagemanager.posit.co/cran/latest"))
required_packages <- c(
"shiny",
"bslib",
"survival",
"ggplot2",
"dplyr",
"scales"
)
installed_packages <- rownames(installed.packages())
missing_packages <- setdiff(required_packages, installed_packages)
if (length(missing_packages) > 0) {
install.packages(
missing_packages,
type = "binary",
dependencies = TRUE
)
}
library(shiny)
library(bslib)
library(survival)
library(ggplot2)
library(dplyr)
library(scales)
generate_survival_data <- function(n = 400, censor_rate = 0.3) {
set.seed(789)
data.frame(
id = seq_len(n),
treatment = sample(c("Treatment A", "Treatment B"), n, replace = TRUE),
subgroup = sample(c("Subgroup 1", "Subgroup 2", "Subgroup 3"), n, replace = TRUE),
age = round(rnorm(n, 60, 10)),
sex = sample(c("Female", "Male"), n, replace = TRUE)
) |>
mutate(
# Adjusted rates to have more gradual decline and more events early
# Treatment B has better survival (lower rate), Treatment A worse (higher rate)
event_time = rweibull(
n,
shape = 1.2, # Shape > 1 means more events early
scale = ifelse(treatment == "Treatment B", 50, 40)
),
censored = rbinom(n, 1, censor_rate),
censor_time = ifelse(
censored == 1,
runif(n, 0.2, 0.95) * event_time,
180
),
time = pmin(event_time, censor_time, 150),
time = round(time, 1),
event = as.integer(event_time <= censor_time & event_time <= 150)
) |>
select(id, treatment, subgroup, age, sex, time, event)
}
km_plot <- function(data) {
fit <- survfit(Surv(time, event) ~ treatment, data = data)
strata <- if (is.null(fit$strata)) {
rep(unique(data$treatment)[1], length(fit$time))
} else {
sub("treatment=", "", rep(names(fit$strata), fit$strata))
}
km_data <- data.frame(
time = fit$time,
survival = fit$surv,
upper = fit$upper,
lower = fit$lower,
strata = strata
)
p_value <- if (length(unique(data$treatment)) < 2) {
NA_real_
} else {
test <- survdiff(Surv(time, event) ~ treatment, data = data)
pchisq(test$chisq, length(test$n) - 1, lower.tail = FALSE)
}
ggplot(km_data, aes(x = time, colour = strata, fill = strata)) +
geom_ribbon(aes(ymin = lower, ymax = upper), alpha = 0.2, colour = NA) +
geom_step(aes(y = survival), linewidth = 1) +
scale_colour_manual(
values = c("Treatment A" = "#56B4E9", "Treatment B" = "#F0C419"),
drop = FALSE
) +
scale_fill_manual(
values = c("Treatment A" = "#56B4E9", "Treatment B" = "#F0C419"),
drop = FALSE
) +
scale_x_continuous(breaks = seq(0, 150, 50), limits = c(0, 150)) +
scale_y_continuous(limits = c(0, 1), labels = number_format(accuracy = 0.01)) +
labs(
x = "Time (months)",
y = "Survival Probability",
colour = "Treatment",
fill = "Treatment"
) +
annotate(
"text",
x = 5,
y = 0.18,
hjust = 0,
label = ifelse(is.na(p_value), "", paste0("p = ", signif(p_value, 3)))
) +
theme_minimal(base_size = 13) +
theme(legend.position = "top")
}
risk_table_plot <- function(data) {
fit <- survfit(Surv(time, event) ~ treatment, data = data)
times <- seq(0, 150, 50)
risk <- summary(fit, times = times, extend = TRUE)
treatment <- if (is.null(risk$strata)) {
rep(unique(data$treatment)[1], length(risk$time))
} else {
sub("treatment=", "", risk$strata)
}
risk_data <- data.frame(
treatment = treatment,
time = risk$time,
n_risk = risk$n.risk
) |>
mutate(treatment = factor(treatment, levels = c("Treatment B", "Treatment A")))
label_data <- risk_data |> distinct(treatment)
ggplot(risk_data, aes(time, treatment, label = n_risk)) +
geom_text(size = 4, colour = "black") +
geom_text(
data = label_data,
aes(x = -8, y = treatment, label = treatment, colour = treatment),
inherit.aes = FALSE,
hjust = 1,
size = 3.2
) +
scale_colour_manual(
values = c("Treatment A" = "#56B4E9", "Treatment B" = "#F0C419"),
drop = FALSE
) +
scale_y_discrete(drop = TRUE) +
scale_x_continuous(breaks = times, limits = c(-15, 150)) +
coord_cartesian(clip = "off") +
labs(x = "Time", y = NULL, title = "Number at risk") +
theme_minimal(base_size = 12) +
theme(
legend.position = "none",
axis.text.y = element_blank(),
axis.ticks.y = element_blank(),
plot.margin = margin(5.5, 5.5, 5.5, 70)
)
}
hazard_ratio_summary <- function(data) {
if (length(unique(data$treatment)) < 2) {
return(tags$p("Select both treatment groups to estimate a hazard ratio.", style = "font-size: 0.9rem;"))
}
model <- coxph(Surv(time, event) ~ treatment, data = data)
estimate <- summary(model)
hr <- estimate$conf.int[1, "exp(coef)"]
lower <- estimate$conf.int[1, "lower .95"]
upper <- estimate$conf.int[1, "upper .95"]
p_value <- estimate$coefficients[1, "Pr(>|z|)"]
tagList(
h2(paste0("HR: ", round(hr, 2)), class = "text-center", style = "margin-bottom: 0.05rem; color: #56B4E9;"),
p(paste0("95% CI: [", round(lower, 2), ", ", round(upper, 2), "]"), class = "text-center", style = "font-size: 0.9rem; margin-bottom: 0.05rem;"),
p(paste0("P-value: ", signif(p_value, 3)), class = "text-center", style = "font-size: 0.9rem; margin-bottom: 0.05rem;"),
hr(style = "margin-top: 0.05rem; margin-bottom: 0.05rem;"),
p(paste0("Total subjects: ", nrow(data)), class = "text-center text-muted", style = "font-size: 0.85rem; margin-bottom: 0.02rem;"),
p(
paste0("Events: ", sum(data$event), " (", round(mean(data$event) * 100, 1), "%)"),
class = "text-center text-muted",
style = "font-size: 0.85rem; margin-bottom: 0;"
)
)
}
ui <- page_sidebar(
title = "Clinical Trial Survival Analysis Dashboard",
sidebar = sidebar(
width = 300,
selectInput(
"treatment",
"Treatment Group:",
choices = c("All", "Treatment A", "Treatment B")
),
selectInput(
"subgroup",
"Subgroup:",
choices = c("All", "Subgroup 1", "Subgroup 2", "Subgroup 3")
),
sliderInput(
"censor_rate",
"Censoring Rate:",
min = 0,
max = 0.5,
value = 0.3,
step = 0.05
),
downloadButton("download_data", "Download Dataset", class = "btn-primary")
),
card(
card_header("Kaplan-Meier Survival Curve"),
plotOutput("km_plot", height = "420px")
),
layout_columns(
col_widths = c(6, 6),
card(
card_header("Number at Risk Table"),
plotOutput("risk_table", height = "260px")
),
card(
card_header("Hazard Ratio Summary"),
uiOutput("hr_summary")
)
)
)
server <- function(input, output, session) {
survival_data <- reactive({
generate_survival_data(censor_rate = input$censor_rate)
})
filtered_data <- reactive({
data <- survival_data()
if (input$treatment != "All") {
data <- data |> filter(treatment == input$treatment)
}
if (input$subgroup != "All") {
data <- data |> filter(subgroup == input$subgroup)
}
data
})
output$km_plot <- renderPlot({
km_plot(filtered_data())
})
output$risk_table <- renderPlot({
risk_table_plot(filtered_data())
})
output$hr_summary <- renderUI({
hazard_ratio_summary(filtered_data())
})
output$download_data <- downloadHandler(
filename = function() {
paste0("survival_data_", Sys.Date(), ".csv")
},
content = function(file) {
write.csv(filtered_data(), file, row.names = FALSE)
}
)
}
shinyApp(ui, server)Shiny Assistant 2: Dataset Tab
# app.R
# ---- Robust package setup ----
options(repos = c(CRAN = "https://packagemanager.posit.co/cran/latest"))
required_packages <- c(
"shiny",
"bslib",
"survival",
"ggplot2",
"dplyr",
"DT",
"scales"
)
installed_packages <- rownames(installed.packages())
missing_packages <- setdiff(required_packages, installed_packages)
if (length(missing_packages) > 0) {
install.packages(
missing_packages,
type = "binary",
dependencies = TRUE
)
}
library(shiny)
library(bslib)
library(survival)
library(ggplot2)
library(dplyr)
library(DT)
library(scales)
generate_survival_data <- function(n = 400, censor_rate = 0.3) {
set.seed(789)
data.frame(
id = seq_len(n),
treatment = sample(c("Treatment A", "Treatment B"), n, replace = TRUE),
subgroup = sample(c("Subgroup 1", "Subgroup 2", "Subgroup 3"), n, replace = TRUE),
age = round(rnorm(n, 60, 10)),
sex = sample(c("Female", "Male"), n, replace = TRUE)
) |>
mutate(
# Adjusted rates to have more gradual decline and more events early
# Treatment B has better survival (lower rate), Treatment A worse (higher rate)
event_time = rweibull(
n,
shape = 1.2, # Shape > 1 means more events early
scale = ifelse(treatment == "Treatment B", 50, 40)
),
censored = rbinom(n, 1, censor_rate),
censor_time = ifelse(
censored == 1,
runif(n, 0.2, 0.95) * event_time,
180
),
time = pmin(event_time, censor_time, 150),
time = round(time, 1),
event = as.integer(event_time <= censor_time & event_time <= 150)
) |>
select(id, treatment, subgroup, age, sex, time, event)
}
km_plot <- function(data) {
fit <- survfit(Surv(time, event) ~ treatment, data = data)
strata <- if (is.null(fit$strata)) {
rep(unique(data$treatment)[1], length(fit$time))
} else {
sub("treatment=", "", rep(names(fit$strata), fit$strata))
}
km_data <- data.frame(
time = fit$time,
survival = fit$surv,
upper = fit$upper,
lower = fit$lower,
strata = strata
)
p_value <- if (length(unique(data$treatment)) < 2) {
NA_real_
} else {
test <- survdiff(Surv(time, event) ~ treatment, data = data)
pchisq(test$chisq, length(test$n) - 1, lower.tail = FALSE)
}
ggplot(km_data, aes(x = time, colour = strata, fill = strata)) +
geom_ribbon(aes(ymin = lower, ymax = upper), alpha = 0.2, colour = NA) +
geom_step(aes(y = survival), linewidth = 1) +
scale_colour_manual(
values = c("Treatment A" = "#56B4E9", "Treatment B" = "#F0C419"),
drop = FALSE
) +
scale_fill_manual(
values = c("Treatment A" = "#56B4E9", "Treatment B" = "#F0C419"),
drop = FALSE
) +
scale_x_continuous(breaks = seq(0, 150, 50), limits = c(0, 150)) +
scale_y_continuous(limits = c(0, 1), labels = number_format(accuracy = 0.01)) +
labs(
x = "Time (months)",
y = "Survival Probability",
colour = "Treatment",
fill = "Treatment"
) +
annotate(
"text",
x = 5,
y = 0.18,
hjust = 0,
label = ifelse(is.na(p_value), "", paste0("p = ", signif(p_value, 3)))
) +
theme_minimal(base_size = 13) +
theme(legend.position = "top")
}
risk_table_plot <- function(data) {
fit <- survfit(Surv(time, event) ~ treatment, data = data)
times <- seq(0, 150, 50)
risk <- summary(fit, times = times, extend = TRUE)
treatment <- if (is.null(risk$strata)) {
rep(unique(data$treatment)[1], length(risk$time))
} else {
sub("treatment=", "", risk$strata)
}
risk_data <- data.frame(
treatment = treatment,
time = risk$time,
n_risk = risk$n.risk
) |>
mutate(treatment = factor(treatment, levels = c("Treatment B", "Treatment A")))
label_data <- risk_data |> distinct(treatment)
ggplot(risk_data, aes(time, treatment, label = n_risk)) +
geom_text(size = 4, colour = "black") +
geom_text(
data = label_data,
aes(x = -8, y = treatment, label = treatment, colour = treatment),
inherit.aes = FALSE,
hjust = 1,
size = 3.2
) +
scale_colour_manual(
values = c("Treatment A" = "#56B4E9", "Treatment B" = "#F0C419"),
drop = FALSE
) +
scale_y_discrete(drop = TRUE) +
scale_x_continuous(breaks = times, limits = c(-15, 150)) +
coord_cartesian(clip = "off") +
labs(x = "Time", y = NULL, title = "Number at risk") +
theme_minimal(base_size = 12) +
theme(
legend.position = "none",
axis.text.y = element_blank(),
axis.ticks.y = element_blank(),
plot.margin = margin(5.5, 5.5, 5.5, 70)
)
}
hazard_ratio_summary <- function(data) {
if (length(unique(data$treatment)) < 2) {
return(tags$p("Select both treatment groups to estimate a hazard ratio.", style = "font-size: 0.9rem;"))
}
model <- coxph(Surv(time, event) ~ treatment, data = data)
estimate <- summary(model)
hr <- estimate$conf.int[1, "exp(coef)"]
lower <- estimate$conf.int[1, "lower .95"]
upper <- estimate$conf.int[1, "upper .95"]
p_value <- estimate$coefficients[1, "Pr(>|z|)"]
tagList(
h2(paste0("HR: ", round(hr, 2)), class = "text-center", style = "margin-bottom: 0.05rem; color: #56B4E9;"),
p(paste0("95% CI: [", round(lower, 2), ", ", round(upper, 2), "]"), class = "text-center", style = "font-size: 0.9rem; margin-bottom: 0.05rem;"),
p(paste0("P-value: ", signif(p_value, 3)), class = "text-center", style = "font-size: 0.9rem; margin-bottom: 0.05rem;"),
hr(style = "margin-top: 0.05rem; margin-bottom: 0.05rem;"),
p(paste0("Total subjects: ", nrow(data)), class = "text-center text-muted", style = "font-size: 0.85rem; margin-bottom: 0.02rem;"),
p(
paste0("Events: ", sum(data$event), " (", round(mean(data$event) * 100, 1), "%)"),
class = "text-center text-muted",
style = "font-size: 0.85rem; margin-bottom: 0;"
)
)
}
ui <- page_navbar(
title = "Clinical Trial Survival Analysis Dashboard",
sidebar = sidebar(
width = 300,
selectInput(
"treatment",
"Treatment Group:",
choices = c("All", "Treatment A", "Treatment B")
),
selectInput(
"subgroup",
"Subgroup:",
choices = c("All", "Subgroup 1", "Subgroup 2", "Subgroup 3")
),
sliderInput(
"censor_rate",
"Censoring Rate:",
min = 0,
max = 0.5,
value = 0.3,
step = 0.05
),
downloadButton("download_data", "Download Dataset", class = "btn-primary")
),
nav_panel(
title = "Analysis",
card(
card_header("Kaplan-Meier Survival Curve"),
plotOutput("km_plot", height = "420px")
),
layout_columns(
col_widths = c(6, 6),
card(
card_header("Number at Risk Table"),
plotOutput("risk_table", height = "260px")
),
card(
card_header("Hazard Ratio Summary"),
uiOutput("hr_summary")
)
)
),
nav_panel(
title = "Dataset",
card(
card_header("Survival Data Table"),
DTOutput("data_table")
)
)
)
server <- function(input, output, session) {
survival_data <- reactive({
generate_survival_data(censor_rate = input$censor_rate)
})
filtered_data <- reactive({
data <- survival_data()
if (input$treatment != "All") {
data <- data |> filter(treatment == input$treatment)
}
if (input$subgroup != "All") {
data <- data |> filter(subgroup == input$subgroup)
}
data
})
output$km_plot <- renderPlot({
km_plot(filtered_data())
})
output$risk_table <- renderPlot({
risk_table_plot(filtered_data())
})
output$hr_summary <- renderUI({
hazard_ratio_summary(filtered_data())
})
output$data_table <- renderDT({
datatable(
filtered_data(),
filter = "top",
options = list(
pageLength = 25,
searching = TRUE,
autoWidth = TRUE,
lengthChange = FALSE, # Removes the "Show entries" dropdown
dom = 'frtip' # Customizes table controls (f=filter, r=processing, t=table, i=info, p=pagination)
),
rownames = FALSE
)
})
output$download_data <- downloadHandler(
filename = function() {
paste0("survival_data_", Sys.Date(), ".csv")
},
content = function(file) {
write.csv(filtered_data(), file, row.names = FALSE)
}
)
}
shinyApp(ui, server)Shiny Assistant 3: Zoomable Cards
# app.R
# ---- Robust package setup ----
options(repos = c(CRAN = "https://packagemanager.posit.co/cran/latest"))
required_packages <- c(
"shiny",
"bslib",
"survival",
"ggplot2",
"dplyr",
"DT",
"scales"
)
installed_packages <- rownames(installed.packages())
missing_packages <- setdiff(required_packages, installed_packages)
if (length(missing_packages) > 0) {
install.packages(
missing_packages,
type = "binary",
dependencies = TRUE
)
}
library(shiny)
library(bslib)
library(survival)
library(ggplot2)
library(dplyr)
library(DT)
library(scales)
generate_survival_data <- function(n = 400, censor_rate = 0.3) {
set.seed(789)
data.frame(
id = seq_len(n),
treatment = sample(c("Treatment A", "Treatment B"), n, replace = TRUE),
subgroup = sample(c("Subgroup 1", "Subgroup 2", "Subgroup 3"), n, replace = TRUE),
age = round(rnorm(n, 60, 10)),
sex = sample(c("Female", "Male"), n, replace = TRUE)
) |>
mutate(
# Adjusted rates to have more gradual decline and more events early
# Treatment B has better survival (lower rate), Treatment A worse (higher rate)
event_time = rweibull(
n,
shape = 1.2, # Shape > 1 means more events early
scale = ifelse(treatment == "Treatment B", 50, 40)
),
censored = rbinom(n, 1, censor_rate),
censor_time = ifelse(
censored == 1,
runif(n, 0.2, 0.95) * event_time,
180
),
time = pmin(event_time, censor_time, 150),
time = round(time, 1),
event = as.integer(event_time <= censor_time & event_time <= 150)
) |>
select(id, treatment, subgroup, age, sex, time, event)
}
km_plot <- function(data) {
fit <- survfit(Surv(time, event) ~ treatment, data = data)
strata <- if (is.null(fit$strata)) {
rep(unique(data$treatment)[1], length(fit$time))
} else {
sub("treatment=", "", rep(names(fit$strata), fit$strata))
}
km_data <- data.frame(
time = fit$time,
survival = fit$surv,
upper = fit$upper,
lower = fit$lower,
strata = strata
)
p_value <- if (length(unique(data$treatment)) < 2) {
NA_real_
} else {
test <- survdiff(Surv(time, event) ~ treatment, data = data)
pchisq(test$chisq, length(test$n) - 1, lower.tail = FALSE)
}
ggplot(km_data, aes(x = time, colour = strata, fill = strata)) +
geom_ribbon(aes(ymin = lower, ymax = upper), alpha = 0.2, colour = NA) +
geom_step(aes(y = survival), linewidth = 1) +
scale_colour_manual(
values = c("Treatment A" = "#56B4E9", "Treatment B" = "#F0C419"),
drop = FALSE
) +
scale_fill_manual(
values = c("Treatment A" = "#56B4E9", "Treatment B" = "#F0C419"),
drop = FALSE
) +
scale_x_continuous(breaks = seq(0, 150, 50), limits = c(0, 150)) +
scale_y_continuous(limits = c(0, 1), labels = number_format(accuracy = 0.01)) +
labs(
x = "Time (months)",
y = "Survival Probability",
colour = "Treatment",
fill = "Treatment"
) +
annotate(
"text",
x = 5,
y = 0.18,
hjust = 0,
label = ifelse(is.na(p_value), "", paste0("p = ", signif(p_value, 3)))
) +
theme_minimal(base_size = 13) +
theme(legend.position = "top")
}
risk_table_plot <- function(data) {
fit <- survfit(Surv(time, event) ~ treatment, data = data)
times <- seq(0, 150, 50)
risk <- summary(fit, times = times, extend = TRUE)
treatment <- if (is.null(risk$strata)) {
rep(unique(data$treatment)[1], length(risk$time))
} else {
sub("treatment=", "", risk$strata)
}
risk_data <- data.frame(
treatment = treatment,
time = risk$time,
n_risk = risk$n.risk
) |>
mutate(treatment = factor(treatment, levels = c("Treatment B", "Treatment A")))
label_data <- risk_data |> distinct(treatment)
ggplot(risk_data, aes(time, treatment, label = n_risk)) +
geom_text(size = 4, colour = "black") +
geom_text(
data = label_data,
aes(x = -8, y = treatment, label = treatment, colour = treatment),
inherit.aes = FALSE,
hjust = 1,
size = 3.2
) +
scale_colour_manual(
values = c("Treatment A" = "#56B4E9", "Treatment B" = "#F0C419"),
drop = FALSE
) +
scale_y_discrete(drop = TRUE) +
scale_x_continuous(breaks = times, limits = c(-15, 150)) +
coord_cartesian(clip = "off") +
labs(x = "Time", y = NULL, title = "Number at risk") +
theme_minimal(base_size = 12) +
theme(
legend.position = "none",
axis.text.y = element_blank(),
axis.ticks.y = element_blank(),
plot.margin = margin(5.5, 5.5, 5.5, 70)
)
}
hazard_ratio_summary <- function(data) {
if (length(unique(data$treatment)) < 2) {
return(tags$p("Select both treatment groups to estimate a hazard ratio.", style = "font-size: 0.9rem;"))
}
model <- coxph(Surv(time, event) ~ treatment, data = data)
estimate <- summary(model)
hr <- estimate$conf.int[1, "exp(coef)"]
lower <- estimate$conf.int[1, "lower .95"]
upper <- estimate$conf.int[1, "upper .95"]
p_value <- estimate$coefficients[1, "Pr(>|z|)"]
tagList(
h2(paste0("HR: ", round(hr, 2)), class = "text-center", style = "margin-bottom: 0.05rem; color: #56B4E9;"),
p(paste0("95% CI: [", round(lower, 2), ", ", round(upper, 2), "]"), class = "text-center", style = "font-size: 0.9rem; margin-bottom: 0.05rem;"),
p(paste0("P-value: ", signif(p_value, 3)), class = "text-center", style = "font-size: 0.9rem; margin-bottom: 0.05rem;"),
hr(style = "margin-top: 0.05rem; margin-bottom: 0.05rem;"),
p(paste0("Total subjects: ", nrow(data)), class = "text-center text-muted", style = "font-size: 0.85rem; margin-bottom: 0.02rem;"),
p(
paste0("Events: ", sum(data$event), " (", round(mean(data$event) * 100, 1), "%)"),
class = "text-center text-muted",
style = "font-size: 0.85rem; margin-bottom: 0;"
)
)
}
ui <- page_navbar(
title = "Clinical Trial Survival Analysis Dashboard",
sidebar = sidebar(
width = 300,
selectInput(
"treatment",
"Treatment Group:",
choices = c("All", "Treatment A", "Treatment B")
),
selectInput(
"subgroup",
"Subgroup:",
choices = c("All", "Subgroup 1", "Subgroup 2", "Subgroup 3")
),
sliderInput(
"censor_rate",
"Censoring Rate:",
min = 0,
max = 0.5,
value = 0.3,
step = 0.05
),
downloadButton("download_data", "Download Dataset", class = "btn-primary")
),
nav_panel(
title = "Analysis",
card(
full_screen = TRUE,
card_header("Kaplan-Meier Survival Curve"),
plotOutput("km_plot", height = "420px")
),
layout_columns(
col_widths = c(6, 6),
card(
full_screen = TRUE,
card_header("Number at Risk Table"),
plotOutput("risk_table", height = "260px")
),
card(
full_screen = TRUE,
card_header("Hazard Ratio Summary"),
uiOutput("hr_summary")
)
)
),
nav_panel(
title = "Dataset",
card(
full_screen = TRUE,
card_header("Survival Data Table"),
DTOutput("data_table")
)
)
)
server <- function(input, output, session) {
survival_data <- reactive({
generate_survival_data(censor_rate = input$censor_rate)
})
filtered_data <- reactive({
data <- survival_data()
if (input$treatment != "All") {
data <- data |> filter(treatment == input$treatment)
}
if (input$subgroup != "All") {
data <- data |> filter(subgroup == input$subgroup)
}
data
})
output$km_plot <- renderPlot({
km_plot(filtered_data())
})
output$risk_table <- renderPlot({
risk_table_plot(filtered_data())
})
output$hr_summary <- renderUI({
hazard_ratio_summary(filtered_data())
})
output$data_table <- renderDT({
datatable(
filtered_data(),
filter = "top",
options = list(
pageLength = 25,
searching = TRUE,
autoWidth = TRUE,
lengthChange = FALSE, # Removes the "Show entries" dropdown
dom = 'frtip' # Customizes table controls (f=filter, r=processing, t=table, i=info, p=pagination)
),
rownames = FALSE
)
})
output$download_data <- downloadHandler(
filename = function() {
paste0("survival_data_", Sys.Date(), ".csv")
},
content = function(file) {
write.csv(filtered_data(), file, row.names = FALSE)
}
)
}
shinyApp(ui, server)Shiny Assistant 4: Adjusted Cox Model
# app.R
# ---- Robust package setup ----
options(repos = c(CRAN = "https://packagemanager.posit.co/cran/latest"))
required_packages <- c(
"shiny",
"bslib",
"survival",
"ggplot2",
"dplyr",
"DT",
"scales"
)
installed_packages <- rownames(installed.packages())
missing_packages <- setdiff(required_packages, installed_packages)
if (length(missing_packages) > 0) {
install.packages(
missing_packages,
type = "binary",
dependencies = TRUE
)
}
library(shiny)
library(bslib)
library(survival)
library(ggplot2)
library(dplyr)
library(DT)
library(scales)
generate_survival_data <- function(n = 400, censor_rate = 0.3) {
set.seed(789)
data.frame(
id = seq_len(n),
treatment = sample(c("Treatment A", "Treatment B"), n, replace = TRUE),
subgroup = sample(c("Subgroup 1", "Subgroup 2", "Subgroup 3"), n, replace = TRUE),
age = round(rnorm(n, 60, 10)),
sex = sample(c("Female", "Male"), n, replace = TRUE)
) |>
mutate(
# Adjusted rates to have more gradual decline and more events early
# Treatment B has better survival (lower rate), Treatment A worse (higher rate)
event_time = rweibull(
n,
shape = 1.2, # Shape > 1 means more events early
scale = ifelse(treatment == "Treatment B", 50, 40)
),
censored = rbinom(n, 1, censor_rate),
censor_time = ifelse(
censored == 1,
runif(n, 0.2, 0.95) * event_time,
180
),
time = pmin(event_time, censor_time, 150),
time = round(time, 1),
event = as.integer(event_time <= censor_time & event_time <= 150)
) |>
select(id, treatment, subgroup, age, sex, time, event)
}
km_plot <- function(data) {
fit <- survfit(Surv(time, event) ~ treatment, data = data)
strata <- if (is.null(fit$strata)) {
rep(unique(data$treatment)[1], length(fit$time))
} else {
sub("treatment=", "", rep(names(fit$strata), fit$strata))
}
km_data <- data.frame(
time = fit$time,
survival = fit$surv,
upper = fit$upper,
lower = fit$lower,
strata = strata
)
p_value <- if (length(unique(data$treatment)) < 2) {
NA_real_
} else {
test <- survdiff(Surv(time, event) ~ treatment, data = data)
pchisq(test$chisq, length(test$n) - 1, lower.tail = FALSE)
}
ggplot(km_data, aes(x = time, colour = strata, fill = strata)) +
geom_ribbon(aes(ymin = lower, ymax = upper), alpha = 0.2, colour = NA) +
geom_step(aes(y = survival), linewidth = 1) +
scale_colour_manual(
values = c("Treatment A" = "#56B4E9", "Treatment B" = "#F0C419"),
drop = FALSE
) +
scale_fill_manual(
values = c("Treatment A" = "#56B4E9", "Treatment B" = "#F0C419"),
drop = FALSE
) +
scale_x_continuous(breaks = seq(0, 150, 50), limits = c(0, 150)) +
scale_y_continuous(limits = c(0, 1), labels = number_format(accuracy = 0.01)) +
labs(
x = "Time (months)",
y = "Survival Probability",
colour = "Treatment",
fill = "Treatment"
) +
annotate(
"text",
x = 5,
y = 0.18,
hjust = 0,
label = ifelse(is.na(p_value), "", paste0("p = ", signif(p_value, 3)))
) +
theme_minimal(base_size = 13) +
theme(legend.position = "top")
}
risk_table_plot <- function(data) {
fit <- survfit(Surv(time, event) ~ treatment, data = data)
times <- seq(0, 150, 50)
risk <- summary(fit, times = times, extend = TRUE)
treatment <- if (is.null(risk$strata)) {
rep(unique(data$treatment)[1], length(risk$time))
} else {
sub("treatment=", "", risk$strata)
}
risk_data <- data.frame(
treatment = treatment,
time = risk$time,
n_risk = risk$n.risk
) |>
mutate(treatment = factor(treatment, levels = c("Treatment B", "Treatment A")))
label_data <- risk_data |> distinct(treatment)
ggplot(risk_data, aes(time, treatment, label = n_risk)) +
geom_text(size = 4, colour = "black") +
geom_text(
data = label_data,
aes(x = -8, y = treatment, label = treatment, colour = treatment),
inherit.aes = FALSE,
hjust = 1,
size = 3.2
) +
scale_colour_manual(
values = c("Treatment A" = "#56B4E9", "Treatment B" = "#F0C419"),
drop = FALSE
) +
scale_y_discrete(drop = TRUE) +
scale_x_continuous(breaks = times, limits = c(-15, 150)) +
coord_cartesian(clip = "off") +
labs(x = "Time", y = NULL, title = "Number at risk") +
theme_minimal(base_size = 12) +
theme(
legend.position = "none",
axis.text.y = element_blank(),
axis.ticks.y = element_blank(),
plot.margin = margin(5.5, 5.5, 5.5, 70)
)
}
hazard_ratio_summary <- function(data, adjust = FALSE) {
if (length(unique(data$treatment)) < 2) {
return(tags$p("Select both treatment groups to estimate a hazard ratio.", style = "font-size: 0.8rem;"))
}
# Build model formula based on adjustment
if (adjust) {
model <- coxph(Surv(time, event) ~ treatment + age + sex, data = data)
} else {
model <- coxph(Surv(time, event) ~ treatment, data = data)
}
estimate <- summary(model)
hr <- estimate$conf.int[1, "exp(coef)"]
lower <- estimate$conf.int[1, "lower .95"]
upper <- estimate$conf.int[1, "upper .95"]
p_value <- estimate$coefficients[1, "Pr(>|z|)"]
model_note <- if (adjust) {
"Adjusted for age and sex"
} else {
"Unadjusted"
}
tagList(
h2(paste0("HR: ", round(hr, 2)), class = "text-center", style = "margin: 0; padding: 0; line-height: 0.9; color: #56B4E9; font-size: 1.8rem;"),
p(paste0("95% CI: [", round(lower, 2), ", ", round(upper, 2), "]"), class = "text-center", style = "font-size: 0.75rem; margin: 0; padding: 0; line-height: 0.9;"),
p(paste0("P-value: ", signif(p_value, 3)), class = "text-center", style = "font-size: 0.75rem; margin: 0; padding: 0; line-height: 0.9;"),
hr(style = "margin: 0.2rem 0;"),
p(model_note, class = "text-center", style = "font-size: 0.7rem; font-style: italic; margin: 0; padding: 0; line-height: 0.9; color: #56B4E9;"),
p(paste0("Total subjects: ", nrow(data)), class = "text-center text-muted", style = "font-size: 0.7rem; margin: 0; padding: 0; line-height: 0.9;"),
p(
paste0("Events: ", sum(data$event), " (", round(mean(data$event) * 100, 1), "%)"),
class = "text-center text-muted",
style = "font-size: 0.7rem; margin: 0; padding: 0; line-height: 0.9;"
)
)
}
ui <- page_navbar(
title = "Clinical Trial Survival Analysis Dashboard",
sidebar = sidebar(
width = 300,
selectInput(
"treatment",
"Treatment Group:",
choices = c("All", "Treatment A", "Treatment B")
),
selectInput(
"subgroup",
"Subgroup:",
choices = c("All", "Subgroup 1", "Subgroup 2", "Subgroup 3")
),
sliderInput(
"censor_rate",
"Censoring Rate:",
min = 0,
max = 0.5,
value = 0.3,
step = 0.05
),
checkboxInput(
"adjust_cox",
"Adjust Cox model for age and sex",
value = FALSE
),
downloadButton("download_data", "Download Dataset", class = "btn-primary")
),
nav_panel(
title = "Analysis",
card(
full_screen = TRUE,
card_header("Kaplan-Meier Survival Curve"),
plotOutput("km_plot", height = "420px")
),
layout_columns(
col_widths = c(6, 6),
card(
full_screen = TRUE,
card_header("Number at Risk Table"),
plotOutput("risk_table", height = "260px")
),
card(
full_screen = TRUE,
card_header("Hazard Ratio Summary"),
uiOutput("hr_summary")
)
)
),
nav_panel(
title = "Dataset",
card(
full_screen = TRUE,
card_header("Survival Data Table"),
DTOutput("data_table")
)
)
)
server <- function(input, output, session) {
survival_data <- reactive({
generate_survival_data(censor_rate = input$censor_rate)
})
filtered_data <- reactive({
data <- survival_data()
if (input$treatment != "All") {
data <- data |> filter(treatment == input$treatment)
}
if (input$subgroup != "All") {
data <- data |> filter(subgroup == input$subgroup)
}
data
})
output$km_plot <- renderPlot({
km_plot(filtered_data())
})
output$risk_table <- renderPlot({
risk_table_plot(filtered_data())
})
output$hr_summary <- renderUI({
hazard_ratio_summary(filtered_data(), adjust = input$adjust_cox)
})
output$data_table <- renderDT({
datatable(
filtered_data(),
filter = "top",
options = list(
pageLength = 25,
searching = TRUE,
autoWidth = TRUE,
lengthChange = FALSE, # Removes the "Show entries" dropdown
dom = 'frtip' # Customizes table controls (f=filter, r=processing, t=table, i=info, p=pagination)
),
rownames = FALSE
)
})
output$download_data <- downloadHandler(
filename = function() {
paste0("survival_data_", Sys.Date(), ".csv")
},
content = function(file) {
write.csv(filtered_data(), file, row.names = FALSE)
}
)
}
shinyApp(ui, server)teal App 1: Basic App
# ---- Robust package setup ----
options(repos = c(CRAN = "https://cran.rstudio.com"))
required_packages <- c(
"shiny",
"dplyr",
"teal"
)
installed_packages <- rownames(installed.packages())
missing_packages <- setdiff(required_packages, installed_packages)
if (length(missing_packages) > 0) {
install.packages(
missing_packages,
type = "binary",
dependencies = TRUE
)
}
library(shiny)
library(dplyr)
library(teal)
data <- teal_data(
IRIS = iris,
MTCARS = mtcars
)
app <- init(
data = data,
modules =example_module()) %>%
modify_title("Basic Teal Demo App") %>%
modify_header("My first teal app") %>%
modify_footer("Powered by teal + shiny")
shinyApp(app$ui, app$server)teal App 2: Pre-Built Module
# ---- Robust package setup ----
options(repos = c(CRAN = "https://cran.rstudio.com"))
required_packages <- c(
"teal",
"teal.widgets",
"shiny",
"DT",
"teal.modules.clinical"
)
installed_packages <- rownames(installed.packages())
missing_packages <- setdiff(required_packages, installed_packages)
if (length(missing_packages) > 0) {
install.packages(
missing_packages,
type = "binary",
dependencies = TRUE
)
}
library(teal)
library(teal.widgets)
library(shiny)
library(DT)
library(teal.modules.clinical)
data <- teal_data(
ADSL = rADSL
)
# Create join keys object
join_keys_obj <- join_keys(
join_key("ADSL", keys = c("USUBJID"))
)
# Assign join keys
join_keys(data) <- join_keys_obj
# Define the Demographic Table Module
demo_table_module <- function() {
tm_t_summary(
label = "Demographic Table",
dataname = "ADSL",
arm_var = choices_selected(
choices = choices_labeled(
choices = "ARM",
labels = col_labels(rADSL, fill = FALSE)["ARM"]
),
selected = "ARM"
),
summarize_vars = choices_selected(
choices = variable_choices("ADSL"),
selected = c("SEX", "AGE", "RACE")
)
)
}
app <- init(
data = data,
modules = modules(demo_table_module())) %>%
modify_title("Basic Teal Demo App") %>%
modify_header("My first teal app") %>%
modify_footer("Powered by teal + shiny")
shinyApp(app$ui, app$server)teal App 3: Custom Module
# ---- Robust package setup ----
options(repos = c(CRAN = "https://cran.rstudio.com"))
required_packages <- c(
"teal",
"teal.widgets",
"shiny",
"ggplot2"
)
installed_packages <- rownames(installed.packages())
missing_packages <- setdiff(required_packages, installed_packages)
if (length(missing_packages) > 0) {
install.packages(
missing_packages,
type = "binary",
dependencies = TRUE
)
}
library(teal)
library(teal.widgets)
library(shiny)
library(ggplot2)
data <- teal_data(
IRIS = iris,
MTCARS = mtcars
)
plot_module <- function(label = "Plot") {
module(
label = label,
ui = function(id) {
ns <- NS(id)
standard_layout(
encoding = tagList(
selectInput(
ns("dataset"),
"Choose a dataset:",
choices = c("IRIS", "MTCARS")
)
),
output = plotOutput(ns("plot"), height = "80vh")
)
},
server = function(id, data) {
moduleServer(id, function(input, output, session) {
output$plot <- renderPlot({
df <- data()[[input$dataset]]
# Keep numeric columns
num_df <- df[, sapply(df, is.numeric), drop = FALSE]
req(ncol(num_df) >= 2)
x_name <- names(num_df)[1]
y_name <- names(num_df)[2]
ggplot(num_df, aes_string(x = x_name, y = y_name)) +
geom_point(color = "steelblue", size = 2) +
labs(
title = paste("First Two Numeric Variables:", input$dataset),
x = x_name,
y = y_name
) +
theme_minimal()
})
})
}
)
}
app <- init(
data = data,
modules = modules(plot_module())) %>%
modify_title("Basic Teal Demo App") %>%
modify_header("My first teal app") %>%
modify_footer("Powered by teal + shiny")
shinyApp(app$ui, app$server)