Cascading Dropdowns

[Timmwardion]

Hey @jrowen. Firstly, thanks for the amazing package.

Secondly. I'm looking for examples of connected dropdowns using rhandsontable, where the dropdowns in column b change as column a changes. I've looked far as wide but there doesn't seem to be any examples I can find of functions in the source parameter of hot_cols or anyone using any kind of reactive function to change the source list.

[jrowen]

You could probably do this in shiny, updating the column factors on each change. It may be possible to do this via JS, but I'm not sure how that would work with the existing R code.

[Timmwardion]

Thanks @jrowen . Here is a minimal shiny app I've been playing around with, trying to do just that, pull in an updated column source on each change given the selected row.

The intent of this code is to switch the source list in column B depending on the value of column A. I've got it validating if you manually enter a value from listB (at least it seems that way) but I've been unsuccessful in actually making the dropdown appear. It seems like the source for each column is called once and cached. I'm wondering if there is any way to force the reload of the source lists?

EDIT: I've now been successful at making a dynamically generated dropdown appear but the problem seems to be that the source is not called on the first select of the dropdown (it will appear on the second if another row is selected before the second selection (confusing I know) see below. I know I can work on the logic below to make a non-default list appear, but that won't get around the issue with the first click.

library(shiny)
library(rhandsontable)

cmt<-function(term){
  if (is.data.frame(term)||is.matrix(term)||is.vector(term)||is.list(term)){
    print("term is data.frame, matrix, list, or vector")
    print(paste(deparse(substitute(term)),"->"))
    print(term)
  } else{
    print(paste(deparse(substitute(term)),"->",term))  
  }

}


ui <- fluidPage(headerPanel("CX Tracker - Data Engine"),

                             fluidPage(
                               column(6,

                                        p(uiOutput("Table"))

                               )))



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



  op <- reactiveValues(data = NULL) #reactive output


  observe({
    print("observe Triggered")
    if (!is.null(input$hot)) {
      op$df <- hot_to_r(input$hot)

      newVal<-input$hot$changes$changes[[1]][[4]]
      row<-input$hot$changes$changes[[1]][[1]]+1
      col<-input$hot$changes$changes[[1]][[2]]+1

      op$row<-row
      op$col<-col

      if (col==1&&nchar(newVal>0)){

        dim<-paste("r",row,sep="")

        if (newVal=="BBB"){
          rspnss<-unique(op$lstB)
          op$select[dim]<-data.frame(rspnss)
          } else if (newVal=="CCC"){
          rspnss<-unique(op$lstC)
          op$select[dim]<-data.frame(rspnss)
        }
      }
    }
  })

  df<-reactive({
    print("df reactive Triggered")
    if (is.null(op$df)) {
      colA<-c("","","","")
      colB<-c("","","","")
      colC<-c("","","","")
      lstA<-c("BBB","CCC","BBB","CCC")
      lstB<-c("B1","B2","B3","B4")
      lstC<-c("C1","C2","C3","C4")

      op$df<-data.frame(colA=colA,colB=colB,colC=colC)
      op$lstA<-lstA
      op$lstB<-lstB
      op$lstC<-lstC
      df<-op$df
    } else{
      df<-op$df
    }
  })

  sourceLst<-reactive({
    print("sourceLst Triggered")
    r<-input$hot_select$select$r
    newVal<-input$hot$changes$changes[[1]][[4]]
    row<-input$hot$changes$changes[[1]][[1]]+1
    col<-input$hot$changes$changes[[1]][[2]]+1
    cmt(r)
    cmt(newVal)
    cmt(row)
    cmt(col)

    if((!is.null(op$row))&&(!is.null(r))&&(r==op$row)){
      dim<-paste("r",r,sep="")

      if (col==1&&nchar(newVal>0)){
        if (newVal=="BBB"){
          rspnss<-unique(op$lstB)
          op$select[dim]<-data.frame(rspnss)
        } else if (newVal=="CCC"){
          rspnss<-unique(op$lstC)
          op$select[dim]<-data.frame(rspnss)
        }
      }
      list<-as.list(op$select[dim])
      source<-list
      return(source)
    } else {
      source<-as.list(c("default",Sys.time()))
      return(source)
    }

  })

  output$Table <- renderUI({

    output$hot<-renderRHandsontable({ 
      rhandsontable(df(),selectCallback=TRUE,readOnly=FALSE,useTypes = TRUE,width = 500) %>%
        hot_context_menu(allowRowEdit = TRUE, allowColEdit = FALSE) %>%
        hot_col(col = "colA", type = "dropdown", source = op$lstA) %>%
        hot_col(col = "colB", type = "dropdown", source = sourceLst(), strict=FALSE) %>%
        hot_col(col = "colC", type = "dropdown", source = sourceLst(), strict=FALSE)
    })
    rHandsontableOutput('hot')

  })
}

