来自检查数据表中的行的 RStudio 闪亮列表

Posted 2023-05-07

【中文标题】来自检查数据表中的行的 RStudio 闪亮列表

【英文标题】：RStudio Shiny list from checking rows in dataTables

【发布时间】：2014-11-19 12:39:42

【问题描述】：

我想要一个类似这样的工作示例： https://demo.shinyapps.io/029-row-selection/

我在运行Shiny Server v1.1.0.10000、packageVersion: 0.10.0 和Node.js v0.10.21 的 Shiny 服务器中尝试了该示例，但即使我从网站加载 js 和 css 文件，它也无法正常工作。它根本不从表中选择行：

# ui.R
library(shiny)

shinyUI(fluidPage(
  title = 'Row selection in DataTables',
  tagList(
          singleton(tags$head(tags$script(src='//cdn.datatables.net/1.10.2/js/jquery.dataTables.js',type='text/javascript'))),
          singleton(tags$head(tags$script(src='//cdn.datatables.net/1.10.2/css/jquery.dataTables.min.css',type='text/css')))
        ),
  sidebarLayout(
    sidebarPanel(textOutput('rows_out')),
    mainPanel(dataTableOutput('tbl')),
    position = 'right'
  )
))

# server.R
library(shiny)

shinyServer(function(input, output) 
  output$tbl <- renderDataTable(
    mtcars,
    options = list(pageLength = 10),
    callback = "function(table) 
      table.on('click.dt', 'tr', function() 
        $(this).toggleClass('selected');
        Shiny.onInputChange('rows',
                            table.rows('.selected').indexes().toArray());
      );
    "
  )
  output$rows_out <- renderText(
    paste(c('You selected these rows on the page:', input$rows),
          collapse = ' ')
  )
)

然后我尝试从另一个使用单选按钮重新排序行的示例中执行此操作。

在我修改后的示例中，我想从网页中显示的 dataTables 表的选中复选框按钮中生成一个 id 列表。例如，从前 5 行中选择一些行，我希望我的文本框是：1,3,4 对应于我添加到 mtcars 的 mymtcars$id 列。然后我计划将一个动作链接到文本框的值。

在这个例子中我已经差不多了，但是选中这些框并不会更新文本框中的列表。与示例 Shinyapp 不同，如果表格被重新使用，我希望我的复选框保持选择状态。这可能是棘手的部分，我不知道该怎么做。我还想在表格的左上角添加一个“全选/取消全选”文本框，用于选择/取消选择表格中的所有框。有什么想法吗？

# server.R
library(shiny)

mymtcars = mtcars
mymtcars$id = 1:nrow(mtcars)

shinyServer(function(input, output, session) 

      rowSelect <- reactive(
        if (is.null(input[["row"]])) 
            paste(sort(unique(rep(0,nrow(mymtcars)))),sep=',')
         else 
            paste(sort(unique(input[["row"]])),sep=',')
        
      )

  observe(
      updateTextInput(session, "collection_txt",
        value = rowSelect()
        ,label = "Foo:"
      )
  )

      # sorted columns are colored now because CSS are attached to them
      output$mytable = renderDataTable(
              addCheckboxButtons <- paste0('<input type="checkbox" name="row', mymtcars$id, '" value="', mymtcars$id, '">',"")
                  #Display table with checkbox buttons
                  cbind(Pick=addCheckboxButtons, mymtcars[, input$show_vars, drop=FALSE])
          , options = list(bSortClasses = TRUE, aLengthMenu = c(5, 25, 50), iDisplayLength = 25))

)


# ui.R
library(shiny)

mymtcars = mtcars
mymtcars$id = 1:nrow(mtcars)

shinyUI(pageWithSidebar(
      headerPanel('Examples of DataTables'),
      sidebarPanel(
              checkboxGroupInput('show_vars', 'Columns to show:', names(mymtcars),
                                                        selected = names(mymtcars))
            ),
      mainPanel(
                         dataTableOutput("mytable")
      ,textInput("collection_txt",label="Foo")
              )
      )
)

【参考方案1】：

对于第一个问题，您需要安装 shiny 和 htmltools >= 0.2.6 的开发版本：

# devtools::install_github("rstudio/htmltools")
# devtools::install_github("rstudio/shiny")
library(shiny)
runApp(list(ui = fluidPage(
  title = 'Row selection in DataTables',
  sidebarLayout(
    sidebarPanel(textOutput('rows_out')),
    mainPanel(dataTableOutput('tbl')),
    position = 'right'
  )
)
, server = function(input, output) 
  output$tbl <- renderDataTable(
    mtcars,
    options = list(pageLength = 10),
    callback = "function(table) 
    table.on('click.dt', 'tr', function() 
    $(this).toggleClass('selected');
    Shiny.onInputChange('rows',
    table.rows('.selected').indexes().toArray());
    );
"
  )
  output$rows_out <- renderText(
    paste(c('You selected these rows on the page:', input$rows),
          collapse = ' ')
  )

)
)

