Persistent Selections Using DT and R Shiny

Question

I have a Shiny use case where I want to allow users to filter their data by selecting columns and seeing certain summary statistics. The idea is to allow them to quickly drill down to more granular groups and view the results. It works well except if a user makes a selection at a higher level, then all of the filters and selections are reset and need to be selected again. I've been having some trouble to make these filters persistent and only update in certain cases.

For example, a user wants to see the median incomes for Engineers (Level 1) in Switzerland and Germany (Level 2) and display that by age (Level 3). They would sort by the selectInput values above each table to choose the category then select the values in the table to include variables like "Engineer" as shown in the image below.

If they want to see how "Pilot" changes the results, the country filters will vanish. I'd like those to all remain in place and that's the part that has been giving me fits.

Any thoughts on how to address this? The code for this sample is as follows:

Server:

library(shiny)
library(DT)
library(plyr)
library(dplyr)

# Generate income data

n <- 1000
age <- sample(20:60, n, replace=TRUE)
sex <- sample(c("M", "F"), n, replace=TRUE)
country <- sample(c("US", "CA", "UK", "DE", "CH", "NL"), n, replace=TRUE)
occupation <- sample(c("Engineer", "Doctor", "Retail", "Pilot"), n, replace=TRUE)
income <- sample(20000:120000, n, replace=TRUE)

df <- data.frame(age, sex, country, income, occupation)
categories <- c("None", "age", "sex", "country", "occupation")

shinyServer(function(input, output, session) {

  output$selection_1 <- renderUI({
    selectInput("selection_1", "Level 1 Selection", selected = "None",
                choices = categories)
  })

  output$selection_2 <- renderUI({
    selectInput("selection_2", "Level 2 Selection", selected = "None",
                choices = categories)
  })

  output$selection_3 <- renderUI({
    selectInput("selection_3", "Level 3 Selection", selected = "None",
                choices = categories)
  })

  table_1 <- reactive({
    validate(
      need(input$selection_1 != "None", "Select a variable for aggregation.")
    )
    ddply(df, input$selection_1, summarize,
          Count = length(income),
          Med_Income = median(income))
    })

  output$table_1_agg <- DT::renderDataTable(
    table_1(),
    rownames = TRUE,
    selection = list(selected = "")
    )

  # Get values to match on subsequent tables
  table_1_vals <- reactive({
    table_1()[input$table_1_agg_rows_selected, 1]
  })

  # Filter table 2
  table_2 <- reactive({
    validate(
      need(input$selection_2 != "None", "Select a variable for aggregation.")
    )
    # Filter selected values from table_1
    if(length(table_1_vals())>0){
      sel_1_col <- grep(input$selection_1, names(df))
      df2 <- df[df[,sel_1_col] %in% table_1_vals(),]
    }else{
      df2 <- df
    }
    ddply(df2, input$selection_2, summarize,
          Count = length(income),
          Med_Income = median(income))
  })

  output$table_2_agg <- DT::renderDataTable(
    table_2(),
    rownames = TRUE,
    selection = list(selected = "")
  )

  # Get values to match on subsequent tables
  table_2_vals <- reactive({
    table_2()[input$table_2_agg_rows_selected, 1]
  })

  # Filter table 3
  table_3 <- reactive({
    validate(
      need(input$selection_3 != "None", "Select a variable for aggregation.")
    )
    df3 <- df
    # Filter selected values from table_1
    if(length(table_1_vals())>0){
      sel_1_col <- grep(input$selection_1, names(df))
      df3 <- df3[df3[,sel_1_col] %in% table_1_vals(),]
    }
    if(length(table_2_vals())>0){
        sel_2_col <- grep(input$selection_2, names(df))
        df3 <- df3[df3[,sel_2_col] %in% table_2_vals(),]
    }
    ddply(df3, input$selection_3, summarize,
          Count = length(income),
          Med_Income = median(income))
  })

  output$table_3_agg <- DT::renderDataTable(
    table_3(),
    rownames = TRUE,
    selection = list(selected = "")
  )
})

UI:

shinyUI(fluidPage(
  fluidRow(
    column(6,
           uiOutput("selection_1"),
           DT::dataTableOutput("table_1_agg")),
    column(6,
           uiOutput("selection_2"),
           DT::dataTableOutput("table_2_agg"))
  ),
  fluidRow(
    column(6,
           br(),
           uiOutput("selection_3"),
           DT::dataTableOutput("table_3_agg"))
  )
))

Thanks!

Answer 1

One option is to store the selected rows and use later at the moment of redrawing the table. That is possible using an additional renderUI to put the creation of the table and use the parameter selection to indicate what rows to select.

library(shiny)
library(DT)
library(dplyr)
library(plyr)

# Generate income data

n <- 1000
age <- sample(20:60, n, replace=TRUE)
sex <- sample(c("M", "F"), n, replace=TRUE)
country <- sample(c("US", "CA", "UK", "DE", "CH", "NL"), n, replace=TRUE)
occupation <- sample(c("Engineer", "Doctor", "Retail", "Pilot"), n, replace=TRUE)
income <- sample(20000:120000, n, replace=TRUE)

df <- data.frame(age, sex, country, income, occupation)
categories <- c("None", "age", "sex", "country", "occupation")

ui <- shinyUI(fluidPage(
  fluidRow(
    column(6,
           uiOutput("selection_1"),
           DT::dataTableOutput("table_1_agg")),
    column(6,
           uiOutput("selection_2"),
           uiOutput("table_2_aggUI")
    )
  ),
  fluidRow(
    column(6,
           br(),
           uiOutput("selection_3"),
           uiOutput("table_3_aggUI")
    )
  )
))

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

  table2_selected <- NULL
  table3_selected <- NULL

  output$selection_1 <- renderUI({
    selectInput("selection_1", "Level 1 Selection", selected = "None",
                choices = categories)
  })

  output$selection_2 <- renderUI({
    selectInput("selection_2", "Level 2 Selection", selected = "None",
                choices = categories)
  })

  output$selection_3 <- renderUI({
    selectInput("selection_3", "Level 3 Selection", selected = "None",
                choices = categories)
  })

  table_1 <- reactive({
    validate(
      need(input$selection_1 != "None", "Select a variable for aggregation.")
    )
    ddply(df, input$selection_1, summarize,
          Count = length(income),
          Med_Income = median(income))
  })

  output$table_1_agg <- DT::renderDataTable(
    table_1(),
    rownames = TRUE,
    selection = list(selected = "")
  )

  # Get values to match on subsequent tables
  table_1_vals <- reactive({
    table_1()[input$table_1_agg_rows_selected, 1]
  })

  # Filter table 2
  table_2 <- reactive({
    validate(
      need(input$selection_2 != "None", "Select a variable for aggregation.")
    )
    # Filter selected values from table_1
    if(length(table_1_vals())>0){
      sel_1_col <- grep(input$selection_1, names(df))
      df2 <- df[df[,sel_1_col] %in% table_1_vals(),]
    }else{
      df2 <- df
    }
    ddply(df2, input$selection_2, summarize,
          Count = length(income),
          Med_Income = median(income))
  })


  output$table_2_aggUI <- renderUI({
    # to redraw UI if data on table_2() change
    table_2()
    output$table_2_agg <- DT::renderDataTable(
      isolate(table_2()),
      rownames = TRUE,
      selection = list(target = 'row', selected = table2_selected)
    )
    DT::dataTableOutput("table_2_agg")
  })

  # keep record of selected rows
  observeEvent(input$table_2_agg_rows_selected, {
    table2_selected <<- as.integer(input$table_2_agg_rows_selected)
    cat("Table 2 selected:", table2_selected, "\n")
  })

  # Get values to match on subsequent tables
  table_2_vals <- reactive({
    table_2()[input$table_2_agg_rows_selected, 1]
  })

  # Filter table 3
  table_3 <- reactive({
    validate(
      need(input$selection_3 != "None", "Select a variable for aggregation.")
    )
    df3 <- df
    # Filter selected values from table_1
    if(length(table_1_vals())>0){
      sel_1_col <- grep(input$selection_1, names(df))
      df3 <- df3[df3[,sel_1_col] %in% table_1_vals(),]
    }
    if(length(table_2_vals())>0){
      sel_2_col <- grep(input$selection_2, names(df))
      df3 <- df3[df3[,sel_2_col] %in% table_2_vals(),]
    }
    ddply(df3, input$selection_3, summarize,
          Count = length(income),
          Med_Income = median(income))
  })


  output$table_3_aggUI <- renderUI({
    # to redraw UI if data on table_3() change
    table_3()
    output$table_3_agg <- DT::renderDataTable(
      isolate(table_2()),
      rownames = TRUE,
      selection = list(target = 'row', selected = table3_selected)
    )
    DT::dataTableOutput("table_3_agg")
  })

  # keep record of selected rows
  observeEvent(input$table_3_agg_rows_selected, {
    table3_selected <<- as.integer(input$table_3_agg_rows_selected)
    cat("Table 3 selected:", table3_selected, "\n")
  })

})

