RStudio Shiny lista sprawdzanie wierszy w DataTables

Question

chciałbym mieć pracy przykład podobny do tego: https://demo.shinyapps.io/029-row-selection/

Próbowałem przykład w moim Shiny serwer działa Shiny Server v1.1.0.10000, packageVersion: 0.10.0 i Node.js v0.10.21, ale to nie działa nawet jeśli załaduję pliki js i css ze strony internetowej. To po prostu nie wybiera wiersze z tabeli:

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

Potem starał się zrobić to z innego przykładu, który został przy użyciu przycisków radiowych do ponownego sortowania wierszy.

W moim zmodyfikowanym przykładzie chcę utworzyć listę identyfikatorów z zaznaczonych pól wyboru w tabeli tabeli danych widocznej na stronie. Np. Wybierając kilka wierszy z pierwszych 5, chcę, aby mój tekst był: 1,3,4 odpowiadający kolumnie mymtcars$id dodanej do mtcars. Następnie planuję powiązać akcję z wartościami pola tekstowego.

Mam go prawie w tym przykładzie, ale zaznaczenie pól nie powoduje aktualizacji listy w polu tekstowym. W przeciwieństwie do przykładu shinyapp, chciałbym, aby moje checkboxy zachowały status wyboru, jeśli tabela zostanie wykorzystana. Może to być trudna część i nie jestem pewien, jak to zrobić. Chciałbym również dodać pole tekstowe "Wybierz/Anuluj wszystkie" w lewym górnym rogu tabeli, które zaznacza/odznacza wszystkie pola w tabeli. Jakieś pomysły?

# 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

Dla pierwszego problemu trzeba wersję dev shiny i htmltools >= 0.2.6 zainstalowane:

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

za drugim przykładzie:

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

zrobiłem alternatywę dla pól wyboru w tabeli na podstawie poprzedniego kodu odpowiedzi i pewnego szczypanie jQuery/JavaScript.

Dla każdego, kto woli faktyczne dane niż numery wierszy, napisałem ten kod, który wyodrębnia dane z tabeli i pokazuje je jako wybór. Możesz odznaczyć klikając ponownie. Opiera się na poprzednich odpowiedziach, które były dla mnie bardzo pomocne (DZIĘKI), więc chcę się tym również podzielić.

Potrzebuje obiektu sesji, aby utrzymać wektor przy życiu (zakres). Właściwie możesz uzyskać dowolne informacje z tabeli, po prostu zanurkuj w JQuery i zmień $ row.find ('td: nth-child (2)') (numer jest numerem kolumny). Potrzebowałem informacji z drugiego kolumna, ale to zależy od ciebie. Wybór kolorów jest nieco dziwny, jeśli zmienisz również widoczną kwotę kolumny ... kolory wyborów zwykle znikają ...

Mam nadzieję, że to jest pomocne, działa dla mnie (musi być zoptymalizowane, ale nie ma na to czasu)

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 nadano przerwane błyszczące 0.11.1, ale może być łatwo ustalony.Oto aktualizacja że zrobił to (link):

Dodano escape argument renderDataTable() uciec podmioty HTML w tabeli danych ze względów bezpieczeństwa. Może to uszkodzić tabele z poprzednich wersji błyszczących, które używają surowego HTML w treści tabeli, a stare zachowanie może zostać przywrócone przez escape = FALSE, jeśli wiesz o implikacjach związanych z bezpieczeństwem. (# 627)

Zatem, aby dotychczasowe rozwiązania działają, trzeba określić escape = FALSE jako opcja do renderDataTable().