闪亮：更改输入后保持选中数据表上的框

Posted 2023-04-18

【中文标题】闪亮：更改输入后保持选中数据表上的框

【英文标题】：Shiny: keep boxes checked on datatable after changing inputs

【发布时间】：2018-01-03 19:43:49

【问题描述】：

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

在我对列重新排序后，对数据表的所有检查都会消失（例如，尝试通过 mpg 对表进行排序） 删除列后，对数据表的所有检查都会消失（例如，取消选中 Columns to show: 的复选框）

这是我的虚拟示例（它是来自 this SO answer 的代码的修改版本）：

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。

【参考方案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 方法：（效率更高一点，因为您不会为每一行创建输入，因此它不会为每个反应值触发器重新创建表（即列和行刻度）。它重新创建table only in column reactive value trigger. 您也可以在按钮扩展中使用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
    )
  
)

【讨论】：

Shiny 的 DT 库很好地使用了行选择，没有可能更有用的复选框。您还可以通过按钮扩展使用 colvis 过滤器，总体而言代码会更加高效，所以如果复选框不是必须的，最好看看。

1) 小备注：library(data.table) 应该加。 2）仅供参考运行您的代码我收到错误：The 'callback' argument only accept a value returned from JS()on R 3.4.0，闪亮的 1.0.3。 （背景信息：我昨天也处理了这个问题，并且有一个非常相似的代码，没有超时 fct（什么为我解决了错误）。最后一个问题是对我来说，表格更新了复选框，然后又回到了初始状态（所以删除选定的排序），....也许这与你的 data.table 方法是固定的）

@BigDataScientist 如果使用 DT 库会出现错误。您应该分离 DT 包以运行此代码。正如我在 cmets 中提到的，代码基于问题代码，即没有 DT 选项。然而，使用 DT 和它的行选择选项会更有效，尽管出于某种原因显示 GUI 复选框可能会更好。

澄清一下：JS() 函数来自 DT 库，当您添加一些回调函数时 - 所有 javascript 代码都必须在 JS() 中。在基本的闪亮数据表输出中你不使用它，基本闪亮也没有JS function()。

有趣。感谢您的提示。如果你运行你的第一个代码会发生什么。将mpg列排序为“递增”，点击前两个复选框，将排序切换为“递减”，然后返回“递增”？对我来说，这些盒子不再“检查”了，...