shinyApp(ui = ui, server = server)

Answer 2

You could achieve this by adding the following functionality:

1. Initialise a temp reactive variable. At moment t0 this variable will start with values NULL or 0 but further it will capture temporarily the current selected rows and filter options of the tables before redrawing them

    prev_selections = reactiveValues(table2 = NULL, prev_rows_t2 = NULL, new_rows_t2 = NULL, filterop_t2 = 0, table3 = NULL, prev_rows_t3 = NULL, new_rows_t3 = NULL, filterop_t3 = 0) 

2. Because the rows that you select in Table N will filter down Table N+1,... you need to create a copy of the downstream tables before redrawing them. Use observeEvent to capture the tables and values of applied filters (below for Table 2)

    observeEvent(input$table_2_agg_rows_selected,{ prev_selections$table2 = table_2() prev_selections$filterop_t2 = input$selection_2 }) 

3. Create a second collection of observeEvent for each table to capture current selected rows before and after redrawing the table. This collection of observeEvent is to be triggered by row selection taking place in upstream tables (below for table 2)

    observeEvent({input$table_1_agg_rows_selected input$selection_2}, { prev_selections$prev_rows_t2 = isolate(prev_selections$table2[input$table_2_agg_rows_selected,][1]) prev_selections$new_rows_t2 = isolate(if ( input$selection_2 == prev_selections$filterop_t2 ) {which(table_2()[,1] %in% prev_selections$prev_rows_t2[,1])} else {NULL}) }) 

4. Use values from step 3 as input in the selection = list(selected = ) argument of DT::renderDataTable . Don't forget to call datatable from within DT::renderDataTable as per HubertL's answer here

Full code available below:

library(shiny)
library(DT)
library(plyr)
library(dplyr)

# Generate income data

n <- 1000
age <- sample(20:60, n, replace=TRUE)
sex <- sample(c("M", "F"), n, replace=TRUE)
country <- sample(c("US", "CA", "UK", "DE", "CH", "NL"), n, replace=TRUE)
occupation <- sample(c("Engineer", "Doctor", "Retail", "Pilot"), n, replace=TRUE)
income <- sample(20000:120000, n, replace=TRUE)