shinyApp(ui = ui, server = server)

[jrowen]

The table with default to dropdown cell types if the original column in the data.frame is a factor. The dropdown choices will be the factor levels. You set the factor levels by column, so you will only be able to customize the options by column.

[jrowen]

Please let me know if you have additional questions.

[samssann]

Could it be possible to add the type and source arguments to the hot_cell function? Now it only features readOnly and comments. Here is one JS implementation of this https://jsfiddle.net/handsoncode/1gtu29rn/.

[ismirsehregal]

@Timmwardion it's been some time but, however. I'm currently working on creating row dependant dropdowns with rhandsontable and here is a workaround I came up with to prevent users from beeing able to select items which should't be available for a specific row. I'm making only those dropdowns readable, which are currently selected (via readOnly):

library(shiny)
library(rhandsontable)

ui <- fluidPage(
  p(),
  rHandsontableOutput("hot", width = "100%", height = "100%")
)

server = function(input, output, session){
  
  DF <- data.frame("A" = as.integer(1:10), "B" = as.integer(NA))
  
  values <- reactiveValues(data = DF)
  
  observe({
    if(!is.null(input$hot)){
      values$data <- as.data.frame(hot_to_r(input$hot))
    }
  })    
  
  output$hot <- renderRHandsontable({
    
    myTable <- rhandsontable(values$data, width = 500, height = 500, selectCallback = TRUE) %>%
      hot_table(highlightCol = TRUE, highlightRow = TRUE, stretchH = "all") %>% 
      hot_col(col = "B", type = "dropdown", source = NULL, readOnly = TRUE, allowInvalid = FALSE)
    
    if(!is.null(input$hot_select$select$r) && !is.na(values$data$A[input$hot_select$select$r])){
      myTable <- hot_col(myTable, col = "B", type = "dropdown", source = c(0, seq_len(values$data$A[input$hot_select$select$r])), readOnly = TRUE) %>% hot_cell(input$hot_select$select$r, 2, readOnly = FALSE)
    }
    
    myTable
    
  })
  
}

shinyApp(ui, server)

I guess this logic can be transferred to cascading dropdowns.

[StevenLShafer]

Outstanding! That does the trick.
Thanks,
Steve

[rliehrv]

This is great @ismirsehregal , thanks for sharing! I noticed that for any individual row, if one fills A and B, then changes A, it is possible to have an "invalid" entry for B. (For example, in row 5, choose A=5 and B=5, then change A->4. Now you have A=4 and B=5, because B retains the original value.) How would I add functionality such that if you change A, the value in B simply deletes?

[ismirsehregal]

@rliehrv you need to repeat the logic check and apply it to the data.frame

Here is a modified example:

library(shiny)
library(rhandsontable)

ui <- fluidPage(
  p(),
  rHandsontableOutput("hot", width = "100%", height = "100%")
)

