in R, how to create multilevel radioGroupButtons, as each level depends choiceNames depend on the previous level input?

Question

I am trying to create shinyapp in which the first radioGroupButtons will automatically update the second level of radioGroupButtons and then the 3r

Answer 1

As @r2evans suggests one way to get this behavior is with uiOutput and renderUI. Here is a minimal app:

library(shiny)
library(shinyWidgets)
library(dplyr)

# make a data frame for choices

level1 <- LETTERS[1:3]
level2 <- 1:5

df <- expand.grid(level1, level2, stringsAsFactors = FALSE) %>% 
  mutate(Var2=paste(Var1, Var2)) %>% 
  arrange(Var1)

ui <- fluidPage(
  mainPanel(
    fluidRow(
      column(width = 3, "some space"),
      column(
        width = 9,
        align = "center",
        radioGroupButtons(
          inputId = "level1",
          label = "",
          status = "success",
          size = "lg",
          direction = "horizontal",
          justified = FALSE,
          width = "100%",
          individual = TRUE,
          checkIcon =  setNames(
            object = lapply(unique(df$Var1), function(x) icon("check")),
            nm = rep("yes", length(unique(df$Var1)))),
          choiceNames = unique(df$Var1),
          choiceValues = unique(df$Var1) 
        ),
        uiOutput("level2"),
        tags$hr(),
        dataTableOutput("tbl")
      )
    )
))

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

  # render the second level of buttons
  make_level <- reactive({

    df2 <- filter(df, Var1 %in% input$level1)

    radioGroupButtons(
      inputId = "level2",
      label = "",
      status = "primary",
      size = "lg",
      direction = "horizontal",
      justified = FALSE,
      width = "100%",
      individual = TRUE,
      checkIcon =  setNames(
        object = lapply(unique(df2$Var2), function(x) icon("check")),
        nm = rep("yes", length(unique(df2$Var2)))),
      choiceNames = as.list(unique(df2$Var2)),
      choiceValues = as.list(unique(df2$Var2))
    )
  })

  output$level2 <- renderUI({
    make_level()
  })

  output$tbl <- renderDataTable({
    df %>% filter(Var1 == req(input$level1), Var2 == req(input$level2))
  })

}

shinyApp(ui, server)

---

Another way to achieve this is with shiny modules. Here is an example of how that might look. This code is more concise, because the radio buttons are defined once as part of the module and then the module is called as necessary. Because dependency between levels, we still need renderUI in the module.

Code:

library(shiny)
library(shinyWidgets)
library(dplyr)

# make a data frame for choices

level1 <- LETTERS[1:3]
level2 <- 1:5

df <- expand.grid(level1, level2, stringsAsFactors = FALSE) %>%
  mutate(Var2 = paste(Var1, Var2)) %>%
  arrange(Var1)

buttons_ui <- function(id) {
  ns <- NS(id)
  uiOutput(ns("buttons"))
}

buttons_server <- function(input, output, session, button_names, button_status) {

  output$buttons <- renderUI({
    ns <- session$ns

    radioGroupButtons(
      inputId = ns("level"),
      label = "",
      status = button_status(),
      size = "lg",
      direction = "horizontal",
      justified = FALSE,
      width = "100%",
      individual = TRUE,
      checkIcon =  setNames(
        object = lapply(button_names(), function(x)
          icon("check")),
        nm = rep("yes", length(button_names()))
      ),
      choiceNames = button_names(),
      choiceValues = button_names()
    )
  })

  selected <- reactive({ 
    input$level
    })

  return(selected)
}

ui <- fluidPage(mainPanel(fluidRow(
  column(width = 3, "some space"),
  column(
    width = 9,
    align = "center",
    buttons_ui(id = "level1"),
    buttons_ui(id = "level2"),
    # buttons_ui(id = "level3"),
    # buttons_ui(id = "level4"),
    # and so on..
    tags$hr(),
    dataTableOutput("tbl")
  )
)))

server <- function(input, output, session) {
  selected1 <-
    callModule(module = buttons_server,
               id = "level1",
               button_names = reactive({ unique(df$Var1) }), 
               button_status = reactive({ "success"}) )

  selected2 <-
    callModule(
      module = buttons_server,
      id = "level2",
      button_names = reactive({ df %>% filter(Var1 == selected1() ) %>% pull(Var2) %>% unique }),
      button_status = reactive({ "primary" })
    )

  # add more calls to the module server as necessary

  output$tbl <- renderDataTable({
    df %>% filter(Var1 == req(selected1()), Var2 == req(selected2()))
  })
}

shinyApp(ui, server)

Answer 2

You can update choices dynamically in observeEvents, here's a demo:

# Data
dat <- data.frame(
  stringsAsFactors=FALSE,
  L3 = c(1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L),
  L2 = c("gum", "gum", "biscuits", "biscuits", "choc", "choc",
         "hotdrinks", "hotdrinks", "juices", "juices", "energydrinks",
         "energydrinks"),
  L1 = c("sweets", "sweets", "sweets", "sweets", "sweets", "sweets",
         "drinks", "drinks", "drinks", "drinks", "drinks", "drinks"),
  Price = c(23, 34, 23, 23, 54, 32, 45, 23, 12, 56, 76, 43),
  Quantity = c(10, 20, 26, 22, 51, 52, 45, 23, 12, 56, 76, 43),
  value = c("trident", "clortes", "loacker", "tuc",
            "aftereight", "lindt", "tea", "green tea", "orange",
            "mango", "powerhorse", "redbull")
)


# Packages
library(dplyr)
library(shiny)
library(shinyWidgets)


# App
ui <- fluidPage(
  tags$br(),

  # Custom CSS
  tags$style(
    ".btn-group {padding: 5px 10px 5px 10px;}",
    "#l1 .btn {background-color: #5b9bd5; color: #FFF;}",
    "#l2 .btn {background-color: #ed7d31; color: #FFF;}",
    "#value .btn {background-color: #ffd966; color: #FFF;}"
  ),


  tags$br(),
  fluidRow(
    column(
      width = 4,
      offset = 4,
      radioGroupButtons(
        inputId = "l1",
        label = NULL,
        choices = unique(dat$L1),
        justified = TRUE,
        checkIcon = list(
          "yes" = icon("check")
        ), 
        individual = TRUE
      ),
      radioGroupButtons(
        inputId = "l2",
        label = NULL,
        choices = unique(dat$L2),
        justified = TRUE,
        checkIcon = list(
          "yes" = icon("check")
        ), 
        individual = TRUE
      ),
      radioGroupButtons(
        inputId = "value",
        label = NULL,
        choices = unique(dat$value),
        justified = TRUE,
        checkIcon = list(
          "yes" = icon("check")
        ), 
        individual = TRUE
      ),
      tags$br(),
      DT::DTOutput("table")
    )
  )
)

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

  observeEvent(input$l1, {
    updateRadioGroupButtons(
      session = session,
      inputId = "l2",
      choices = dat %>% 
        filter(L1 == input$l1) %>%
        pull(L2) %>%
        unique,
      checkIcon = list(
        "yes" = icon("check")
      )
    )
  })

  observeEvent(input$l2, {
    updateRadioGroupButtons(
      session = session,
      inputId = "value",
      choices = dat %>% 
        filter(L1 == input$l1, L2 == input$l2) %>%
        pull(value) %>%
        unique,
      checkIcon = list(
        "yes" = icon("check")
      )
    )
  })

  output$table <- DT::renderDataTable({
    dat %>% 
      filter(L1 == input$l1, 
             L2 == input$l2,
             value == input$value)
  })

}

shinyApp(ui, server)

Result lokk like: