RStudio从数据表检查排闪亮的列表

Question

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

我试过的例子在我闪亮的服务器上运行Shiny Server v1.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 = ' ') 
    }) 
}) 

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

以我变形例中，我想产生从在所述网页中示出的数据表表的所选择复选框按钮ID的列表。例如，从第5选择一些行，我希望我的文本框为：1,3,4对应mymtcars$id专栏中，我加入到mtcars。然后，我计划将一个操作链接到文本框的值。

我几乎没有在这个例子中，但检查框不更新在文本框中的列表。与示例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") 
      ) 
    ) 
) 

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

你的第二个例子：

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

Answer 2

我已经在基于以前的答案代码和JQuery的/ JavaScript代码一些调整表所做的复选框的选择。

对于任何人谁过行号更喜欢实际的数据我写了这个代码，从表中提取数据并显示，作为选择。您可以通过再次点击取消选择。它建立在对我非常有用的前答案上（感谢），所以我也想分享一下。

它需要一个会话对象，以保持载体活（作用域）。其实你可以从表中得到你想要的任何信息，只需要深入JQuery并改变$ row.find（'td：nth-​​child（2）'）（number是列号）。我需要从第二个专栏但它取决于你。选择颜色有点奇怪，如果你也改变可见列量....选择颜色趋于消失......

我希望这是有益的，对我的作品（有待优化，但没有时间，现在）

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 3

This answer已经闪亮0.11.1，但可以很容易地修复。下面是做到了(link)更新：

增加了一个escape参数renderDataTable()逃脱在数据表中的HTML实体 出于安全原因。这可能会破坏以前的 版本，这些版本在表格内容中使用原始HTML，并且如果您知道安全 的影响，则可以将旧行为 带回escape = FALSE。 （＃627）

因此，为了使以前的解决方案的工作，一个人必须指定escape = FALSE作为一个选项renderDataTable()。