第二个例子：

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))
      ,textInput("collection_txt",label="Foo")
    ),
    mainPanel(
      dataTableOutput("mytable")
    )
  )
  , server = function(input, output, session) 
    rowSelect <- reactive(
      paste(sort(unique(input[["rows"]])),sep=',')
    )
    observe(
      updateTextInput(session, "collection_txt", value = rowSelect() ,label = "Foo:" )
    )
    output$mytable = renderDataTable(
      addCheckboxButtons <- paste0('<input type="checkbox" name="row', mymtcars$id, '" value="', mymtcars$id, '">',"")
      #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)
    , 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); 
    );
")
  
  )
)

【讨论】：

我最终使用了第二个示例，它运行良好，无需更新我的软件。

input[["rows"]] 是所选行的值吗？因为我有一个类似的例子，我无法获取选中行的值。请澄清。

【参考方案2】：

This answer 在闪亮的 0.11.1 中已被破坏，但可以轻松修复。这是完成它的更新(link)：

向renderDataTable() 添加了escape 参数以转义HTML 实体 出于安全原因在数据表中。这可能会破坏以前的表格 在表格内容中使用原始 HTML 的闪亮版本，以及旧行为 如果您了解安全性，可以通过escape = FALSE 带回 影响。 (#627)

因此，要使之前的解决方案有效，必须将escape = FALSE 指定为renderDataTable() 的一个选项。

【讨论】：

给定的链接现在已损坏。我尝试按原样运行代码并使用escape = FALSE，但两次都得到Warning: Error in datatable: The 'callback' argument only accept a value returned from JS()。运行闪亮的 0.13.2。正在调查...

我已更新链接（他们将其从 NEWS 更改为 NEWS.md）。 Shiny 的 API 不断发展，我不再是活跃用户。我相信每个人都会欣赏你的调查结果。

【参考方案3】：

我已经根据之前的答案代码和 JQuery / JavaScript 的一些调整为表格中的复选框提供了替代方案。

对于那些更喜欢实际数据而不是行号的人，我编写了这段代码，它从表中提取数据并将其显示为选择。您可以通过再次单击取消选择。它建立在对我非常有帮助的以前的答案（谢谢）的基础上，所以我也想分享这个。

它需要一个会话对象来使向量保持活动状态（作用域）。实际上，您可以从表中获取所需的任何信息，只需深入 JQuery 并更改 $row.find('td:nth-child(2)') （数字是列号）。我需要来自第二个的信息列，但这取决于你。如果您还更改可见列数量，选择颜色会有点奇怪......选择颜色往往会消失......

我希望这对我有用（需要优化，但现在没有时间）

output$tbl <- renderDataTable(
  mtcars,
  options = list(pageLength = 6),
  callback = "function(table) 
  table.on('click.dt', 'tr', function() 

  if ( $(this).hasClass('selected') ) 
    $(this).removeClass('selected');
   else 
    table.$('tr.selected').removeClass('selected');
    $(this).addClass('selected');
  

  var $row = $(this).closest('tr'),       
    $tdsROW = $row.find('td'),
    $tdsUSER = $row.find('td:nth-child(2)');

  $.each($tdsROW, function()                
    console.log($(this).text());        
  );

  Shiny.onInputChange('rows',table.rows('.selected').indexes().toArray());
  Shiny.onInputChange('CELLselected',$tdsUSER.text());
  Shiny.onInputChange('ROWselected',$(this).text());

  );
  "
)

output$rows_out <- renderUI(
  infoROW <- input$rows
  if(length(input$CELLselected)>0)
    if(input$CELLselected %in%  session$SelectedCell)
      session$SelectedCell <- session$SelectedCell[session$SelectedCell != input$CELLselected]
    else
      session$SelectedCell <- append(session$SelectedCell,input$CELLselected)
    
  
  htmlTXT <- ""
  if(length(session$SelectedCell)>0)
    for(i in 1:length(session$SelectedCell))
      htmlTXT <- paste(htmlTXT,session$SelectedCell[i],sep="<br/>")
    
  elsehtmlTXT <- "please select from the table"
  HTML(htmlTXT)
)

【参考方案4】：

上面的答案已经过时了。我收到错误“数据表中的错误：‘回调’参数只接受从 JS() 返回的值”。

相反，This one 为我工作。