Hide boxes if input not suitable in Shiny - r

Question

I am using shiny and shinydashboard. There are a couple of instances when I would like all or most boxes/plots to be hidden.
If the date range is impossible (i.e. the end date is earlier than the start date).
If inputs selected make the sample size too small.
With issue 1, I want to hide all the boxes and just return an error message. With issue 2, I'd like to show a few infoboxes at the top (e.g. sample size), but hide all the rest of the boxes.
Currently, I am producing an error message using validate for the first condition, and also using validate to stop the plots from running when this happens. However, this still leaves the boxes, even though they are empty, which is quite ugly and messy.
I would probably be able to put every box into a conditionalPanel, I guess, but that seems very repetitive - surely there is a simpler way to pass an argument to all (or a group of) boxes? This code is an example - there are a lot more boxes in the app I am working on.
Example code:
library(shiny)
library(shinydashboard)
library(tidyverse)
random_data <- data.frame(replicate(2, sample(0:10, 1000, rep=TRUE)))
set.seed(1984)
random_data$date <- sample(seq(as.Date('2016-01-01'), as.Date(Sys.Date()), by = "day"), 1000)
sidebar <- dashboardSidebar(dateRangeInput(
"dates", label = h4("Date range"), start = '2016-01-01', end = Sys.Date(),
format = "dd-mm-yyyy", startview = "year", min = "2016-01-01", max = Sys.Date()
))
body <- dashboardBody(
textOutput("selected_dates"),
br(),
fluidRow(
infoBoxOutput("total", width = 12)
),
fluidRow(
box(width = 12, solidHeader = TRUE,
title = "X1 over time",
plotOutput(outputId = "x1_time")
)
),
fluidRow(
box(width = 12, solidHeader = TRUE,
title = "X2 over time",
plotOutput(outputId = "x2_time")
)
)
)
ui <- dashboardPage(dashboardHeader(title = "Example"),
sidebar,
body
)
server <- function(input, output) {
filtered <- reactive({
filtered_data <- random_data %>%
filter(date >= input$dates[1] & date <= input$dates[2])
return(filtered_data)
})
output$selected_dates <- renderText({
validate(
need(input$dates[2] >= input$dates[1], "End date is earlier than start date"
)
)
})
output$total<- renderInfoBox({
validate(
need(input$dates[2] >= input$dates[1], "")
)
infoBox(title = "Sample size",
value = nrow(filtered()),
icon = icon("binoculars"), color = "light-blue")
})
output$x1_time <- renderPlot({
validate(
need(input$dates[2] >= input$dates[1], "")
)
x1_time_plot <- ggplot(filtered(), aes(x = date, y = X1)) +
geom_bar(stat = "identity")
theme_minimal()
x1_time_plot
})
output$x2_time <- renderPlot({
validate(
need(input$dates[2] >= input$dates[1], "")
)
x2_time_plot <- ggplot(filtered(), aes(x = date, y = X2)) +
geom_bar(stat = "identity")
theme_minimal()
x2_time_plot
})
}
shinyApp(ui, server)

Answer 1

You could use shinyjs and the show/hide method on all the inputIds that you want to hide or show or you can put all the boxes in a div with a class and use the hide/show with this class or assign a class directly to the fluidRows.
With both examples validate+need is not required anymore.
This example shows/hides the individual output IDs:
library(shiny)
library(shinydashboard)
library(tidyverse)
library(shinyjs)
## DATA ##################
random_data <- data.frame(replicate(2, sample(0:10, 1000, rep=TRUE)))
set.seed(1984)
random_data$date <- sample(seq(as.Date('2016-01-01'), as.Date(Sys.Date()), by = "day"), 1000)
sidebar <- dashboardSidebar(dateRangeInput(
"dates", label = h4("Date range"), start = '2016-01-01', end = Sys.Date(),
format = "dd-mm-yyyy", startview = "year", min = "2016-01-01", max = Sys.Date()
))
##################
## UI ##################
body <- dashboardBody(
useShinyjs(),
textOutput("selected_dates"),
br(),
fluidRow(
infoBoxOutput("total", width = 12)
),
fluidRow(
box(width = 12, solidHeader = TRUE,
title = "X1 over time",
plotOutput(outputId = "x1_time")
)
),
fluidRow(
box(width = 12, solidHeader = TRUE,
title = "X2 over time",
plotOutput(outputId = "x2_time")
)
)
)
ui <- dashboardPage(dashboardHeader(title = "Example"),
sidebar,
body
)
##################
server <- function(input, output) {
filtered <- reactive({
filtered_data <- random_data %>%
filter(date >= input$dates[1] & date <= input$dates[2])
return(filtered_data)
})
observe({
if (input$dates[2] < input$dates[1]) {
shinyjs::hide("total")
shinyjs::hide("x1_time")
shinyjs::hide("x2_time")
} else {
shinyjs::show("total")
shinyjs::show("x1_time")
shinyjs::show("x2_time")
}
})
output$total<- renderInfoBox({
infoBox(title = "Sample size",
value = nrow(filtered()),
icon = icon("binoculars"), color = "light-blue")
})
output$x1_time <- renderPlot({
x1_time_plot <- ggplot(filtered(), aes(x = date, y = X1)) +
geom_bar(stat = "identity")
theme_minimal()
x1_time_plot
})
output$x2_time <- renderPlot({
x2_time_plot <- ggplot(filtered(), aes(x = date, y = X2)) +
geom_bar(stat = "identity")
theme_minimal()
x2_time_plot
})
}
shinyApp(ui, server)
This example uses classes for the fluidRows, so this will hide the whole main page of the dashboard:
## UI ##################
body <- dashboardBody(
useShinyjs(),
textOutput("selected_dates"),
br(),
fluidRow(class ="rowhide",
infoBoxOutput("total", width = 12)
),
fluidRow(class ="rowhide",
box(width = 12, solidHeader = TRUE,
title = "X1 over time",
plotOutput(outputId = "x1_time")
)
),
fluidRow(class ="rowhide",
box(width = 12, solidHeader = TRUE,
title = "X2 over time",
plotOutput(outputId = "x2_time")
)
)
)
ui <- dashboardPage(dashboardHeader(title = "Example"),
sidebar,
body
)
##################
server <- function(input, output) {
filtered <- reactive({
filtered_data <- random_data %>%
filter(date >= input$dates[1] & date <= input$dates[2])
return(filtered_data)
})
observe({
if (input$dates[2] < input$dates[1]) {
shinyjs::hide(selector = ".rowhide")
} else {
shinyjs::show(selector = ".rowhide")
}
})
output$total<- renderInfoBox({
infoBox(title = "Sample size",
value = nrow(filtered()),
icon = icon("binoculars"), color = "light-blue")
})
output$x1_time <- renderPlot({
x1_time_plot <- ggplot(filtered(), aes(x = date, y = X1)) +
geom_bar(stat = "identity")
theme_minimal()
x1_time_plot
})
output$x2_time <- renderPlot({
x2_time_plot <- ggplot(filtered(), aes(x = date, y = X2)) +
geom_bar(stat = "identity")
theme_minimal()
x2_time_plot
})
}
shinyApp(ui, server)