server = function(input, output, session){
  
  DF <- data.frame("A" = as.integer(1:10), "B" = as.integer(NA))
  
  values <- reactiveValues(data = DF)
  
  observe({
    if(!is.null(input$hot)){
      tmpData <- as.data.frame(hot_to_r(input$hot))
      tmpData[which(tmpData$B > tmpData$A), "B"] <- NA
      values$data <- tmpData
    }
  })    
  
  output$hot <- renderRHandsontable({
    myTable <- rhandsontable(values$data, width = 500, height = 500, selectCallback = TRUE) %>%
      hot_table(highlightCol = TRUE, highlightRow = TRUE, stretchH = "all") %>% 
      hot_col(col = "B", type = "dropdown", source = NULL, readOnly = TRUE, allowInvalid = FALSE)
    
    if(!is.null(input$hot_select$select$r) && !is.na(values$data$A[input$hot_select$select$r])){
      myTable <- hot_col(myTable, col = "B", type = "dropdown", source = c(0, seq_len(values$data$A[input$hot_select$select$r])), readOnly = TRUE) %>% hot_cell(input$hot_select$select$r, 2, readOnly = FALSE)
    }
    
    myTable
    
  })
  
}

shinyApp(ui, server)

PS: Here you can find another example on SO.

[rliehrv]

Perfect, thank you so much!

[jeffreyxparker]

Here's an example of multiple cascading dropdowns with the validation for those looking in the future. It removes selections if the something higher on the hierarchy is selected that does not include that dropdown selection. I love the generalized version below too!:

library(shiny)
library(rhandsontable)
library(usa)
library(tidyverse)

dropdown_options <- tibble(state.region, state.abb) %>%
  left_join(counties, by = c("state.abb" = "state")) %>%
  select(region = state.region, state = state.abb, county = name) %>%
  drop_na()

ui <- fluidPage(
  rHandsontableOutput("hot", width = "100%", height = "100%")
)

server = function(input, output, session){
  
  DF <- data.frame("region" = c("South", "Midwest","Northeast","West"),
                   "state" = as.character(NA),
                   "county" = as.character(NA))
  
  values <- reactiveValues(data = DF)
  
  observe({
    if(!is.null(input$hot)){
      tmpData <- as.data.frame(hot_to_r(input$hot))
      
      # Def more elegant way to do this validation
      for (i in seq_along(tmpData$region)) {
        
        # State validation
        region_selected <- tmpData[i,1]
        states_allow <- dropdown_options %>%
          filter(region == region_selected) %>%
          pull(state) %>%
          unique()
        if(!(tmpData[i,2] %in% states_allow)) tmpData[i,2] <- NA
        
        # County validation
        state_selected <- tmpData[i,2]
        county_allow <- dropdown_options %>%
          filter(state == state_selected) %>%
          pull(county) %>%
          unique()
        if(!(tmpData[i,3] %in% county_allow)) tmpData[i,3] <- NA
        
      }
      values$data <- tmpData
    }
  })    
  
  output$hot <- renderRHandsontable({
    
    region_options <- dropdown_options %>% pull(region) %>% unique()
    myTable <- rhandsontable(values$data, width = 500, height = 500, selectCallback = TRUE) %>%
      hot_table(highlightCol = TRUE, highlightRow = TRUE, stretchH = "all") %>%
      hot_col(col = "region", type = "dropdown", source = region_options, readOnly = NULL, allowInvalid = TRUE) %>%
      hot_col(col = "state", type = "dropdown", source = NULL, readOnly = TRUE, allowInvalid = FALSE) %>%
      hot_col(col = "county", type = "dropdown", source = NULL, readOnly = TRUE, allowInvalid = FALSE) 
    
    
    if(!is.null(input$hot_select$select$r)){
      
      # State options
      if(!is.na(values$data$region[input$hot_select$select$r])){
        
        selected_row_region <- values$data$region[input$hot_select$select$r]
        state_options <- dropdown_options %>% filter(region == selected_row_region) %>% pull(state) %>% unique()
        myTable <- hot_col(myTable,
                           col = "state",
                           type = "dropdown",
                           source = state_options,
                           readOnly = TRUE) %>% 
          hot_cell(input$hot_select$select$r, 2, readOnly = FALSE)
        
        # County options
        if(!is.na(values$data$state[input$hot_select$select$r])){
          selected_row_state <- values$data$state[input$hot_select$select$r]
          county_options <- dropdown_options %>% filter(state == selected_row_state) %>% pull(county) %>% unique()

          myTable <- hot_col(myTable,
                             col = "county",
                             type = "dropdown",
                             source = county_options,
                             readOnly = TRUE) %>%
          hot_cell(input$hot_select$select$r, 3, readOnly = FALSE)
          
        }
      }
    }
    
    myTable
    
  })
  
}

