Shiny Exercise 3
Rockefeller University, Bioinformatics Resource Centre
https://rockefelleruniversity.github.io/RU_shiny/
Â
These exercises are about dynamic UIs and user feedback.
Exercises for Shiny session 3
- Starting from the final app you made in question #5 in the exercises for Session 2, allow the user to upload the table as opposed to it being hard coded into the app.
- HINT: we have previously used the number of rows in the UI object
for the value box showing the number of patients. This will now break
the app because the table is no longer present when the app loads.
- You should make it so the value box doesn’t render with the number of patients until the table is loaded.
library(ggplot2)
library(dplyr)
library(shiny)
library(bslib)
library(DT)
library(survival)
ui <- page_navbar(
title = "Cancer data",
theme = bs_theme(version = 5, bootswatch = "pulse"),
sidebar = sidebar(
fileInput("upload_file", "Upload a file:", accept = c(".csv", ".xlsx", "tsv")), # input for uploading files
sliderInput("number_of_bins", "Number of bins for histogram of age:",
min = 2, max = 50, value = 10, step = 1),
selectInput("survival_column", "Choose a column for the survivial plot:",
choices = c("Smoking_History_NLP", "Sex", "Sample_Type", "Cancer_Type_Detailed"),
selected = "Smoking_History_NLP"),
actionButton("update_plots", "Update plots"),
width = 300),
nav_panel(
title = "Data visualization",
layout_columns(
layout_columns(
uiOutput("num_patients_UI"),
card(card_header("Age distribution"),
plotOutput("age_histogram")),
col_widths = c(3,9),
row_heights = list("300px")
),
layout_columns(
card(card_header("Sex"),
plotOutput("sex_pie_chart")),
card(card_header("Smoking status"),
plotOutput("smokes_pie_chart")),
card(card_header("Sample Type"),
plotOutput("sampleType_pie_chart")),
card(card_header("Cancer Type"),
plotOutput("cancerType_pie_chart")),
col_widths = c(6, 6, 6, 6),
row_heights = c("400px", "400px")
),
layout_columns(
card(card_header("Survival by group"),
plotOutput("survival_kaplan")),
col_widths = c(12),
row_heights = list("500px")
),
col_widths = c(12,12, 12), fill=F
)
),
nav_panel(
title = "Clinical data table",
card(
card_header("Clinical Data"),
DT::dataTableOutput("data_in")
)
),
nav_spacer(),
nav_menu(
title = "Links",
align = "right",
nav_item(
tags$a(
shiny::icon("chart-simple"), "RU BRC - Learn more!",
href = "https://www.cbioportal.org/",
target = "_blank"
)
)
)
)
server <- function(input, output){
# make a reactive to take in the input path and make a data frame
# we also have to change all of the reactive contexts that use this data frame to now use the table from this reactive
de_table_in <- reactive({
req(input$upload_file$datapath)
rio::import(input$upload_file$datapath)
})
# we now need to wait until we have a table to know the number of patients in the study, so we use renderUI to only render this valuebox when a table is present and uploaded
# if we have no path yet from a file, then we show a blank valuebox
output$num_patients_UI <- renderUI({
if(!is.null(input$upload_file$datapath)){
value_box("Number of patients",
value = nrow(de_table_in()),
theme = "text-purple")
}else{
value_box("Number of patients",
value = "",
theme = "text-purple")
}
})
output$data_in <- renderDataTable({
req(de_table_in())
datatable(de_table_in())
})
output$age_histogram <- renderPlot({
req(de_table_in())
ggplot(de_table_in(), aes(x = Current_Age)) +
geom_histogram(bins=input$number_of_bins) +
theme_bw()
}) %>%
bindEvent(input$update_plots, de_table_in(), ignoreNULL = FALSE) # we add the table as an event to trigger, otherwise the plot won't render until the first time the button is pressed
output$sex_pie_chart <- renderPlot({
de_table_in() %>%
group_by(Sex) %>%
summarize(Num = n()) %>%
ggplot(aes(x = 1, y = Num, fill = Sex)) +
geom_bar(stat="identity", color="white") +
coord_polar("y") +
theme_void() +
theme(legend.text=element_text(size=12))
})
output$sampleType_pie_chart <- renderPlot({
de_table_in() %>%
group_by(Sample_Type) %>%
summarize(Num = n()) %>%
ggplot(aes(x = 1, y = Num, fill = Sample_Type)) +
geom_bar(stat="identity", color="white") +
coord_polar("y") +
theme_void() +
theme(legend.text=element_text(size=12))
})
output$smokes_pie_chart <- renderPlot({
de_table_in() %>%
group_by(Smoking_History_NLP) %>%
summarize(Num = n()) %>%
ggplot(aes(x = 1, y = Num, fill = Smoking_History_NLP)) +
geom_bar(stat="identity", color="white") +
coord_polar("y") +
theme_void() +
theme(legend.text=element_text(size=12))
})
output$cancerType_pie_chart <- renderPlot({
de_table_in() %>%
group_by(Cancer_Type_Detailed) %>%
summarize(Num = n()) %>%
ggplot(aes(x = 1, y = Num, fill = Cancer_Type_Detailed)) +
geom_bar(stat="identity", color="white") +
coord_polar("y") +
theme_void() +
theme(legend.text=element_text(size=12))
})
survival_plot <- reactive({
surv_obj <- Surv(time = de_table_in()$Overall_Survival_Months, event = de_table_in()$Survival_code)
fit <- survfit(as.formula(paste0("surv_obj ~ ", input$survival_column)), data = de_table_in())
surv_df <- data.frame(
time = fit$time,
surv = fit$surv,
group = rep(names(fit$strata), fit$strata)
)
ggplot(surv_df, aes(x = time, y = surv, color = group)) +
geom_step(linewidth = 1) +
labs(x = "Time (months)", y = "Survival Probability", color = "Group") +
theme_minimal() +
theme(legend.text=element_text(size=12)) +
ggtitle(paste0("Kaplan Meier - ", input$survival_column))
}) %>%
bindEvent(input$update_plots, de_table_in(), ignoreNULL = FALSE) # we add the table as an event to trigger, otherwise the plot won't render until the first time the button is pressed
output$survival_kaplan <- renderPlot({
survival_plot()
})
}
- Modify the app so that the user does not initially see the blank cards or the inputs for the plots (sliderInput and selectInput), and then once they load in the table, the plots and cards are then rendered.
- Also display a message in the main body of the front page telling them to upload a table
library(ggplot2)
library(dplyr)
library(shiny)
library(bslib)
library(DT)
library(survival)
ui <- page_navbar(
title = "Cancer data",
theme = bs_theme(version = 5, bootswatch = "pulse"),
sidebar = sidebar(
fileInput("upload_file", "Upload a file:", accept = c(".csv", ".xlsx", "tsv")),
uiOutput("user_inputs_UI"),
width = 300),
nav_panel(
title = "Data visualization",
uiOutput("plot_columns_UI"),
),
nav_panel(
title = "Clinical data table",
uiOutput("table_UI")
),
nav_spacer(),
nav_menu(
title = "Links",
align = "right",
nav_item(
tags$a(
shiny::icon("chart-simple"), "RU BRC - Learn more!",
href = "https://www.cbioportal.org/",
target = "_blank"
)
)
)
)
server <- function(input, output){
de_table_in <- reactive({
req(input$upload_file$datapath)
rio::import(input$upload_file$datapath)
})
output$num_patients_UI <- renderUI({
if(!is.null(input$upload_file$datapath)){
value_box("Number of patients",
value = nrow(de_table_in()),
theme = "text-purple")
}else{
value_box("Number of patients",
value = "",
theme = "text-purple")
}
})
# add renderUI functions for inputs, plots and table
output$user_inputs_UI <- renderUI({
req(de_table_in())
div(
sliderInput("number_of_bins", "Number of bins for histogram of age:",
min = 2, max = 50, value = 10, step = 1),
selectInput("survival_column", "Choose a column for the survivial plot:",
choices = c("Smoking_History_NLP", "Sex", "Sample_Type", "Cancer_Type_Detailed"),
selected = "Smoking_History_NLP"),
actionButton("update_plots", "Update plots")
)
})
output$plot_columns_UI <- renderUI({
if(is.null(input$upload_file)) {
div("You must load data!", style = "color: #273449; font-weight: bold;")
}else if(!is.null(de_table_in())){
layout_columns(
layout_columns(
uiOutput("num_patients_UI"),
card(card_header("Age distribution"),
plotOutput("age_histogram")),
col_widths = c(3,9),
row_heights = list("300px")
),
layout_columns(
card(card_header("Sex"),
plotOutput("sex_pie_chart")),
card(card_header("Smoking status"),
plotOutput("smokes_pie_chart")),
card(card_header("Sample Type"),
plotOutput("sampleType_pie_chart")),
card(card_header("Cancer Type"),
plotOutput("cancerType_pie_chart")),
col_widths = c(6, 6, 6, 6),
row_heights = c("400px", "400px")
),
layout_columns(
card(card_header("Survival by group"),
plotOutput("survival_kaplan")),
col_widths = c(12),
row_heights = list("500px")
),
col_widths = c(12,12, 12), fill=F
)
}
})
output$table_UI <- renderUI({
req(de_table_in())
card(
card_header("Clinical Data"),
DT::dataTableOutput("data_in"),
min_height = "1000px"
)
})
output$data_in <- renderDataTable({
req(de_table_in())
datatable(de_table_in())
})
output$age_histogram <- renderPlot({
req(de_table_in())
ggplot(de_table_in(), aes(x = Current_Age)) +
geom_histogram(bins=input$number_of_bins) +
theme_bw()
}) %>%
bindEvent(input$update_plots, de_table_in(), ignoreNULL = FALSE) # we add the table as an event to trigger, otherwise the plot won't render until the first time the button is pressed
output$sex_pie_chart <- renderPlot({
de_table_in() %>%
group_by(Sex) %>%
summarize(Num = n()) %>%
ggplot(aes(x = 1, y = Num, fill = Sex)) +
geom_bar(stat="identity", color="white") +
coord_polar("y") +
theme_void() +
theme(legend.text=element_text(size=12))
})
output$sampleType_pie_chart <- renderPlot({
de_table_in() %>%
group_by(Sample_Type) %>%
summarize(Num = n()) %>%
ggplot(aes(x = 1, y = Num, fill = Sample_Type)) +
geom_bar(stat="identity", color="white") +
coord_polar("y") +
theme_void() +
theme(legend.text=element_text(size=12))
})
output$smokes_pie_chart <- renderPlot({
de_table_in() %>%
group_by(Smoking_History_NLP) %>%
summarize(Num = n()) %>%
ggplot(aes(x = 1, y = Num, fill = Smoking_History_NLP)) +
geom_bar(stat="identity", color="white") +
coord_polar("y") +
theme_void() +
theme(legend.text=element_text(size=12))
})
output$cancerType_pie_chart <- renderPlot({
de_table_in() %>%
group_by(Cancer_Type_Detailed) %>%
summarize(Num = n()) %>%
ggplot(aes(x = 1, y = Num, fill = Cancer_Type_Detailed)) +
geom_bar(stat="identity", color="white") +
coord_polar("y") +
theme_void() +
theme(legend.text=element_text(size=12))
})
survival_plot <- reactive({
surv_obj <- Surv(time = de_table_in()$Overall_Survival_Months, event = de_table_in()$Survival_code)
fit <- survfit(as.formula(paste0("surv_obj ~ ", input$survival_column)), data = de_table_in())
surv_df <- data.frame(
time = fit$time,
surv = fit$surv,
group = rep(names(fit$strata), fit$strata)
)
ggplot(surv_df, aes(x = time, y = surv, color = group)) +
geom_step(linewidth = 1) +
labs(x = "Time (months)", y = "Survival Probability", color = "Group") +
theme_minimal() +
theme(legend.text=element_text(size=12)) +
ggtitle(paste0("Kaplan Meier - ", input$survival_column))
}) %>%
bindEvent(input$update_plots, de_table_in(), ignoreNULL = FALSE) # we add the table as an event to trigger, otherwise the plot won't render until the first time the button is pressed
output$survival_kaplan <- renderPlot({
survival_plot()
})
}
- Put in some safeguards to let the user know when an improper file has been uploaded. Validate the input file by doing some simple checks to make sure required columns are present.
- Once a table is uploaded, display a notification telling the user new data has been loaded into the app.
library(ggplot2)
library(dplyr)
library(shiny)
library(bslib)
library(DT)
library(survival)
ui <- page_navbar(
title = "Cancer data",
theme = bs_theme(version = 5, bootswatch = "pulse"),
sidebar = sidebar(
fileInput("upload_file", "Upload a file:", accept = c(".csv", ".xlsx", "tsv")),
uiOutput("user_inputs_UI"),
width = 300),
nav_panel(
title = "Data visualization",
uiOutput("plot_columns_UI"),
),
nav_panel(
title = "Clinical data table",
uiOutput("table_UI")
),
nav_spacer(),
nav_menu(
title = "Links",
align = "right",
nav_item(
tags$a(
shiny::icon("chart-simple"), "RU BRC - Learn more!",
href = "https://www.cbioportal.org/",
target = "_blank"
)
)
)
)
server <- function(input, output){
# add the validate function to the reactive where we read in the table
de_table_in <- reactive({
req(input$upload_file)
file_in <- rio::import(input$upload_file$datapath)
validate(
need(expr = all(c("Smoking_History_NLP", "Sex", "Sample_Type", "Cancer_Type_Detailed") %in% colnames(file_in)),
message = "You must have the following columns: 'Smoking_History_NLP', 'Sex', 'Sample_Type', 'Cancer_Type_Detailed'")
)
file_in
})
# show notification when we have a data frame resulting from an uploaded file
observe({
showNotification("You have loaded data - congrats!", type = "message", duration = 5)
}) %>% bindEvent(de_table_in())
output$num_patients_UI <- renderUI({
if(!is.null(input$upload_file$datapath)){
value_box("Number of patients",
value = nrow(de_table_in()),
theme = "text-purple")
}else{
value_box("Number of patients",
value = "",
theme = "text-purple")
}
})
# add renderUI functions for inputs, plots and table
output$user_inputs_UI <- renderUI({
req(de_table_in())
div(
sliderInput("number_of_bins", "Number of bins for histogram of age:",
min = 2, max = 50, value = 10, step = 1),
selectInput("survival_column", "Choose a column for the survivial plot:",
choices = c("Smoking_History_NLP", "Sex", "Sample_Type", "Cancer_Type_Detailed"),
selected = "Smoking_History_NLP"),
actionButton("update_plots", "Update plots")
)
})
output$plot_columns_UI <- renderUI({
if(is.null(input$upload_file)) {
div("You must load data!", style = "color: #273449; font-weight: bold;")
}else if(!is.null(de_table_in())){
layout_columns(
layout_columns(
uiOutput("num_patients_UI"),
card(card_header("Age distribution"),
plotOutput("age_histogram")),
col_widths = c(3,9),
row_heights = list("300px")
),
layout_columns(
card(card_header("Sex"),
plotOutput("sex_pie_chart")),
card(card_header("Smoking status"),
plotOutput("smokes_pie_chart")),
card(card_header("Sample Type"),
plotOutput("sampleType_pie_chart")),
card(card_header("Cancer Type"),
plotOutput("cancerType_pie_chart")),
col_widths = c(6, 6, 6, 6),
row_heights = c("400px", "400px")
),
layout_columns(
card(card_header("Survival by group"),
plotOutput("survival_kaplan")),
col_widths = c(12),
row_heights = list("500px")
),
col_widths = c(12,12, 12), fill=F
)
}
})
output$table_UI <- renderUI({
req(de_table_in())
card(
card_header("Clinical Data"),
DT::dataTableOutput("data_in"),
min_height = "1000px"
)
})
output$data_in <- renderDataTable({
req(de_table_in())
datatable(de_table_in())
})
output$age_histogram <- renderPlot({
req(de_table_in())
ggplot(de_table_in(), aes(x = Current_Age)) +
geom_histogram(bins=input$number_of_bins) +
theme_bw()
}) %>%
bindEvent(input$update_plots, de_table_in(), ignoreNULL = FALSE) # we add the table as an event to trigger, otherwise the plot won't render until the first time the button is pressed
output$sex_pie_chart <- renderPlot({
de_table_in() %>%
group_by(Sex) %>%
summarize(Num = n()) %>%
ggplot(aes(x = 1, y = Num, fill = Sex)) +
geom_bar(stat="identity", color="white") +
coord_polar("y") +
theme_void() +
theme(legend.text=element_text(size=12))
})
output$sampleType_pie_chart <- renderPlot({
de_table_in() %>%
group_by(Sample_Type) %>%
summarize(Num = n()) %>%
ggplot(aes(x = 1, y = Num, fill = Sample_Type)) +
geom_bar(stat="identity", color="white") +
coord_polar("y") +
theme_void() +
theme(legend.text=element_text(size=12))
})
output$smokes_pie_chart <- renderPlot({
de_table_in() %>%
group_by(Smoking_History_NLP) %>%
summarize(Num = n()) %>%
ggplot(aes(x = 1, y = Num, fill = Smoking_History_NLP)) +
geom_bar(stat="identity", color="white") +
coord_polar("y") +
theme_void() +
theme(legend.text=element_text(size=12))
})
output$cancerType_pie_chart <- renderPlot({
de_table_in() %>%
group_by(Cancer_Type_Detailed) %>%
summarize(Num = n()) %>%
ggplot(aes(x = 1, y = Num, fill = Cancer_Type_Detailed)) +
geom_bar(stat="identity", color="white") +
coord_polar("y") +
theme_void() +
theme(legend.text=element_text(size=12))
})
survival_plot <- reactive({
surv_obj <- Surv(time = de_table_in()$Overall_Survival_Months, event = de_table_in()$Survival_code)
fit <- survfit(as.formula(paste0("surv_obj ~ ", input$survival_column)), data = de_table_in())
surv_df <- data.frame(
time = fit$time,
surv = fit$surv,
group = rep(names(fit$strata), fit$strata)
)
ggplot(surv_df, aes(x = time, y = surv, color = group)) +
geom_step(linewidth = 1) +
labs(x = "Time (months)", y = "Survival Probability", color = "Group") +
theme_minimal() +
theme(legend.text=element_text(size=12)) +
ggtitle(paste0("Kaplan Meier - ", input$survival_column))
}) %>%
bindEvent(input$update_plots, de_table_in(), ignoreNULL = FALSE) # we add the table as an event to trigger, otherwise the plot won't render until the first time the button is pressed
output$survival_kaplan <- renderPlot({
survival_plot()
})
}
- Allow the user to download the survival curve that is currently present in their app session
library(ggplot2)
library(dplyr)
library(shiny)
library(bslib)
library(DT)
library(survival)
ui <- page_navbar(
title = "Cancer data",
theme = bs_theme(version = 5, bootswatch = "pulse"),
sidebar = sidebar(
fileInput("upload_file", "Upload a file:", accept = c(".csv", ".xlsx", "tsv")),
uiOutput("user_inputs_UI"),
width = 300),
nav_panel(
title = "Data visualization",
uiOutput("plot_columns_UI"),
),
nav_panel(
title = "Clinical data table",
uiOutput("table_UI")
),
nav_spacer(),
nav_menu(
title = "Links",
align = "right",
nav_item(
tags$a(
shiny::icon("chart-simple"), "RU BRC - Learn more!",
href = "https://www.cbioportal.org/",
target = "_blank"
)
)
)
)
server <- function(input, output){
de_table_in <- reactive({
req(input$upload_file)
file_in <- rio::import(input$upload_file$datapath)
validate(
need(expr = all(c("Smoking_History_NLP", "Sex", "Sample_Type", "Cancer_Type_Detailed") %in% colnames(file_in)),
message = "You must have the following columns: 'Smoking_History_NLP', 'Sex', 'Sample_Type', 'Cancer_Type_Detailed'")
)
file_in
})
observe({
showNotification("You have loaded data - congrats!", type = "message", duration = 5)
}) %>% bindEvent(de_table_in())
output$num_patients_UI <- renderUI({
if(!is.null(input$upload_file$datapath)){
value_box("Number of patients",
value = nrow(de_table_in()),
theme = "text-purple")
}else{
value_box("Number of patients",
value = "",
theme = "text-purple")
}
})
output$user_inputs_UI <- renderUI({
req(de_table_in())
div(
sliderInput("number_of_bins", "Number of bins for histogram of age:",
min = 2, max = 50, value = 10, step = 1),
selectInput("survival_column", "Choose a column for the survivial plot:",
choices = c("Smoking_History_NLP", "Sex", "Sample_Type", "Cancer_Type_Detailed"),
selected = "Smoking_History_NLP"),
actionButton("update_plots", "Update plots")
)
})
output$plot_columns_UI <- renderUI({
if(is.null(input$upload_file)) {
div("You must load data!", style = "color: #273449; font-weight: bold;")
}else if(!is.null(de_table_in())){
layout_columns(
layout_columns(
uiOutput("num_patients_UI"),
card(card_header("Age distribution"),
plotOutput("age_histogram")),
col_widths = c(3,9),
row_heights = list("300px")
),
layout_columns(
card(card_header("Sex"),
plotOutput("sex_pie_chart")),
card(card_header("Smoking status"),
plotOutput("smokes_pie_chart")),
card(card_header("Sample Type"),
plotOutput("sampleType_pie_chart")),
card(card_header("Cancer Type"),
plotOutput("cancerType_pie_chart")),
col_widths = c(6, 6, 6, 6),
row_heights = c("400px", "400px")
),
layout_columns(
card(card_header("Survival by group"),
downloadButton("download_survival", style = "width:25%;"), # add download button to UI
plotOutput("survival_kaplan")),
col_widths = c(12),
row_heights = list("500px")
),
col_widths = c(12,12, 12), fill=F
)
}
})
# add the dowload handler to the server function
output$download_survival <- downloadHandler(
filename = function() {
"kaplan_survivialplot.pdf"
},
content = function(file) {
ggsave(filename = file, plot = survival_plot(), width = 15)
}
)
output$table_UI <- renderUI({
req(de_table_in())
card(
card_header("Clinical Data"),
DT::dataTableOutput("data_in"),
min_height = "1000px"
)
})
output$data_in <- renderDataTable({
req(de_table_in())
datatable(de_table_in())
})
output$age_histogram <- renderPlot({
req(de_table_in())
ggplot(de_table_in(), aes(x = Current_Age)) +
geom_histogram(bins=input$number_of_bins) +
theme_bw()
}) %>%
bindEvent(input$update_plots, de_table_in(), ignoreNULL = FALSE)
output$sex_pie_chart <- renderPlot({
de_table_in() %>%
group_by(Sex) %>%
summarize(Num = n()) %>%
ggplot(aes(x = 1, y = Num, fill = Sex)) +
geom_bar(stat="identity", color="white") +
coord_polar("y") +
theme_void() +
theme(legend.text=element_text(size=12))
})
output$sampleType_pie_chart <- renderPlot({
de_table_in() %>%
group_by(Sample_Type) %>%
summarize(Num = n()) %>%
ggplot(aes(x = 1, y = Num, fill = Sample_Type)) +
geom_bar(stat="identity", color="white") +
coord_polar("y") +
theme_void() +
theme(legend.text=element_text(size=12))
})
output$smokes_pie_chart <- renderPlot({
de_table_in() %>%
group_by(Smoking_History_NLP) %>%
summarize(Num = n()) %>%
ggplot(aes(x = 1, y = Num, fill = Smoking_History_NLP)) +
geom_bar(stat="identity", color="white") +
coord_polar("y") +
theme_void() +
theme(legend.text=element_text(size=12))
})
output$cancerType_pie_chart <- renderPlot({
de_table_in() %>%
group_by(Cancer_Type_Detailed) %>%
summarize(Num = n()) %>%
ggplot(aes(x = 1, y = Num, fill = Cancer_Type_Detailed)) +
geom_bar(stat="identity", color="white") +
coord_polar("y") +
theme_void() +
theme(legend.text=element_text(size=12))
})
survival_plot <- reactive({
surv_obj <- Surv(time = de_table_in()$Overall_Survival_Months, event = de_table_in()$Survival_code)
fit <- survfit(as.formula(paste0("surv_obj ~ ", input$survival_column)), data = de_table_in())
surv_df <- data.frame(
time = fit$time,
surv = fit$surv,
group = rep(names(fit$strata), fit$strata)
)
ggplot(surv_df, aes(x = time, y = surv, color = group)) +
geom_step(linewidth = 1) +
labs(x = "Time (months)", y = "Survival Probability", color = "Group") +
theme_minimal() +
theme(legend.text=element_text(size=12)) +
ggtitle(paste0("Kaplan Meier - ", input$survival_column))
}) %>%
bindEvent(input$update_plots, de_table_in(), ignoreNULL = FALSE) # we add the table as an event to trigger, otherwise the plot won't render until the first time the button is pressed
output$survival_kaplan <- renderPlot({
survival_plot()
})
}