Switching between reactive data sets of different formats with rhandsontable

Question

In this excellent question: Shiny: Switching reactive datasets with Rhandsontable and external parameters the data frames and the rhandsontable output have identical structures.

I am trying to solve a similar problem, but with datasets that do not have identical structures, and with datasets that are built up in nested lists. Consider this example with two input selectors:

There are four possible tables that can be produced, depending on the input selectors. They are:

Table 1 (list 1, "first"):

Table 2 (list 1, "second"):

Table 3 (list 2, "third"):

Table 4 (list 2, "fourth"):

Each table appears in the same spot through a renderRHandsontable element. I think my problem lies in updating the reactiveValue "values" - how do you update an element of a list and not any of the other elements? Here is a minimal example where the display is correct, but you cannot change any elements (the problem I am trying to solve).

require(rhandsontable)
require(shiny)

# Create some fake lists
list_1 <- list()
list_2 <- list()
list_1[['first']] <- data.frame(matrix(1:4,ncol=4))
list_1[['second']] <- data.frame(matrix(1:2,ncol=2),bool=factor('a1',levels=c('a1','a2','a3')))
list_2[['third']] <- data.frame(matrix(7:9,ncol=3))
list_2[['fourth']] <- data.frame(matrix(10:11,ncol=2),bool=factor('b1',levels=c('b1','b2')))

ui <- fluidPage(sidebarLayout(sidebarPanel(
  selectInput(
    'list_selector', 'Select list:',
    choices = c('list_1', 'list_2')
  ),
  uiOutput("second_selectorUI")
),
mainPanel(rHandsontableOutput("out"))))

server <- function(input, output) {

  values = reactiveValues()
  values[["list_1"]] <- list_1
  values[["list_2"]] <- list_2

  # Feed user input back to the list
  observe({
    if (!is.null(input$out)) {
      temp <- hot_to_r(input$out)
      if (isolate(input$list_selector) %in% c('first','third')){
        values[[isolate(input$list_selector)]][[isolate(input$list_selector)]] <- temp$values #Returns to wide format
      } else {
        values[[isolate(input$list_selector)]][[isolate(input$list_selector)]] <- temp
      }
    }
  })

  # Why isn't values[["list_1"]][[input$second_list_selector]] allowed?
  list <- reactive({
    if (input$list_selector == "list_1") {
      values[["list_1"]]
    } else if (input$list_selector == "list_2"){
      values[["list_2"]]
    }
  })

  output$second_selectorUI <- renderUI({
    if (input$list_selector == 'list_1'){
      selectInput(inputId = "second_list_selector", label="Select element 1", 
                  choices = c('first', 'second'))
    } else if (input$list_selector == 'list_2'){
      selectInput(inputId = "second_list_selector", label="Select element 2", 
                  choices = c('third', 'fourth'))
    }
  })

  output$out <- renderRHandsontable({
    if (!is.null(list()) && !is.null(input$second_list_selector)){
      if (input$second_list_selector %in% c('first','third')){
        df <- list()[[input$second_list_selector]]
        df <- data.frame(values=as.numeric(df)) #Turns into long format
        rhandsontable(df, stretchH = "all", rowHeaderWidth = 300, width=600)
      } else if (input$second_list_selector %in% c('second','fourth')){
        df <- list()[[input$second_list_selector]]
        rhandsontable(df, stretchH = "all", rowHeaderWidth = 50, height = 300,width=600) %>%
          hot_col("bool", allowInvalid = FALSE)
      }
    }
  })
}

shinyApp(ui = ui, server = server)

Answer 1

Here is a way:

ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      selectInput("sel_1", label = "Select list:", 
                  choices = c("list_1", "list_2")),
      selectInput("sel_2", label = "Select element 1",
                  choices = names(list_1))
    ),
    mainPanel(
      rHandsontableOutput("hot")
    )
  )
)

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

  list_1$first <- data.frame(values = as.numeric(list_1$first))
  list_2$third <- data.frame(values = as.numeric(list_2$third))

  values <- reactiveValues(list_1 = list_1, list_2 = list_2)

  observe({
    x <- input$sel_1
    label <- paste("Select element", substr(x, nchar(x) - 1, nchar(x)))
    updateSelectInput(session, "sel_2", label, 
                      choices = names(values[[x]]))
  })

  # Key part: storing back the data in `values` every time there is a change
  observe({
    if (!is.null(input$hot) && !is.null(input$hot$changes$changes)) 
      values[[isolate(input$sel_1)]][[isolate(input$sel_2)]] <- hot_to_r(input$hot)
  })

  output$hot <- renderRHandsontable({
      df <- values[[input$sel_1]][[input$sel_2]]
      if (is.null(df)) return(NULL)
      if (input$sel_2 %in% c("first", "third")) {
        rhandsontable(df, stretchH = "all", rowHeaderWidth = 300, width = 600)
      } else {
        rhandsontable(df, stretchH = "all", rowHeaderWidth = 50, height = 300, width = 600) %>%
          hot_col("bool", allowInvalid = FALSE)
      }
  })

}

Be careful with this answer though, because as I was writing it, I could still occasionally see weird unreproducible bugs like the wrong table being overwritten, I find reactivity very hard to control in the context of rhandsontable.