shinyApp(ui, server)

[ismirsehregal]

@jeffreyxparker sorry for the late reply.

I made a generalized data.table version (i'm not very familiar with the tidyverse) which let's you filter the data without a predefined order:

library(shiny)
library(rhandsontable)
library(data.table)
library(usa)

DT <- merge(merge(data.table("state_region" = as.character(state.region), "state" = state.abb), counties), zipcodes,  allow.cartesian = TRUE)
DT <- DT[sample(nrow(DT), 1000), ] # reduce data

emptyDT <- data.table(state_region = rep(NA_character_, 10), state = rep(NA_character_, 10), fips = rep(NA_character_, 10), 
                      name = rep(NA_character_, 10), zip = rep(NA_character_, 10), city = rep(NA_character_, 10), lat = NA_real_, 
                      long = NA_real_)

ui <- fluidPage(
  hr(),
  mainPanel(rHandsontableOutput("ExampleTable"))
)

server <- function(input, output, session) {
  
  displayRV <- reactiveVal(emptyDT)
  selectedRowRV <- reactiveVal(NULL)
  
  observeEvent(input$ExampleTable, {
    displayRV(hot_to_r(input$ExampleTable))
  })
  
  output$ExampleTable <- renderRHandsontable({
    rhandsontableObj <- rhandsontable(displayRV(), rowHeaders = NULL, stretchH = "all", selectCallback = TRUE, widisplayRVh = 300, height = 300, digits = 6)
    if(is.null(selectedRowRV())){
      for(col in names(displayRV())){
        rhandsontableObj <- hot_col(rhandsontableObj, col, allowInvalid = FALSE, type = "dropdown", source = c(NA_character_, sort(unique(DT[[col]]))), readOnly = FALSE)
      }
    } else {
      rowOptionsDT <- DT[selectedRowRV(), on = names(selectedRowRV())]
      for(col in names(displayRV())){
        rhandsontableObj <- hot_col(rhandsontableObj, col, allowInvalid = FALSE, type = "dropdown", source = c(NA_character_, sort(unique(rowOptionsDT[[col]]))), readOnly = TRUE) %>% hot_cell(row = input$ExampleTable_select$select$r, col = col, readOnly = FALSE)
      }
    }
    rhandsontableObj
  })
  
  observeEvent(input$ExampleTable, {
    selectedRowDT <- hot_to_r(input$ExampleTable)[input$ExampleTable_select$select$r,]
    if(nrow(selectedRowDT) > 0){
      selectedRowDT <- selectedRowDT[, which(unlist(lapply(selectedRowDT, function(x)!all(is.na(x))))), with = FALSE] # drop NA columns
      if(nrow(selectedRowDT) > 0){
        selectedRowRV(selectedRowDT)
      } else {
        selectedRowRV(NULL)
      }
    } else {
      selectedRowRV(NULL)
    }
  })
  
}

shinyApp(ui = ui, server = server)

However, this approach requires the user to explicitly deselect their choices before all options are displayed again.