Question

我想有一个类似于此的工作示例： 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不同，我希望我的复选框能够保留选择状态（如果使用该表）。这可能是棘手的部分，我不知道该怎么做。我还想在表格的左上角添加一个“选择/取消全选”文本框，用于选择/取消选择表格中的所有框。有什么想法吗？

enter image description here

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

Answer 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 = ' ')
  })
}
)
)

enter image description here

第二个例子：

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

enter image description here

Answer 2

This answer在闪亮的0.11.1中被破坏，但很容易修复。以下是执行(link)的更新：

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

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

Answer 3

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

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

它需要一个会话对象来保持向量的活动（范围）。实际上你可以从表中获得你想要的任何信息，只需深入了解JQuery并更改$ row.find（＆＃39; td：nth-child（2）＆＃39;）（数字是列号）.I需要第二栏中的信息，但这取决于你。如果您还更改可见列数量，选择颜色有点奇怪....选择颜色往往会消失......

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

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

Answer 4

以上答案已过时。我收到错误消息“数据表错误：'callback'参数仅接受从JS（）返回的值”。

相反，This one为我工作。

RStudio来自检查dataTables中的行的Shiny列表

4 个答案: