RStudio闪亮的列表，来自于检查datatable中的行

I would like to have a working example similar to this: https://demo.shinyapps.io/029-row-selection/

我希望有一个类似的工作示例:https://demo.shinyapps.io/029- rowselection/。

I tried the example in my Shiny server running Shiny Server v1.1.0.10000, packageVersion: 0.10.0 and Node.js v0.10.21, but it is not working even if I load the js and css files from the website. It simply does not select rows from the table:

我在运行闪亮服务器v1.1.1.0.10000、packageVersion: 0.10.0和Node的闪亮服务器中尝试了这个示例。js v0.10.21，但是即使我从网站上加载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 = ' ')
  })
})

I then tried to do this from a different example that was using radio buttons to re-sort the rows.

然后我尝试从另一个使用单选按钮来重新排序行的例子中做这个。

In my modified example, I want to produce a list of ids from the selected checkbox buttons of the dataTables table shown in the webpage. E.g., selecting some rows from the first 5, I want my textbox to be: 1,3,4 corresponding to the mymtcars$id column I added to mtcars. I then plan to link an action to the values of the textbox.

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

I have it almost there in this example, but checking the boxes does not update the list in the textbox. Differently to the example shinyapp, I would like my checkboxes to keep the selection status if the table is resorted. This may be the tricky part, and I am not sure how to do it. I would also like to add a "Select/Unselect all" textbox on the top left corner of the table, that selects/unselects all boxes in the table. Any ideas?

在这个例子中，我几乎可以看到它，但是检查框不会更新文本框中的列表。与示例shinyapp不同的是，我希望我的复选框保留选择状态(如果诉诸表)。这可能是棘手的部分，我不知道该怎么做。我还想在表的左上角添加一个“Select/Unselect all”的文本框，它选择/Unselect表中的所有框。什么好主意吗?

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

3 个解决方案

#1

For the first problem you need the dev version of shiny and htmltools >= 0.2.6 installed:

对于第一个问题，您需要安装有光泽和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 = ' ')
  })
}
)
)

for your second example:

对于你的第二个示例:

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); 
    });
}")
  }
  )
)

#2

This answer has been rendered broken in shiny 0.11.1, but can easily be fixed. Here is the update that did it (link):

这个答案被渲染成闪亮的0.11.1，但是很容易修复。以下是做过的更新(链接):

Added an escape argument to renderDataTable() to escape the HTML entities in the data table for security reasons. This might break tables from previous versions of shiny that use raw HTML in the table content, and the old behavior can be brought back by escape = FALSE if you are aware of the security implications. (#627)

为renderDataTable()添加了一个转义参数，以便出于安全原因转义数据表中的HTML实体。这可能会破坏在表内容中使用原始HTML的以前版本的闪亮表，如果您知道安全性的含义，那么可以通过escape = FALSE返回旧的行为。(# 627)

Thus, to make the previous solutions work, one must specify escape = FALSE as an option to renderDataTable().

因此，要使以前的解决方案正常工作，必须指定escape = FALSE作为renderDataTable()的选项。

#3

I have made an alternative for check boxes in tables based on the previous Answer code and some tweaking of the JQuery / JavaScript.

我已经根据前面的答案代码和JQuery / JavaScript的一些调整，在表中选择了复选框。

For anyone who prefers actual data over row numbers i wrote this code that extracts data from the table and shows that as selection. You can deselect by clicking again. It builds on the former Answers that were very helpful to me (THANKS) so i want to share this as well.

对于任何喜欢实际数据而不喜欢行号的人，我编写了这段代码，它从表中提取数据并显示为选择。您可以通过单击再次取消选择。它建立在前一个对我很有帮助的答案之上(谢谢)，所以我也想分享这个。

It needs a session object to keep the vector alive (scoping). Actually you can get whatever information you want from the table, just dive into JQuery and change the $row.find('td:nth-child(2)') (number is the column number).I needed the info from the Second column but it is up to you. Selection colors is a bit odd if you also change the visible column amount.... selection colors tend to disappear...

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

I hope this is helpful, works for me (needs to be optimized but no time for that now)

我希望这对我很有帮助(需要优化但现在没有时间)

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/>")
    }
  }else{htmlTXT <- "please select from the table"}
  HTML(htmlTXT)
})