Shiny plots based on condition

Question

I'm a bit perplexed on this and have been searching and reading for the better part of the morning. Have tried a few things but can't seem to get it correct.

I'm attempting to make a shiny plot that creates a ggplot based on ui selected inputs.

Here's an example of what I'm working with:

library(tidyverse)
library(shiny)
library(shinyWidgets)

subject <- c("A", "A", "A", "B", "B", "B", "C", "C", "C", "D", "D", "D", "E", "E")
grp <- c(rep("One", times = 6), rep("Two", times = 8))
date <- c(rep(c("8/1/2020", "8/2/2020", "8/3/2020"), times = 4), "8/1/2020", "8/2/2020")
var <- round(rnorm(n = length(subject), mean = 0, sd = 2), 3)

df <- data.frame(subject, grp, date, var)
df$date <- as.Date(df$date, "%m/%d/%Y")

I define my ui based on the selections I want in order: Date, Group, Subject, with the option to plot multiple subjects:

UI

ui <- fluidPage(
  
  selectInput(inputId = "date",
              label = "date",
              choices = df %>% distinct(date) %>% pull(date),
              selected = min(df$date)),
  
  selectInput(inputId = "grp",
              label = "grp",
              choices = df %>% distinct(grp) %>% pull(grp),
              selected = "One"),
  
  selectizeInput(inputId = "subject",
              label = "subject",
              choices = df %>% distinct(subject) %>% pull(subject),
              multiple = T),
  
  plotOutput(outputId = "plt")
)

In my server I attempt to do two filters. The first filter is to get the date and group. the second is to then only select the subjects in the selected group. Unfortunately, shiny retains all subjects.

Server

server <- function(input, output){
  
  output1 <- reactive({
    d <- df %>%
      filter(date == input$date,
             (grp == input$grp))
    d
  })
  
  output2 <- reactive({
    d <- output1() %>%
      filter(grp == input$grp &
               subject %in% input$subject)
    d
  })
  
  output$plt <- renderPlot({
    d <- output2()
    
    plt <- d %>%
      ggplot(aes(x = subject, y = var)) +
      geom_col()
    
    plt
  })
  
}


shinyApp(ui, server)

I feel like what I have above is pretty straight forward but I can't sort out why it wont return what I want. Thanks.

Answer 1

Two things:

1. I think you're over-filtering in your two output* blocks. I'm inferring that output1 should be returning just the frame that has that date, and then make sure that the grp pull-down only includes the available groups; similarly for the second pull-down into subjects. For this, I'll simplify the filtering.

2. When you know which grps and subjects are available, updateSelectizeInput the applicable pull-down with the available choices. In order to do this, we'll also add session to the server definition.

Try this:

ui <- fluidPage(
  
  selectInput(inputId = "date",
              label = "date",
              choices = df %>% distinct(date) %>% pull(date),
              selected = min(df$date)),
  
  selectInput(inputId = "grp",
              label = "grp",
              choices = df %>% distinct(grp) %>% pull(grp),
              selected = "One"),
  
  selectizeInput(inputId = "subject",
              label = "subject",
              choices = df %>% distinct(subject) %>% pull(subject),
              multiple = T),
  
  plotOutput(outputId = "plt")
)

server <- function(input, output, session) {
  
  output1 <- reactive({
    d <- df %>%
      filter(date == input$date)
    updateSelectizeInput(session, "grp", choices = unique(d$grp))
    d
  })
  
  output2 <- reactive({
    d <- req(output1()) %>%
      filter(grp == input$grp)
    updateSelectizeInput(session, "subject", choices = unique(d$subject))
    d
  })
  
  output$plt <- renderPlot({
    d <- req(output2()) %>%
      filter(subject %in% input$subject)
    plt <- ggplot(d, aes(x = subject, y = var)) +
      geom_col()
    plt
  })
  
}

FYI: I also added calls to req, which prevent blocks from firing and completing when the inputs are invalid, missing, or just unstable. In smaller apps this generally doesn't happen, but if/when reactivity gets a bit big, it happens frequently enough. Even if it just happens spuriously, having req(...) may prevent a renderPlot from throwing an error temporarily/unnecessarily. (It certainly doesn't hurt anything.)