RStudio Shiny список из проверки строк в dataTables

Я хотел бы иметь рабочий пример, подобный этому: 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 = ' ')
  })
})

Затем я попытался сделать это из другого примера, который использовал переключатели для повторной сортировки строк.

В моем измененном примере я хочу создать список идентификаторов из выбранных флажков в таблице dataTables, показанной на веб-странице. Например, выбирая некоторые строки из первых 5, я хочу, чтобы мое текстовое поле было: 1,3,4, соответствующее столбцу mymtcars$id, добавленному в mtcars. Затем я планирую связать действие со значениями текстового поля.

У меня есть это почти в этом примере, но при проверке ящиков не обновляется список в текстовом поле. В отличие от примера 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")
              )
      )
)

Ответ 1

Для первой проблемы вам понадобится версия dev 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

Ответ 2

Этот ответ оказался сломанным в блестящем 0.11.1, но его можно легко устранить. Вот обновление, которое сделало это (ссылка):

Добавлен аргумент escape в renderDataTable(), чтобы избежать элементов HTML   в таблице данных по соображениям безопасности. Это может привести к поломке таблиц с предыдущих   версии блестящих, которые используют исходный HTML в содержимом таблицы, а также старое поведение   может быть возвращено escape = FALSE, если вы знаете о безопасности   последствия. (# 627)

Таким образом, чтобы предыдущие решения работали, нужно указать escape = FALSE как опцию renderDataTable().

Ответ 3

Я сделал альтернативу для флажков в таблицах на основе предыдущего кода ответа и некоторой настройки JQuery/JavaScript.

Для тех, кто предпочитает фактические данные по номерам строк, я написал этот код, который извлекает данные из таблицы и показывает это как выбор. Вы можете отменить выбор, щелкнув еще раз. Он основывается на первых ответах, которые мне очень помогли (СПАСИБО), поэтому я хочу поделиться этим также.

Ему нужен объект сеанса, чтобы сохранить вектор (область охвата). Фактически вы можете получить любую необходимую информацию из таблицы, просто погрузитесь в JQuery и измените строку $row.find('td: nth-child (2)') (число - номер столбца). Мне нужна информация со второго но это зависит от вас. Цвета выбора немного нечетны, если вы также меняете количество видимых столбцов... цвета выбора, как правило, исчезают...

Надеюсь, это полезно, работает для меня (нужно оптимизировать, но сейчас нет времени)

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