df <- data.frame(age, sex, country, income, occupation)
categories <- c("None", "age", "sex", "country", "occupation")

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

  output$selection_1 <- renderUI({
    selectInput("selection_1", "Level 1 Selection", selected = "None",
                choices = categories)
  })

  output$selection_2 <- renderUI({
    selectInput("selection_2", "Level 2 Selection", selected = "None",
                choices = categories)
  })

  output$selection_3 <- renderUI({
    selectInput("selection_3", "Level 3 Selection", selected = "None",
                choices = categories)
  })

  table_1 <- reactive({
    validate(
      need(input$selection_1 != "None", "Select a variable for aggregation.")
    )
    ddply(df, input$selection_1, summarize,
          Count = length(income),
          Med_Income = median(income))
  })

  output$table_1_agg <- DT::renderDataTable(
    table_1(),
    rownames = TRUE,
    selection = list(selected = "")
  )

  # Get values to match on subsequent tables
  table_1_vals <- reactive({
    table_1()[input$table_1_agg_rows_selected, 1]
  })

  # Filter table 2
  table_2 <- reactive({
    validate(
      need(input$selection_2 != "None", "Select a variable for aggregation.")
    )
    # Filter selected values from table_1
    if(length(table_1_vals())>0){
      sel_1_col <- grep(input$selection_1, names(df))
      df2 <- df[df[,sel_1_col] %in% table_1_vals(),]
    }else{
      df2 <- df
    }
    ddply(df2, input$selection_2, summarize,
          Count = length(income),
          Med_Income = median(income))
  })

  output$table_2_agg <- DT::renderDataTable(
    datatable(table_2(),
    rownames = TRUE,
    selection = list(target = 'row', selected = prev_selections$new_rows_t2))
  )

  # Get values to match on subsequent tables
  table_2_vals <- reactive({
    table_2()[input$table_2_agg_rows_selected, 1]
  })

  # Filter table 3
  table_3 <- reactive({
    validate(
      need(input$selection_3 != "None", "Select a variable for aggregation.")
    )
    df3 <- df
    # Filter selected values from table_1
    if(length(table_1_vals())>0){
      sel_1_col <- grep(input$selection_1, names(df))
      df3 <- df3[df3[,sel_1_col] %in% table_1_vals(),]
    }
    if(length(table_2_vals())>0){
      sel_2_col <- grep(input$selection_2, names(df))
      df3 <- df3[df3[,sel_2_col] %in% table_2_vals(),]
    }
    ddply(df3, input$selection_3, summarize,
          Count = length(income),
          Med_Income = median(income))
  })

  output$table_3_agg <- DT::renderDataTable(
    datatable(table_3(),
    rownames = TRUE,
    selection = list(target = 'row', selected = prev_selections$new_rows_t3))
  )


  ## Retain highlighted rows in temp variables and enable persistent filtering

  #initialize temp variables
  prev_selections = reactiveValues(table2 = NULL, prev_rows_t2 = NULL, new_rows_t2 = NULL, filterop_t2 = 0,
                                   table3 = NULL, prev_rows_t3 = NULL, new_rows_t3 = NULL, filterop_t3 = 0)

  #Capture current selections/highlights in Table N
  observeEvent(input$table_2_agg_rows_selected, 
               {
                 prev_selections$table2 = table_2()
                 prev_selections$filterop_t2 = input$selection_2
               })

  observeEvent(input$table_3_agg_rows_selected, 
               {
                 prev_selections$table3 = table_3()
                 prev_selections$filterop_t3 = input$selection_3
               })

  #Observe upstream events (e.g. highlights in Table N-1,...) and enable persistent selection
  #Table 2
  observeEvent({input$table_1_agg_rows_selected
    input$selection_2}, 
    {
      prev_selections$prev_rows_t2 = isolate(prev_selections$table2[input$table_2_agg_rows_selected,][1])
      prev_selections$new_rows_t2 = isolate(if ( input$selection_2 == prev_selections$filterop_t2 ) 
      {which(table_2()[,1] %in% prev_selections$prev_rows_t2[,1])} else {NULL})

    })

  #Table 3
  observeEvent({
    input$table_1_agg_rows_selected
    input$table_2_agg_rows_selected
    input$selection_3
  }, 
  {
    prev_selections$prev_rows_t3 = isolate(prev_selections$table3[input$table_3_agg_rows_selected,][1])
    prev_selections$new_rows_t3 = isolate(if ( input$selection_3 == prev_selections$filterop_t3 ) 
    {which(table_3()[,1] %in% prev_selections$prev_rows_t3[,1])} else {NULL})

  })


})


ui <- shinyUI(fluidPage(
  fluidRow(
    column(6,
           uiOutput("selection_1"),
           DT::dataTableOutput("table_1_agg")),
    column(6,
           uiOutput("selection_2"),
           DT::dataTableOutput("table_2_agg"))
  ),
  fluidRow(
    column(6,
           br(),
           uiOutput("selection_3"),
           DT::dataTableOutput("table_3_agg"))
  )
))

shinyApp(ui = ui, server = server)