How can selectizeInput controls update each other?

Hello,

I'm trying to use selectizeInput for auto-filling a form with a dataframe.

Basically I'd like that depending in which field the user is typing, the other fields are updated.
If the user selects a city, the corresponding postcodes will appear in the postcode field choices. Once a postcode is selected, the locality field is updated. This is the easy part...

But how can I implement this behavior also for the other fields :
select postcode -> update city and update locality choices
select locality -> update postcode -> update city

knowing that :
1 city = 1 or many postcodes
1 postcode = 1 city
1 postcode = 1 or many localities
1 locality = 1 postcode

Thank you for your help.

data <- data.frame(city_name = c("CITY01","CITY06","CITY07","CITY08","CITY08","CITY08","CITY08","CITY09","CITY09","CITY10","CITY10","CITY10","CITY10","CITY10","CITY10","CITY10"),
                   postcode = c(47925,47931,47920,47919,47919,47922,47919,47940,47940,47900,47900,47900,47917,47917,47990,47990), 
                   locality = c("LOC00",NA,"LOC04","LOC06","LOC07","LOC08",NA,"LOC09",NA,"LOC11","LOC15","LOC20","LOC14","LOC17","LOC12","LOC13"))

ui <- shinyUI(fluidPage(
  titlePanel("Auto Fill"),
  sidebarPanel(
    selectizeInput("city_name", choices = data[order(data$city_name), 'city_name'], selected = NULL, label = NULL, options = list(
      plugins = list('restore_on_backspace'),
      onFocus = I("
                  function() {
                  this.clear();
                  }")
      )
      ),
    selectizeInput("postcode", choices = data$postcode, selected = NULL, label = NULL, options = list(
      plugins = list('restore_on_backspace')
    )
    ),
    selectizeInput("locality", choices = data$locality, selected = NULL, label = NULL, options = list(
      plugins = list('restore_on_backspace')
    )
    )
      )
  )
)

server <- shinyServer(function(input, output, session) {
  
  observe({
    cdp <- data[data$city_name == input$city_name, ]$postcode
    updateSelectInput(session, "postcode", choices = cdp[order(cdp)], selected = NULL)
  })
  
  observe({
    loc <- data[data$postcode == input$postcode, ]$loc
    updateSelectInput(session, "locality", choices = loc[order(loc)])
  })
  
})

shinyApp(ui = ui, server = server)

@jcheng recently made some experimental code (there's the gist and I also pasted it below) for something that seems very similar (inter-dependent selectInputs). It's quite a bit of code, but more there's lots of helpful comments :slight_smile:

I hope it leads to some insight!

library(shiny)

columnFilterUI <- function(id) {
  ns <- NS(id)
  uiOutput(ns("filter_container"))
}

columnFilter <- function(input, output, session, df, col_num, choice_filter) {
  # This renders a selectInput and only re-renders when the selected data
  # frame changes. (i.e. it doesn't re-render when filters change state.)
  output$filter_container <- renderUI({
    # Don't render if col_num is > actual number of cols
    req(col_num <= ncol(df()))
    
    freezeReactiveValue(input, "filter_value")
    selectInput(session$ns("filter_value"), names(df())[[col_num]],
      choices = sort(unique(df()[,col_num,drop=TRUE])),
      multiple = TRUE)
  })
  
  # When the other filters change, update this filter to remove rows that
  # are filtered out by the other filters' criteria. (We also add in the
  # currently selected values for this filter, so that changing other
  # filters does not cause this filter's selected values to be unselected;
  # while that behavior might make sense logically, it's a poor user
  # experience.)
  observeEvent(choice_filter(), {
    current_values <- input$filter_value
    
    updateSelectInput(session, "filter_value",
      choices = sort(unique(c(current_values, df()[choice_filter(),col_num,drop=TRUE]))),
      selected = current_values
    )
  })
  
  # Return a reactive that is a row index of selected rows, according to
  # just this filter. If this filter shouldn't be taken into account
  # because its col_num is too high, or if there are no values selected,
  # just return TRUE to accept all rows.
  reactive({
    if (col_num > ncol(df())) {
      TRUE
    } else if (!isTruthy(input$filter_value)) {
      TRUE
    } else {
      df()[,col_num,drop=TRUE] %in% input$filter_value
    }
  })
}

columnFilterSetUI <- function(id, maxcol, colwidth) {
  ns <- NS(id)
  
  fluidRow(
    lapply(1:maxcol, function(i) {
      column(colwidth,
        columnFilterUI(ns(paste0("col", i)))
      )
    })
  )
}

columnFilterSet <- function(input, output, session, df, maxcol) {
  
  # Each column filter needs to only display the choices that are
  # permitted after all the OTHER filters have had their say. But
  # each column filter must not take its own filter into account
  # (hence we do filter[-col], not filter, in the reactive below).
  create_choice_filter <- function(col) {
    reactive({
      filter_values <- lapply(filters[-col], do.call, args = list())
      Reduce(`&`, filter_values, TRUE)
    })
  }
  
  # filters is a list of reactive expressions, each of which is a
  # logical vector of rows to be selected.
  filters <- lapply(1:maxcol, function(i) {
    callModule(columnFilter, paste0("col", i), df, i, create_choice_filter(i))
  })
  
  reactive({
    # Unpack the list of reactive expressions to a list of logical vectors
    filter_values <- lapply(filters, do.call, args = list())
    # Combine all the logical vectors using & operator
    selected_rows <- Reduce(`&`, filter_values, TRUE)
    # Return the data frame, filtered by the selected rows
    df()[selected_rows,]
  })
}

ui <- fluidPage(
  selectInput("dataset", "Dataset", c("mtcars", "pressure", "cars"), selected = "mtcars"),
  columnFilterSetUI("filterset", maxcol = 4, colwidth = 3),
  DT::dataTableOutput("table")
)

server <- function(input, output, session) {
  selected_data <- reactive({
    get(input$dataset, "package:datasets")
  })
  
  filtered_data <- callModule(columnFilterSet, "filterset", df = selected_data, maxcol = 4)
  
  output$table <- DT::renderDataTable({ filtered_data() })
}

shinyApp(ui, server)
1 Like