Shiny Exercises
Portugal 2023
Julian Mollenhauer
Universität Tübingen1 Input and output controls
In this task, the following app is to be adapted. First, run the app in an R console and take a close look at it. Then work on the following tasks one after the other.
library(shiny)
# User interface with slider (input) and plot (output)
ui <- fluidPage(
sliderInput(inputId = "n",
label = "Number of samples",
min = 1, max = 100, value = 10),
plotOutput(outputId = "hist")
)
# Server function connecting input and output
server <- function(input, output){
output$hist <- renderPlot({
x <- rnorm(input$n) # draw n random values
hist(x, main = "Histogram")
})
}
shinyApp(ui = ui, server = server)- Add the heading “Histogram of random values” to the app using
titlePanel()inside thefluidPage()function.
library(shiny)
# User interface with slider (input) and plot (output)
ui <- fluidPage(
#######################################################
titlePanel("Histogram of random values"),
# Alternatively, an HTML tag can be used.
# Note: in this case, however, no title tag is set in the header
# (i.e. the title is not displayed in the browser tab).
# titlePanel() does this automatically.
# tags$h2("Histogram of random values"),
#######################################################
sliderInput(inputId = "n",
label = "Number of samples",
min = 1, max = 100, value = 10),
plotOutput(outputId = "hist")
)
# Server function connecting input and output
server <- function(input, output){
output$hist <- renderPlot({
x <- rnorm(input$n) # draw n random values
hist(x, main = "Histogram")
})
}
shinyApp(ui = ui, server = server)- Adjust the app so that the slider
"n"can only move between 50 and 1000 in increments of 50. See?sliderInputfor help.
library(shiny)
# User interface with slider (input) and plot (output)
ui <- fluidPage(
titlePanel("Histogram of random values"),
#######################################################
sliderInput(inputId = "n",
label = "Number of samples",
min = 50, max = 1000, value = 50, step = 50),
#######################################################
plotOutput(outputId = "hist")
)
# Server function connecting input and output
server <- function(input, output){
output$hist <- renderPlot({
x <- rnorm(input$n) # draw n random values
hist(x, main = "Histogram")
})
}
shinyApp(ui = ui, server = server)- Add another input (
selectInput()orradioButtons()) and let the user choose among drawing samples from three distributions: normal, uniform (runif()), or exponential (rexp()). Useswitch()to adjust the logic in the server function. See?switchfor help.
library(shiny)
# User interface with slider (input) and plot (output)
ui <- fluidPage(
titlePanel("Histogram of random values"),
sliderInput(inputId = "n",
label = "Number of samples",
min = 50, max = 1000, value = 50, step = 50),
#######################################################
#selectInput(inputId = "distribution",
# label = "Distribution",
# choices = c("normal", "uniform", "exponential")),
radioButtons(inputId = "distribution",
label = "Distribution",
choices = c("normal", "uniform", "exponential")),
#######################################################
plotOutput(outputId = "hist")
)
# Server function connecting input and output
server <- function(input, output){
output$hist <- renderPlot({
#######################################################
x <- switch(input$distribution,
normal = rnorm(input$n),
uniform = runif(input$n),
exponential = rexp(input$n)
)
# draw n random values from the chosen distribution
#######################################################
hist(x, main = "Histogram")
})
}
shinyApp(ui = ui, server = server)- Add a
checkboxInput()to the UI. When the box is ticked, the distribution from which random values are drawn should be drawn into the histogram usingcurve().
The y-axis of the histogram must represent the density (argument
freq = FALSE). To draw the curve into the histogram, the
argument add = TRUE must be set for
curve().
library(shiny)
# User interface with slider (input) and plot (output)
ui <- fluidPage(
titlePanel("Histogram of random values"),
sliderInput(inputId = "n",
label = "Number of samples",
min = 50, max = 1000, value = 50, step = 50),
radioButtons(inputId = "distribution",
label = "Distribution",
choices = c("normal", "uniform", "exponential")),
#######################################################
# Add checkbox UI
checkboxInput("show_distribution", "Show distribution in histogram"),
#######################################################
plotOutput(outputId = "hist")
)
# Server function connecting input and output
server <- function(input, output){
output$hist <- renderPlot({
x <- switch(input$distribution,
normal = rnorm(input$n),
uniform = runif(input$n),
exponential = rexp(input$n)
)
#######################################################
# freq = FALSE -> plot density on y-axis
hist(x, main = "Histogram", freq = FALSE)
#######################################################
# Add server logic: if input$show_distribution is TRUE
# the selected distribution (input$distribution) is added to the hist()
if(input$show_distribution){
switch(input$distribution,
normal = curve(dnorm, from = -6, to = 6,
add = TRUE, col = "red", lty = 2),
uniform = curve(dunif, from = 0, to = 1,
add = TRUE, col = "red", lty = 2),
exponential = curve(dexp, from = 0, to = 10,
add = TRUE, col = "red", lty = 2))
}
#######################################################
})
}
shinyApp(ui = ui, server = server)- Depending on how you solved the task before, an undesirable
behaviour may have occurred: Each time the
checkboxInput()is clicked, new values are drawn.
Try to find a solution so that this does not happen, i.e. when the box is clicked, the distribution is added to or removed from the histogram without drawing new random values.
Move the part where the values are drawn into a reactive expression
using reactive({}).
library(shiny)
# User interface with slider (input) and plot (output)
ui <- fluidPage(
titlePanel("Histogram of random values"),
sliderInput(inputId = "n",
label = "Number of samples",
min = 50, max = 1000, value = 50, step = 50),
radioButtons(inputId = "distribution",
label = "Distribution",
choices = c("normal", "uniform", "exponential")),
checkboxInput("show_distribution", "Show distribution in histogram"),
plotOutput(outputId = "hist")
)
# Server function connecting input and output
server <- function(input, output){
#######################################################
# Move drawing proces into reactive expression
get_data <- reactive({
switch(input$distribution,
normal = rnorm(input$n),
uniform = runif(input$n),
exponential = rexp(input$n)
)
})
#######################################################
output$hist <- renderPlot({
#######################################################
# refer back to reactive expression get_data()
# add xlab (not necessary, but nicer)
hist(get_data(), main = "Histogram", freq = FALSE, xlab = "x")
#######################################################
if(input$show_distribution){
switch(input$distribution,
normal = curve(dnorm, from = -6, to = 6,
add = TRUE, col = "red", lty = 2),
uniform = curve(dunif, from = 0, to = 1,
add = TRUE, col = "red", lty = 2),
exponential = curve(dexp, from = 0, to = 10,
add = TRUE, col = "red", lty = 2))
}
})
}
shinyApp(ui = ui, server = server)- Add a layout: Try both, (1) an automatic layout using
sidebarLayout(),sidebarPanel(), andmainPanel(); (2) a custom layout usingfluidRow()andcolumn().
library(shiny)
# User interface with slider (input) and plot (output)
ui <- fluidPage(
titlePanel("Histogram of random values"),
#######################################################
# Add sidebarLayout
sidebarLayout(
sidebarPanel(
sliderInput(inputId = "n",
label = "Number of samples",
min = 50, max = 1000, value = 50, step = 50),
radioButtons(inputId = "distribution",
label = "Distribution",
choices = c("normal", "uniform", "exponential")),
checkboxInput("show_distribution", "Show distribution in histogram")
),
mainPanel(
plotOutput(outputId = "hist")
)
)
#######################################################
)
# Server function connecting input and output
server <- function(input, output){
get_data <- reactive({
switch(input$distribution,
normal = rnorm(input$n),
uniform = runif(input$n),
exponential = rexp(input$n)
)
})
output$hist <- renderPlot({
hist(get_data(), main = "Histogram", freq = FALSE, xlab = "x")
if(input$show_distribution){
switch(input$distribution,
normal = curve(dnorm, from = -6, to = 6,
add = TRUE, col = "red", lty = 2),
uniform = curve(dunif, from = 0, to = 1,
add = TRUE, col = "red", lty = 2),
exponential = curve(dexp, from = 0, to = 10,
add = TRUE, col = "red", lty = 2))
}
})
}
shinyApp(ui = ui, server = server)library(shiny)
# User interface with slider (input) and plot (output)
ui <- fluidPage(
titlePanel("Histogram of random values"),
#######################################################
# Add custom layout using fluidRow(), column() and
# wellPanel() to separate sections
wellPanel(
fluidRow(
column(6,
sliderInput(inputId = "n",
label = "Number of samples",
min = 50, max = 1000, value = 50, step = 50)
),
column(2,
radioButtons(inputId = "distribution",
label = "Distribution",
choices = c("normal", "uniform", "exponential"))
),
column(3,
checkboxInput("show_distribution", "Show distribution in histogram")
))),
fluidRow(
plotOutput(outputId = "hist")
)
#######################################################
)
# Server function connecting input and output
server <- function(input, output){
get_data <- reactive({
switch(input$distribution,
normal = rnorm(input$n),
uniform = runif(input$n),
exponential = rexp(input$n)
)
})
output$hist <- renderPlot({
hist(get_data(), main = "Histogram", freq = FALSE, xlab = "x")
if(input$show_distribution){
switch(input$distribution,
normal = curve(dnorm, from = -6, to = 6,
add = TRUE, col = "red", lty = 2),
uniform = curve(dunif, from = 0, to = 1,
add = TRUE, col = "red", lty = 2),
exponential = curve(dexp, from = 0, to = 10,
add = TRUE, col = "red", lty = 2))
}
})
}
shinyApp(ui = ui, server = server)Draw the reactive graph by hand and compare it to the one created using the
reactlogpackage (executeoptions(shiny.reactlog = TRUE)before you start the shiny app to enable reactlog and press Ctrl + F3 or Command + F3 to display the generated reactive graph).Note: There are some additional “internal” nodes (
clientData$...) in the graph created by reactlog. They are responsible for rendering the plot correctly. You can simply ignore them if you compare the graphs.
library(shiny)
options(shiny.reactlog = TRUE) # enable reactlog
# User interface with slider (input) and plot (output)
ui <- fluidPage(
titlePanel("Histogram of random values"),
#######################################################
# Add sidebarLayout
sidebarLayout(
sidebarPanel(
sliderInput(inputId = "n",
label = "Number of samples",
min = 50, max = 1000, value = 50, step = 50),
radioButtons(inputId = "distribution",
label = "Distribution",
choices = c("normal", "uniform", "exponential")),
checkboxInput("show_distribution", "Show distribution in histogram")
),
mainPanel(
plotOutput(outputId = "hist")
)
)
#######################################################
)
# Server function connecting input and output
server <- function(input, output){
get_data <- reactive({
switch(input$distribution,
normal = rnorm(input$n),
uniform = runif(input$n),
exponential = rexp(input$n)
)
})
output$hist <- renderPlot({
hist(get_data(), main = "Histogram", freq = FALSE, xlab = "x")
if(input$show_distribution){
switch(input$distribution,
normal = curve(dnorm, from = -6, to = 6,
add = TRUE, col = "red", lty = 2),
uniform = curve(dunif, from = 0, to = 1,
add = TRUE, col = "red", lty = 2),
exponential = curve(dexp, from = 0, to = 10,
add = TRUE, col = "red", lty = 2))
}
})
}
shinyApp(ui = ui, server = server)
# Press Ctrl + 3 (or Command + F3) to open the reactlog graph2 Analysis of the
PlantGrowth dataset
Create a Shiny app that displays a boxplot for the
PlantGrowth data in R.
Let the user select the groups to display.
Depending on the selected groups, the histogram could look like this: (You can adapt the code below for your app)
par(mfrow = c(1, 3))
## if all groups are selected:
boxplot(weight ~ group, PlantGrowth)
## if only group ctrl and trt2 are selected
data <- droplevels(PlantGrowth[PlantGrowth$group %in% c("ctrl", "trt2"), ])
boxplot(weight ~ group, data, axes = FALSE)
axis(2)
axis(1, at = 1:nlevels(data$group), labels = levels(data$group))
box()
## if only group trt1 is selected
data <- droplevels(PlantGrowth[PlantGrowth$group %in% c("trt1"), ])
boxplot(weight ~ group, data, axes = FALSE)
axis(2)
axis(1, at = 1:nlevels(data$group), labels = levels(data$group))
box()
Use checkboxGroupInput() or selectInput()
to select the groups.
- Use
validate(need(...))to display a message if no group is selected. Otherwise, an error message could appear.
Check whether the input variable in which the selected groups are
stored contains elements (e.g. using
length(input$...) > 0)
- Add an output that shows the results of a one-sample t test, a
two-sample t test (
t.test()), or a one-way ANOVA (oneway.test()), depending on whether one, two, or three groups are selected.
# if only group ctrl and trt2 are selected
data <- droplevels(PlantGrowth[PlantGrowth$group %in% c("ctrl", "trt2"), ])
t.test(weight ~ group, data) # two-sample t test
# if only group trt1 is selected
data <- droplevels(PlantGrowth[PlantGrowth$group %in% c("trt1"), ])
t.test(data$weight, mu = 0) # one-sample t test
# all three groups
data <- droplevels(PlantGrowth[PlantGrowth$group %in% c("ctrl", "trt1", "trt2"), ])
oneway.test(weight ~ group, data) # one-way ANOVA- Add an input that lets the user select whether to treat the variances in the groups as being equal. Accordingly, display the correct test.
Use the var.equal argument.
library(shiny)
ui <- fluidPage(
titlePanel("PlantGrowth"),
sidebarLayout(
sidebarPanel(
checkboxGroupInput(inputId = "groups",
label = "Select group(s)",
choices = c("control" = "ctrl",
"treatment 1" = "trt1",
"treatment 2" = "trt2")
),
checkboxInput("checkb_vareq", "Treat variances as being equal?")
),
mainPanel(
plotOutput("box_plot"),
verbatimTextOutput("result_test")
)
)
)
server <- function(input, output){
data <- reactive({
validate(need(length(input$groups) > 0, "Please select at least one group."))
droplevels(PlantGrowth[PlantGrowth$group %in% input$groups, ])
})
output$box_plot <- renderPlot({
boxplot(weight ~ group, data(), axes = FALSE)
axis(2)
axis(1, at = 1:nlevels(data()$group), labels = levels(data()$group))
box()
})
output$result_test <- renderPrint({
req(input$groups)
if(length(input$groups) == 1){
t.test(data()$weight, mu = 0)
}else if(length(input$groups) == 2){
t.test(weight ~ group, data(), var.equal = input$checkb_vareq)
}else if(length(input$groups) == 3){
oneway.test(weight ~ group, data(), var.equal = input$checkb_vareq)
}
})
}
shinyApp(ui = ui, server = server)- Bonus exercise: Hide the input that lets the user select whether to treat the variances in the groups as being equal if only one group (or no group) is selected.
Use conditionalPanel() (reminder: the condition has to
be a JavaScript expression, see ?conditionalPanel for some
examples. In order to access the reactive input value in JS and
calculate its length use input['inputId'].length) or
uiOutput() paired with renderUI().
library(shiny)
ui <- fluidPage(
titlePanel("PlantGrowth"),
sidebarLayout(
sidebarPanel(
checkboxGroupInput(inputId = "groups",
label = "Select group(s)",
choices = c("control" = "ctrl",
"treatment 1" = "trt1",
"treatment 2" = "trt2")
),
conditionalPanel("input['groups'].length > 1",
checkboxInput("checkb_vareq", "Treat variances as being equal?")
)
),
mainPanel(
plotOutput("box_plot"),
verbatimTextOutput("result_test")
)
)
)
server <- function(input, output){
data <- reactive({
validate(need(length(input$groups) > 0, "Please select at least one group."))
droplevels(PlantGrowth[PlantGrowth$group %in% input$groups, ])
})
output$box_plot <- renderPlot({
boxplot(weight ~ group, data(), axes = FALSE)
axis(2)
axis(1, at = 1:nlevels(data()$group), labels = levels(data()$group))
box()
})
output$result_test <- renderPrint({
req(input$groups)
if(length(input$groups) == 1){
t.test(data()$weight, mu = 0)
}else if(length(input$groups) == 2){
t.test(weight ~ group, data(), var.equal = input$checkb_vareq)
}else if(length(input$groups) == 3){
oneway.test(weight ~ group, data(), var.equal = input$checkb_vareq)
}
})
}
shinyApp(ui = ui, server = server)3 Bootstrap from
cars dataset
Create a Shiny app with the user interface consisting of an
actionButton()input and two outputs:plotOutput()andverbatimTextOutput(). On each button click- a new 50-observations bootstrap sample is drawn with replacement
from the
carsdata, - the scatter plot is displayed,
- descriptive statistics (
summary()) are shown.
- a new 50-observations bootstrap sample is drawn with replacement
from the
In the server function, use
getsamples <- eventReactive({...}) to be able to access
the same data set both within renderPlot() and
renderPrint()
library(shiny)
ui <- fluidPage(
titlePanel("Bootstrap sampling"),
sidebarLayout(
sidebarPanel(
actionButton("new_sample", "New sample"),
tags$hr(),
verbatimTextOutput("stats")
),
mainPanel(
plotOutput("scatterplot")
)
)
)
server <- function(input, output){
getsamples <- eventReactive(input$new_sample, {
cars[sample(1:50, 50, replace = TRUE), ]
})
output$scatterplot <- renderPlot({
plot(dist ~ speed, getsamples())
})
output$stats <- renderPrint({
summary(getsamples())
})
}
shinyApp(ui = ui, server = server)Expand the previous Shiny app.
- Add a check box to allow the user to show a regression line.
- Add a second button ‘Reset’ that restores the sample to the original cars data.
To get two buttons to work in the server function, combine
reactiveValues() and
observe()/observeEvent(). More here: https://shiny.rstudio.com/articles/action-buttons.html.
library(shiny)
ui <- fluidPage(
titlePanel("Bootstrap sampling"),
sidebarLayout(
sidebarPanel(
fluidRow(
column(6,
actionButton("new_sample", "New sample")
),
column(6,
actionButton("reset", "Reset")
)
),
checkboxInput("show_regr", "Show regression line"),
tags$hr(),
verbatimTextOutput("stats")
),
mainPanel(
plotOutput("scatterplot")
)
)
)
server <- function(input, output){
getsamples <- reactiveValues(data = cars)
observeEvent(input$new_sample,{
getsamples$data <- cars[sample(1:50, 50, replace = TRUE), ]
})
observeEvent(input$reset,{
getsamples$data <- cars
})
output$scatterplot <- renderPlot({
plot(dist ~ speed, getsamples$data, xlim = c(0, 26), ylim = c(0, 125))
if(input$show_regr){
abline(lm(dist ~ speed, getsamples$data))
}
})
output$stats <- renderPrint({
summary(getsamples$data)
})
}
shinyApp(ui = ui, server = server)- Take a look at the reactive graph created by the reactlog package.
Find the nodes for
observe()orobserveEvent()andreactiveValues()and play a little bit with this graph using the ‘Next Step / Previous Step’ button at the top. Try to understand what happens if you click ‘Reset’ in the app and how this process is represented in the graph.
4 Linear regression
Develop a Shiny App with the following content:
Simulate data from the following model \[ y_i = \beta_0 + \beta_1 \cdot x_i + e_i\] with \(e_i \sim N(\mu = 0, \sigma = \sigma)\), \(i = 1, ..., n\) and \(x_i \sim \mathcal{U}(0, 100)\). The parameters \(\beta_0\) and \(\beta_1\) as well as \(\sigma\) and the sample size \(n\) should be freely adjustable by the user (within a certain range).
Display the simulated data in a scatterplot.
Add the true regression line to the plot if a checkbox has been ticked.
Estimate a linear model based on the simulated data and plot the estimated regression line in the scatterplot as well. (but only if another checkbox has been ticked)
Give the inputs meaningful labels so that the user can understand what he can change with the inputs.
Add descriptions that help the user understand the app. In this context, you should also include the mathematical expression of the model in the app and briefly explain the parameters.
If you are still looking for a challenge, then let the user decide whether a quadratic or even cubic term should be included in the model. E.g.: \[ y_i = \beta_0 + \beta_1 \cdot x_i + \beta_2 \cdot x_i^2 + e_i\]
Feel free to show me the finished app and ask me for feedback :)