1

I am working on a task similar to those described in RStudio Shiny list from checking rows in dataTables and Shiny - checkbox in table in shiny - embedding checkboxes within a DT table.

My application is a little more complicated though - there are multiple tabs, the table can be filtered, and the content depends on reactive values elsewhere. I have been able to get the checkboxes working with a little JS, but have found if I have another DT table in another tab, the target table does not render at all.

A minimum example is given below, and if I comment out mytable1 in the tab1UI, everything in tab2 works - the tables on tab2 are rendered, checkboxes output a value, and mytable2 can be filtered by the values input. With the tab1 table present only the tab2 headers are rendered, no tables. Also, placing tab2 before tab1 renders the tab2 table as normal. Neither of these workarounds is a valid option though - anybody know what the problem could be? Most likely the problem would be the javascript snippets is my guess, but not sure how to fix it.

# Import required modules.
library(shiny)
library(shinyjs)
library(DT)

# Tab 1 UI code.
tab1UI <- function(id) {
  ns <- NS(id)
  tabPanel(
    "Tab 1",
    fluidRow(
      DT::dataTableOutput(ns('mytable1'))
    )
  )
}

# Tab 2 UI code.
tab2UI <- function(id) {
  ns <- NS(id)
  tabPanel(
    "Tab 2",
    fluidRow(
      uiOutput(ns('cars')),
      h2('The mtcars data'),
      DT::dataTableOutput(ns('mytable2')),
      h2("Selected"),
      tableOutput(ns("checked"))
    )
  )
}

# Tab 1 server code.
tab1Server <- function(input, output, session) {
  ns <- session$ns
  output$mytable1 <- DT::renderDataTable(
    datatable(data.frame(a=c(1, 2), b=c(3, 4)))
  )
}

# Tab 2 server code.
tab2Server <- function(input, output, session) {
  ns <- session$ns

  # Helper function for making checkboxes.
  shinyInput = function(FUN, len, id, ...) {
    inputs = character(len)
    for (i in seq_len(len)) {
      inputs[i] = as.character(FUN(ns(paste0(id, i)), label = NULL, ...))
    }
    inputs
  }

  output$cars <- renderUI({
    selectInput(
      ns("cars"),
      "",
      choices=row.names(mtcars),
      multiple = TRUE,
      selected=row.names(mtcars)
    )
  })

  # Update table records with selection.
  subsetData <- reactive({
    runjs("Shiny.unbindAll($('#tab2-mytable2').find('table').DataTable().table().node());")
    cars <- req(input$cars)
    sel <- mtcars[row.names(mtcars) %in% cars,]
    data.frame(sel, Favorite=shinyInput(checkboxInput,nrow(sel), "cbox_", width = 10))
  })

  # Datatable with checkboxes.
  output$mytable2 <- DT::renderDataTable(
    datatable(
      subsetData(),
      escape = FALSE,
      options = list(
        paging = FALSE,
        server = FALSE,
        preDrawCallback = JS('function() {Shiny.unbindAll(this.api().table().node()); }'),
        drawCallback = JS('function() {Shiny.bindAll(this.api().table().node()); }')
      )
    )
  )

  # Helper function for reading checkbox.
  shinyValue = function(id, len) {
    values <- unlist(lapply(seq_len(len), function(i) {
      value = input[[paste0(id, i)]]
      if (is.null(value)) NA else value
    }))
    return(values)
  }

  # Output read checkboxes.
  observe({
    len <- length(input$cars)
    output$checked <- renderTable({
      data.frame(selected=shinyValue("cbox_", len))
    })
  })
}

# Define UI for application.
ui <- fluidPage(
  useShinyjs(),
  navbarPage(
    'Title',
    tab1UI("tab1"),
    tab2UI("tab2")
  )
)

# Define server.
server <- function(input, output, session) {

  # Call tab1 server code.
  callModule(tab1Server, "tab1")

  # Call tab2 server code.
  callModule(tab2Server, "tab2")
}

# Run the application
shinyApp(ui = ui, server = server)
ssast
  • 779
  • 1
  • 8
  • 17
  • This seems to work if you remove the line `runjs("Shiny.unbindAll ......` and if you move the option `server = FALSE` to the `renderDataTable` function: `DT::renderDataTable({ ...... }, server = FALSE)`. – Stéphane Laurent Jun 06 '19 at 21:35
  • @StéphaneLaurent you are correct in that tab2$mytable2 renders as expected then, however, in this form, the checkboxes displayed in the table tab2$checked do no longer update after changing the selection in the "cars" selectInput - like they are "stuck" with the values of the initial checkboxes. The only solution I came up with was the runjs.. code, but I'm open to another way. – ssast Jun 07 '19 at 18:42
  • Indeed. Change `cars <- req(input$cars)` to `cars <- input$cars`, and move the line `runjs(......)` to an `observeEvent(input$cars,`. I don't understand but this works. – Stéphane Laurent Jun 07 '19 at 19:44
  • @StéphaneLaurent Yes, this does it! Many thanks, and if you consolidate the fixes to a full answer, I will gladly accept it as the solution. – ssast Jun 10 '19 at 16:35

0 Answers0