Question

我正在执行类似于RStudio Shiny list from checking rows in dataTables和Shiny - checkbox in table in shiny中所述的任务-将复选框嵌入DT表中。

尽管，我的应用程序有点复杂-有多个选项卡，可以过滤表，并且内容取决于其他地方的反应性值。我已经能够使用一些JS启用复选框，但是发现如果我在另一个选项卡中有另一个DT表，则目标表根本不会呈现。

下面给出一个最小的示例，如果我在tab1UI中注释掉mytable1，则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)

多个标签中的R闪亮DT复选框

0 个答案: