R блестящие флажки DT в нескольких вкладках - PullRequest
Новая
       11

R блестящие флажки DT в нескольких вкладках

1 голос
/ 16 апреля 2019

Я работаю над задачей, аналогичной описанной в Блестящий список RStudio из проверки строк в dataTables и Shiny - флажок в таблице в виде блестящего - встраивание флажков в таблицу DT.

Мое приложение немного сложнее - там есть несколько вкладок, таблицу можно отфильтровать, а содержимое зависит от реактивных значений в других местах. Я смог установить флажки, работающие с небольшим JS, но обнаружил, что если у меня есть другая таблица DT на другой вкладке, целевая таблица не отображается вообще.

Ниже приведен минимальный пример, и если я закомментирую mytable1 в tab1UI, все в tab2 работает - таблицы на tab2 отображаются, флажки выводят значение, а mytable2 может быть отфильтрован по входным значениям. При наличии таблицы tab1 отображаются только заголовки tab2, без таблиц. Кроме того, размещение tab2 перед tab1 отображает таблицу tab2 как обычно. Ни один из этих обходных путей не является допустимым вариантом - кто-нибудь знает, в чем может быть проблема? Скорее всего, проблема заключается в фрагментах javascript, я думаю, но не знаю, как это исправить. 

# 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)
...