更改输入后在数据表上保持选中框

Question

我想在我闪亮的应用程序中实现复选框；但是，我面临两个问题：

1. 对列重新排序后，对数据表的任何检查都会消失（例如，尝试按

   mpg

   对表进行排序）
2. 删除列后，数据表上的任何检查都会消失（例如，取消选中

   Columns to show:

   中的框）

这是我的虚拟示例（它是来自这个答案的代码的修改版本）：

library(shiny)
TABLE = mtcars
TABLE$id = 1:nrow(mtcars)
APP <- list()

APP$ui <- pageWithSidebar(
    headerPanel(NULL),
    sidebarPanel(
        checkboxGroupInput("show_vars", "Columns to show:", 
                           names(TABLE), selected = names(TABLE))
    ),
    mainPanel(
        dataTableOutput("resultTABLE")
    )
)
APP$server <- function(input, output, session) {

    output$resultTABLE = renderDataTable({
        addCheckboxButtons <- paste0('<input type="checkbox" name="row', 
                                     TABLE$id, '" value="', TABLE$id, '">',"")
        cbind(Pick = addCheckboxButtons, TABLE[, input$show_vars, drop = FALSE])
    }, escape = FALSE)
}

runApp(APP)

APP

有效，但为了全面实施，我需要解决问题 1 和 2。

Answer 1

根据您问题中提供的SO答案：

library(shiny)
mymtcars = mtcars
mymtcars$id = 1:nrow(mtcars)
runApp(
  list(ui = pageWithSidebar(
    headerPanel('Examples of DataTables'),
    sidebarPanel(
      checkboxGroupInput('show_vars', 'Columns to show:', names(mymtcars),
                         selected = names(mymtcars))
    ),
    mainPanel(
      dataTableOutput("mytable")
    )
  )
  , server = function(input, output, session) {

    strd<-reactiveValues(tr=0, slrows=character(length=nrow(mymtcars)))


    #preserve selected rows in a reactive element
    rowSelect <- reactive({
      input$rows
    })
    # use reactive value that's equal to 'checked' parameter for html code
    observe({
      strd$slrows<-ifelse(mymtcars$id %in% as.numeric(rowSelect()),'checked','' )
    })

    #use observer for column checkboxinput to detect first run
    observeEvent(input$show_vars, {
      strd$tr<-strd$tr+1
      print(strd$tr)
    }, ignoreNULL = TRUE)


    output$mytable = renderDataTable({
      #if first run - nothing is checked
      if (strd$tr==1){
        addCheckboxButtons <- paste0('<input type="checkbox" name="row', mymtcars$id, '" value="', mymtcars$id, '" >',"")

      } else{
        # add 'checked' parameter for html depending if id is present in selected rows reactive value
        addCheckboxButtons <- paste0('<input type="checkbox" name="row', mymtcars$id, '" value="', mymtcars$id,'" ',
                                     strd$slrows,'>',"")
      }
      #Display table with checkbox buttons
      (cbind(Pick=addCheckboxButtons, mymtcars[, input$show_vars, drop=FALSE]))
    }, options = list(orderClasses = TRUE, lengthMenu = c(5, 25, 50), pageLength = 25),
    escape=FALSE, callback = "function(table) {
    table.on('change.dt', 'tr td input:checkbox', function() {
    setTimeout(function () {
    Shiny.onInputChange('rows', $(this).add('tr td input:checkbox:checked').parent().siblings(':last-child').map(function() {
    return $(this).text();
    }).get())
    }, 10); 
    });
  }")
  }
  )
)

类似的 DT 方法：（效率更高一些，因为您不需要为每一行创建输入，因此它不会为每个反应值触发器重新创建表（即列和行刻度）。它仅重新创建表在列反应值触发器中，您还可以在按钮扩展中使用

colvis

，以便与纯DT解决方案相处

library(shiny)
library(DT)
mymtcars<-mtcars

shinyApp(
  ui = pageWithSidebar(
    headerPanel('Examples of DataTables'),
    sidebarPanel(
      checkboxGroupInput('show_vars', 'Columns to show:', names(mymtcars),
                         selected = names(mymtcars))
    ),
    mainPanel(
      verbatimTextOutput("selrows"),
      DT::dataTableOutput("mytable")
    )
  ),


  server = function(input, output) {

    strd<-reactiveValues(tr=0, slrows=c(0,0))

    observe({
      if(strd$tr==1){
        strd$slrows<-0
      } else  strd$slrows<-input$mytable_rows_selected
    })

    rowSelect <- reactive({
      input$mytable_rows_selected
    })

    observeEvent(input$show_vars, {
      strd$tr<-strd$tr+1
      print(strd$tr)
    }, ignoreNULL = TRUE)


    output$mytable = DT::renderDataTable({
      datatable(mymtcars[, input$show_vars, drop=F], rownames=FALSE,options = list(pageLength = 10),
                selection = list(mode='multiple', target='row',
                                 selected = strd$slrows)  )

    }
      )

    output$selrows<-renderPrint({
      input$mytable_rows_selected
    })
  }
)