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()。