three interdependent selectInput in R/Shiny application

Question

I'm working on a R/Shiny application and one of its features should be to export data based on some filters. However the filters depends on each other. Consider a list of companies, each companies has some teams or departments and these can be located in different countries. The user can filter the data to export through three drop-down menus (selectInput), but I would like that when one dimension (i.e. group) is selected the choices in the drop-down list for the other two dimensions (i.e. departments and countries) are updated accordingly. However filtering on a second dimension (i.e. departments) should narrow down the selection rather than updating all the selectInput's choices.

The code below is the closest I could get to the desired output. However there are two problems. First, filtering on a second dimension does not narrow down the selection, but updates also the choices for the first selected dimension. Second, even though the choices are updated the selection is not kept in the input field which remains blank.

Any idea how to approach this problem ?

Edit

The code below is almost working. Right now no matters which dimension is selected first, the choices for the remaining two dimensions are correctly updated and filtering on a second dimension does narrow down the selection. However, I'm not able to select more than one item per selectInput despite the multiple = TRUE.

Any idea on how to solve this problem ?

library(shiny)
library(dplyr)

## Create dataframe
group <- rep(toupper(letters[1:3]),each=3)
department <- c("a","b","c","a","b","d","b","c","d")
country <- c("IT","FR","DE","IT","DE","HU","HU","FR","FR")
df <- data.frame(group, department, country)


## Simple user interface with 3 selectInput
ui <- fluidPage(
  selectInput('group', 'Group:', df$group, multiple=TRUE, selectize=T),
  selectInput('dept', 'Department:', df$department, multiple=TRUE, selectize=T),
  selectInput('country', 'Country:', df$country, multiple=TRUE, selectize=T),
  tableOutput("table1")
)


filter_names <- c("input$group", "input$dept", "input$country")
filters <- c("group %in% input$group", "department %in% input$dept","country %in% input$country")
checknull <- NULL


server=function(input,output,session) {

  ## reactive block to update the choices in the select input fields
  choices <- reactive({
    for (i in seq_along(filter_names)) {
      checknull[i] <- eval(parse(text=paste0("!is.null(", filter_names[i], ")",sep="")))
    }

    req(filters[checknull])
    tmp <- eval(parse(text=paste0("filter(df, ", paste0(filters[checknull], collapse = " & "), ")")))
    return(tmp)
  })

  ## updateSelectInput
  observe({
    updateSelectInput(session,'group', choices=sort(unique(choices()$group)), selected = input$group)
    updateSelectInput(session,'dept', choices=sort(unique(choices()$department)), selected = input$dept)
    updateSelectInput(session,'country', choices=sort(unique(choices()$country)), selected = input$country)
  })

 output$table1 <- renderTable({df})
}

shinyApp(ui,server)

Answer 1

library(shiny)
library(tidyverse)

df <- data.frame(
  country = c("USA", "JAPAN", "USA", "USA", "USA", "USA", "USA", "JAPAN", "JAPAN", "JAPAN",
              "JAPAN", "JAPAN", "AUS", "AUS", "AUS", "AUS", "AUS", "CAN", "CAN", "CAN"),
  name = c("joe schmoe", "patty o'furniture", "joe schmoe", "joe schmoe","joe schmoe", "joe schmoe",
           "joe schmoe", "patty o'furniture", "patty o'furniture", "patty o'furniture", "patty o'furniture",
           "patty o'furniture", "aida bugg", "aida bugg", "aida bugg", "aida bugg", "aida bugg", "peg legge",
           "peg legge", "peg legge"),
  order_number = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20)
)

getChoices <- function(data, ..., include_empty = FALSE) {
  filters <- list(...)
  filters <- filters[lengths(filters) > 0]
  if (length(filters) > 0) {
    filters <- filters[sapply(filters, function(x)
      ! all(x == ""))]
  }
  choices <- vector("list", length(names(data)))
  names(choices) <- names(data)
  for (i in names(data)) {
    x <- data
    filters_sans_self <- filters[!names(filters) %in% i]
    for (j in names(filters_sans_self)) {
      x <- x %>% filter(!!as.symbol(j) %in% filters_sans_self[[j]])
    }
    if (include_empty) {
      choices[[i]] <- c("", sort(unique(x[[i]])))
    } else {
      choices[[i]] <- sort(unique(x[[i]]))
    }
  }
  choices
}

ui <- fluidPage(sidebarLayout(
  sidebarPanel(
    selectizeInput("country", "Country", choices = NULL, multiple = TRUE),
    selectizeInput("name", "Name", choices = NULL, multiple = TRUE),
    selectizeInput("ord", "Order Number", choices = NULL, multiple = TRUE)
  ),
  mainPanel(tableOutput("out"))
))

server <- function(input, output, session) {
  data <- reactiveVal(df)
  
  choices <- reactive({
    getChoices(data = data(),
               input$country,
               input$name,
               input$ord)
  })
  
  observe({
    updateSelectizeInput(
      inputId = "country",
      choices = choices()$country,
      selected = input$country
    )
    updateSelectizeInput(
      inputId = "name",
      choices = choices()$name,
      selected = input$name
    )
    updateSelectizeInput(
      inputId = "ord",
      choices = choices()$order_number,
      selected = input$ord
    )
  })
  
  filtered <- reactive({
    data <- data()
    if (!is.null(input$country) & !identical(input$country, "")) {
      data <- filter(data, country %in% input$country)
    }
    if (!is.null(input$name) & !identical(input$name, "")) {
      data <- filter(data, name %in% input$name)
    }
    if (!is.null(input$ord) & !identical(input$ord, "")) {
      data <- filter(data, order_number %in% input$ord)
    }
    data
  })
  
  output$out <- renderTable({
    filtered()
  })
  
}

shinyApp(ui, server)

Answer 2

I've been looking for a solution for a similar problem and came across this.

Thanks for the almost-working example! I just switched to selectizeInput and it seems to work for me. Does this meet your need if you are still looking into this?

One problem, though, is that there's no way of coming back and re-filter because the choices would have been gone. I added a reset filter button to get around that.

library(shiny)
library(dplyr)

## Create dataframe
group <- rep(toupper(letters[1:3]),each=3)
department <- c("a","b","c","a","b","d","b","c","d")
country <- c("IT","FR","DE","IT","DE","HU","HU","FR","FR")
df <- data.frame(group, department, country)


## Simple user interface with 3 selectInput
ui <- fluidPage(
  selectizeInput('group', 'Group:', df$group, selected=df$group, multiple=TRUE),
  selectizeInput('dept', 'Department:', df$department, selected=df$department, multiple=TRUE),
  selectizeInput('country', 'Country:', df$country, selected=df$country, multiple=TRUE),
  actionButton("reset_filters", "Reset filters"),
  tableOutput("table1")
)


filter_names <- c("input$group", "input$dept", "input$country")
filters <- c("group %in% input$group", "department %in% input$dept","country %in% input$country")
checknull <- NULL


server=function(input,output,session) {

  ## reactive block to update the choices in the select input fields
  choices <- reactive({
    for (i in seq_along(filter_names)) {
      checknull[i] <- eval(parse(text=paste0("!is.null(", filter_names[i], ")",sep="")))
    }

    req(filters[checknull])
    tmp <- eval(parse(text=paste0("filter(df, ", paste0(filters[checknull], collapse = " & "), ")")))
    return(tmp)
  })

  ## updateSelectInput
  observe({
    updateSelectizeInput(session,'group', choices=sort(unique(choices()$group)), selected=sort(unique(choices()$group)))
    updateSelectizeInput(session,'dept', choices=sort(unique(choices()$department)), selected=sort(unique(choices()$department)))
    updateSelectizeInput(session,'country', choices=sort(unique(choices()$country)), selected=sort(unique(choices()$country)))
  })

  ## reset filters
  observeEvent(input$reset_filters, {
    updateSelectizeInput(session,'group', choices=df$group, selected=df$group)
    updateSelectizeInput(session,'dept', choices=df$department, selected=df$department)
    updateSelectizeInput(session,'country', choices=df$country, selected=df$country)
  })

  output$table1 <- renderTable({choices()})
}

shinyApp(ui,server)