updateRadioButtons in R Shiny not triggering event

Question

I am writing an app where radioButtons should only appear when a certain selectInput is selected. That is working. Then they should further filter the dataset. But now I have the problem that when I choose a button, I get the error message

Listening on http://127.xxx:xxxx
Warning: Error in [[: subscript out of bounds
45: updateRadioButtons
44: [/Users/x/Desktop/R2/app.R#61].

Here is my code with an example dataframe.

tab <- sort(rep(c('typeA','typeB'), 500))
group <- sort(rep(c('AA', 'BB', 'CC', 'DD'), 250))
subgroup <- sort(rep(LETTERS[seq(from = 1, to = 10)], 100))
year <- rep(seq(1996,1999), 250)
relValue <- rnorm(1000, 10, 5)
df <- data.frame(tab, group, subgroup, year, relValue, stringsAsFactors = FALSE)

dfBackup <- df

library(shiny)
library(plotly)
library(ggplot2)
library(dplyr)

ui <- fluidPage(
  sidebarPanel(
    #uiOutput("selected_tab_UI")
    selectInput(inputId = 'selected_tab', label = 'tab', choices = '') ,
    #uiOutput("selected_subgroup_UI")
    selectInput(inputId = 'selected_subgroup', label = 'subgroup', choices = ''),
    #uiOutput("selected_group_UI")
    hr(),
    conditionalPanel(
      condition = "input.selected_tab != 'typeA'",
      radioButtons(inputId = 'selected_group', label = 'group', choices = '')
    )
  ),
  mainPanel(
    plotlyOutput("graph")
  )
)

server <- function(input, output, session){

  observe({
    updateSelectInput(session,
                      'selected_tab',
                      choices = df$tab)
  })

  observe({
    updateSelectInput(
      session,
      'selected_subgroup',
      choices = df %>%
        filter(tab == input$selected_tab) %>%
        select(subgroup) %>%
        arrange(subgroup) %>%
        .[[1]]
    )
  })

   observe({
     if (input$selected_tab != 'typeA'){
     updateRadioButtons(session,
                        'selected_group',
                        choices = df %>%
                        filter(group == input$selected_group) %>%
                        select(group) %>%
                        .[[1]]
                        )
     }
  })

  plotdata <- reactive({df[df$subgroup == input$selected_subgroup,]}) #df$group == input$selected_group & 

  output$graph <- renderPlotly({
    plotdata() %>%
      plot_ly %>%
      ggplot()+
      geom_bar(mapping = aes(x = year, y = relValue), stat = 'identity', position = 'dodge', fill = '#6cb6ff')
  })
}

shinyApp(ui,server)

Answer 1

So what happens here?

   choices = df %>%
   filter(group == input$selected_group) %>%
   select(group) %>%
   .[[1]]

You filter with an empty value which produces a data frame with nrow = 0 . The select statement will coerce your data.frame to a vector and you end up with a vector of length 0.

So you only want to your observer to trigger when the tab is not empty.

observe({
    if(is.null(input$selected_tab == FALSE))
    updateSelectInput(
        session,
        'selected_subgroup',
        choices = df %>%
            filter(tab == input$selected_tab) %>%
            select(subgroup) %>%
            arrange(subgroup) %>%
            .[[1]]
    )
})

I general I do not like this way of updating the UI this way, since it often leads to crashes. Are you familiar with server-side rendering with renderUI and uiOutput ? It is much to control what is and is not shown in the UI.

tab <- sort(rep(c('typeA','typeB'), 500))
group <- sort(rep(c('AA', 'BB', 'CC', 'DD'), 250))
subgroup <- sort(rep(LETTERS[seq(from = 1, to = 10)], 100))
year <- rep(seq(1996,1999), 250)
relValue <- rnorm(1000, 10, 5)
df <- data.frame(tab, group, subgroup, year, relValue, stringsAsFactors = FALSE)

dfBackup <- df


library(shiny)
library(plotly)
library(ggplot2)
library(dplyr)

ui <- fluidPage(
    sidebarPanel(
        #uiOutput("selected_tab_UI")
        selectInput(inputId = 'selected_tab', label = 'tab', choices = '') ,
        #uiOutput("selected_subgroup_UI")
        selectInput(inputId = 'selected_subgroup', label = 'subgroup', choices = ''),
        #uiOutput("selected_group_UI")
        hr(),
        conditionalPanel(
            condition = "input.selected_tab != 'typeA'",
            radioButtons(inputId = 'selected_group', label = 'group', choices = '')
        )
    ),
    mainPanel(
        plotlyOutput("graph")
    )
)

unique(df[df$tab == "typeA", ]$subgroup)
# unique(df[df$tab == "typeB", ]$subgroup)

server <- function(input, output, session){

    observe({
        updateSelectInput(session,
                          'selected_tab',
                          choices = unique(df$tab))
    })

    observeEvent(input$selected_tab, {
        req(input$selected_tab)

        updateSelectInput(
            session,
            'selected_subgroup',
            choices = unique(df[df$tab == input$selected_tab, ]$subgroup)
        )
    })



    observeEvent(c(input$selected_tab, input$selected_subgroup), {
        req(input$selected_tab)
        req(input$selected_subgroup)

        if (input$selected_tab != 'typeA'){
            updateRadioButtons(session,
                               'selected_group',
                               choices = unique(df[df$subgroup == input$selected_subgroup, ]$group)
            )
        }
    })

    plotdata <- reactive({df[df$subgroup == input$selected_subgroup,]}) #df$group == input$selected_group & 

    output$graph <- renderPlotly({
        plotdata() %>%
            plot_ly %>%
            ggplot()+
            geom_bar(mapping = aes(x = year, y = relValue), stat = 'identity', position = 'dodge', fill = '#6cb6ff')
    })
}

shinyApp(ui,server)

I mostly prefer observeEvent over observers, since these only trigger when the event gets actually triggered. Anyhow, take a look at renderUI :-)