Отформатировать вектор строк курсивом и красным шрифтом в R DT (с датой)

Question

Немного похоже на этот вопрос: Как придать цвет заданному интервалу строк таблицы DT?

но в моем случае я бы хотел, чтобы пользователь выбирал строки в таблице, затем по нажатию кнопки отменяет выбор строк и превращает ранее выделенные строки, которые теперь являются частью списка строк, представленных для удаления, серым цветом. шрифт (цвет: светло-серый) и курсивом. Это указывает на то, что они будут исключены из дальнейшего анализа. Во-вторых, кнопка отмены всего выбора должна изменить все строки обратно на обычный формат

Я дошел до того, что записал выбранные строки и добавил функцию отмены выбора, но затем изменил стиль строк перед их сбросом, ускользает от меня ...

Вывод, который я надеюсь достичь:

Не уверен, что это правильный подход, но я думал использовать оба values$selected_rows и values$removed_rows, где первый содержит выбор до его отправки, а удаленный содержит потенциально растущий список строк, выбранных для удаления, если пользователь решает удалить больше строк при другой передаче

removed_rows - это также список строк, которые необходимо стилизовать (выделены курсивом серым цветом)

library(shiny)
library(DT)


ui <- fluidPage(
    actionButton('SubmitRemoval', 'Exclude selected rows'),
    actionButton('UndoRemoval', 'Include full data'),
  verbatimTextOutput('Printresult'),
    DT::dataTableOutput('mytable')

)

server <- function(input, output,session) {

  values <- reactiveValues()

  observe({
    values$selected_rows <- input$mytable_rows_selected
  })


  observeEvent(input$SubmitRemoval, { 
        values$removed_rows <- c(values$removed_rows,input$mytable_rows_selected)


    dataTableProxy('mytable') %>% selectRows(NULL)
    values$selected_rows <- NULL
    removeTab("tabs", "mytable")
    })

  Remaining_mtcars <- reactive({ 
    req( values$removed_rows)
    mtcarsR <- mtcars[-c(values$removed_rows), ]
    mtcarsR
    })

  output$Printresult <- renderText({ nrow(Remaining_mtcars()) })

  observeEvent(input$UndoRemoval, {
    values$removed_rows <- NULL

    })

  output$mytable <- DT::renderDataTable({
    DT::datatable(mtcars,  
                  extensions = c('Buttons', 'ColReorder', 'FixedHeader', 'Scroller'),
                  options = list(pageLength = 25,
                                 selection = c('multiple'),
                                 dom = 'frtipB'
    )
  )
  })
}
runApp(list(ui = ui, server = server))

UPDATE @SL: Я пытался переместить ваши функции javascript для отправки и отмены внутри части DT :: JS () встроенных кнопок, но я не смог заставить ее работать. Я думаю, что я близко, но не знаю, где проблема.

Выходной код таблицы будет иметь следующую структуру:

 output[["mytable"]] <- renderDT({
    datatable(dat, 
              escape = -2, 
              extensions = c('Buttons', 'ColReorder', 'FixedHeader', 'Scroller'),
              callback = JS(callback),
              options = list(
                dom = 'frtipB',
                initComplete = JS(initComplete),
                rowId = JS(sprintf("function(data){return data[%d];}", ncol(dat))), 
                columnDefs = list(
                  list(visible = FALSE, targets = ncol(dat)),
                  list(className = "dt-center", targets = "_all")
                ),
                buttons = list('copy', 'csv',
                               list(
                                 extend = "collection",
                                 text = 'Deselect', 
                                 action = DT::JS("function ( e, dt, node, config ) {
                                       Shiny.setInputValue('SubmitRemoval', true, {priority: 'event'});
                                     }")
                                   ## move the submit javascript here
                                ),
                               list(
                                 extend = "collection",
                                 text = 'Restore', 
                                 action = DT::JS("function ( e, dt, node, config ) {
                                       Shiny.setInputValue('UndoRemoval', true, {priority: 'event'});
 ## move the undo removal javascript here
                                     }")
                               )
                )
              )
    )
  })

Answer 1

Вот лучшее решение (это заняло у меня несколько часов).Эта таблица не перерисовывает таблицу, когда кто-то нажимает кнопку, и не ошибается, когда таблица сортируется по столбцу.

library(shiny)
library(DT)

initComplete <- c(
  "function(settings) {",
  "  var table=settings.oInstance.api();", 
  "  $('#SubmitRemoval').on('click', function(){",
  "    table.$('tr.selected').addClass('x');",
  "  });",
  "  $('#UndoRemoval').on('click', function(){",
  "    table.$('tr').removeClass('x');",
  "  });",
  "}"
)

callback <- "
var xrows = [];
table.on('preDraw', function(e, settings) {
  var tbl = settings.oInstance.api();
  var nrows = tbl.rows().count();
  var rows = tbl.$('tr');
  var some = false; var r = 0;
  while(!some && r<nrows){
    if($(rows[r]).hasClass('x')){
      some = true
    }
    r++;
  }
  if(some){
    xrows = [];
    for(var i = 0; i < nrows; i++){
      if($(rows[i]).hasClass('x')){
        xrows.push(rows[i].getAttribute('id'));
      }
    }
  }
}).on('draw.dt', function(){
  for(var i=0; i<xrows.length; i++){
    var row = $('#' + xrows[i]);
    row.addClass('x');
  }
  xrows = [];
});
"

ui <- fluidPage(
  tags$head(
    tags$style(HTML(
      ".x { background-color: rgb(211,211,211) !important; font-style: italic}
       table.dataTable tr.selected.x td { background-color: rgb(211,211,211) !important;}"
    ))
  ),
  actionButton('SubmitRemoval', 'Exclude selected rows'),
  actionButton('UndoRemoval', 'Include full data'),
  br(),
  DTOutput('mytable')

)

server <- function(input, output,session) {

  dat <- cbind(mtcars[1:6,], id=1:6)

  output[["mytable"]] <- renderDT({
    datatable(dat, 
              callback = JS(callback),
              options = list(
                initComplete = JS(initComplete),
                rowId = JS(sprintf("function(a){return a[%d];}", ncol(dat))), 
                columnDefs = list(list(visible=FALSE, targets=ncol(dat)))
              )
    )
  })

  proxy <- dataTableProxy("mytable")

  observeEvent(input[["UndoRemoval"]], { 
    proxy %>% selectRows(NULL)
  })

}

shinyApp(ui, server)

Обновление

Вот версия с иконками:

library(shiny)
library(DT)

initComplete <- c(
  "function(settings) {",
  "  var table = settings.oInstance.api();", 
  "  var cross = '<span style=\"color:red; font-size:18px\"><i class=\"glyphicon glyphicon-remove\"></i></span>'",
  "  var checkmark = '<span style=\"color:red; font-size:18px\"><i class=\"glyphicon glyphicon-ok\"></i></span>'",
  "  $('#SubmitRemoval').on('click', function(){",
  "    table.$('tr.selected').addClass('x');",
  "    table.$('tr.selected')",
  "      .each(function(){$(this).find('td').eq(1).html(cross);});",
  "  });",
  "  $('#UndoRemoval').on('click', function(){",
  "    table.$('tr').removeClass('x');",
  "    table.$('tr')",
  "      .each(function(i){$(this).find('td').eq(1).html(checkmark);});",
  "  });",
  "}"
)

callback <- "
var cross = '<span style=\"color:red; font-size:18px\"><i class=\"glyphicon glyphicon-remove\"></i></span>'
var xrows = [];
table.on('preDraw', function(e, settings) {
  var tbl = settings.oInstance.api();
  var nrows = tbl.rows().count();
  var rows = tbl.$('tr');
  var some = false; var r = 0;
  while(!some && r<nrows){
    if($(rows[r]).hasClass('x')){
      some = true
    }
    r++;
  }
  if(some){
    xrows = [];
    for(var i = 0; i < nrows; i++){
      if($(rows[i]).hasClass('x')){
        xrows.push(rows[i].getAttribute('id'));
      }
    }
  }
}).on('draw.dt', function(){
  for(var i=0; i<xrows.length; i++){
    var row = $('#' + xrows[i]);
    row.addClass('x').find('td').eq(1).html(cross);
  }
  xrows = [];
});
"

ui <- fluidPage(
  tags$head(
    tags$style(HTML(
      ".x { background-color: rgb(211,211,211) !important; font-style: italic}
       table.dataTable tr.selected.x td { background-color: rgb(211,211,211) !important;}"
    ))
  ),
  actionButton('SubmitRemoval', 'Exclude selected rows'),
  actionButton('UndoRemoval', 'Include full data'),
  br(),
  DTOutput('mytable')

)

server <- function(input, output,session) {

  dat <- cbind(Selected = '<span style="color:red; font-size:18px"><i class="glyphicon glyphicon-ok"></i></span>', 
               mtcars[1:6,], id = 1:6)

  output[["mytable"]] <- renderDT({
    datatable(dat, 
              escape = -2, 
              callback = JS(callback),
              options = list(
                initComplete = JS(initComplete),
                rowId = JS(sprintf("function(data){return data[%d];}", ncol(dat))), 
                columnDefs = list(
                  list(visible = FALSE, targets = ncol(dat)),
                  list(className = "dt-center", targets = "_all")
                )
              )
    )
  })

  proxy <- dataTableProxy("mytable")

  observeEvent(input[["UndoRemoval"]], { 
    proxy %>% selectRows(NULL)
  })

}

shinyApp(ui, server)

Обновление

Получитьиндексы исключенных строк в input$excludedRows:

initComplete <- c(
  "function(settings) {",
  "  var table = settings.oInstance.api();", 
  "  var cross = '<span style=\"color:red; font-size:18px\"><i class=\"glyphicon glyphicon-remove\"></i></span>'",
  "  var checkmark = '<span style=\"color:red; font-size:18px\"><i class=\"glyphicon glyphicon-ok\"></i></span>'",
  "  $('#SubmitRemoval').on('click', function(){",
  "    table.$('tr.selected').addClass('x');",
  "    table.$('tr.selected')",
  "      .each(function(){$(this).find('td').eq(1).html(cross);});",
  "    var excludedRows = [];",
  "    table.$('tr').each(function(i, row){",
  "      if($(this).hasClass('x')){excludedRows.push(parseInt($(row).attr('id')));}",
  "    });",
  "    Shiny.setInputValue('excludedRows', excludedRows);",
  "  });",
  "  $('#UndoRemoval').on('click', function(){",
  "    table.$('tr').removeClass('x');",
  "    table.$('tr')",
  "      .each(function(i){$(this).find('td').eq(1).html(checkmark);});",
  "    Shiny.setInputValue('excludedRows', null);",
  "  });",
  "}"
)

Обновление

Это проще с опцией server = FALSE из renderDT:

library(shiny)
library(DT)

initComplete <- c(
  "function(settings) {",
  "  var table = settings.oInstance.api();", 
  "  $('#SubmitRemoval').on('click', function(){",
  "    table.$('tr.selected').addClass('x').each(function(){",
  "      var td = $(this).find('td').eq(1)[0];", 
  "      var cell = table.cell(td);", 
  "      cell.data('remove');",
  "    });",
  "    table.draw(false);",
  "    table.rows().deselect();",
  "    var excludedRows = [];",
  "    table.$('tr').each(function(i, row){",
  "      if($(this).hasClass('x')){excludedRows.push(parseInt($(row).attr('id')));}",
  "    });",
  "    Shiny.setInputValue('excludedRows', excludedRows);",
  "  });",
  "  $('#UndoRemoval').on('click', function(){",
  "    table.$('tr').removeClass('x').each(function(){",
  "      var td = $(this).find('td').eq(1)[0];", 
  "      var cell = table.cell(td);", 
  "      cell.data('ok');",
  "    });",
  "    Shiny.setInputValue('excludedRows', null);",
  "  });",
  "}"
)

render <- c(
  'function(data, type, row, meta){',
  '  if(type === "display"){',
  '    return "<span style=\\\"color:red; font-size:18px\\\"><i class=\\\"glyphicon glyphicon-" + data + "\\\"></i></span>";',
  '  } else {',
  '    return data;',
  '  }',
  '}'
)

ui <- fluidPage(
  tags$head(
    tags$style(HTML(
      ".x { color: rgb(211,211,211); font-style: italic; }"
    ))
  ),
  verbatimTextOutput("excludedRows"),
  actionButton('SubmitRemoval', 'Exclude selected rows'),
  actionButton('UndoRemoval', 'Include full data'),
  br(),
  DTOutput('mytable')
)

server <- function(input, output,session) {

  dat <- cbind(Selected = "ok", mtcars[1:6,], id = 1:6)

  output[["mytable"]] <- renderDT({
    datatable(dat, 
              extensions = "Select",
              options = list(
                initComplete = JS(initComplete),
                rowId = JS(sprintf("function(data){return data[%d];}", ncol(dat))), 
                columnDefs = list(
                  list(visible = FALSE, targets = ncol(dat)),
                  list(className = "dt-center", targets = "_all"),
                  list(
                    targets = 1,
                    render = JS(render)
                  ) 
                )
              )
    )
  }, server = FALSE)

  proxy <- dataTableProxy("mytable")

  observeEvent(input[["UndoRemoval"]], { 
    proxy %>% selectRows(NULL)
  })

  output$excludedRows <- renderPrint({
    input[["excludedRows"]]
  })

}

shinyApp(ui, server)

Answer 2

Вот вариант. Вместо того чтобы использовать кнопку, чтобы пометить выбранные строки как удаленные, пользователь нажимает на значки.

library(shiny)
library(DT)

callback <- c(
  "table.on('click', 'td:nth-child(2)', function(){",
  "  var td = this;",
  "  var cell = table.cell(td);",
  "  if(cell.data() === 'ok'){",
  "    cell.data('remove');",
  "  } else {",
  "    cell.data('ok');",
  "  }",
  "  var $row = $(td).closest('tr');",
  "  $row.toggleClass('excluded');",
  "  var excludedRows = [];",
  "  table.$('tr').each(function(i, row){",
  "    if($(this).hasClass('excluded')){",
  "      excludedRows.push(parseInt($(row).attr('id')));",
  "    }",
  "  });",
  "  Shiny.setInputValue('excludedRows', excludedRows);",
  "})"
)

restore <- c(
  "function(e, table, node, config) {",
  "  table.$('tr').removeClass('excluded').each(function(){",
  "    var td = $(this).find('td').eq(1)[0];", 
  "    var cell = table.cell(td);", 
  "    cell.data('ok');",
  "  });",
  "  Shiny.setInputValue('excludedRows', null);",
  "}"
)

render <- c(
  'function(data, type, row, meta){',
  '  if(type === "display"){',
  '    return "<span style=\\\"color:red; font-size:18px\\\"><i class=\\\"glyphicon glyphicon-" + data + "\\\"></i></span>";',
  '  } else {',
  '    return data;',
  '  }',
  '}'
)

ui <- fluidPage(
  tags$head(
    tags$style(HTML(
      ".excluded { color: rgb(211,211,211); font-style: italic; }"
    ))
  ),
  fluidRow(
    column(
      6, 
      tags$label("Excluded rows"),
      verbatimTextOutput("excludedRows")
    ),
    column(
      6, 
      tags$label("Included rows"),
      verbatimTextOutput("includedRows")
    )
  ),
  br(),
  DTOutput('mytable')
)

server <- function(input, output,session) {

  dat <- cbind(Selected = "ok", mtcars[1:6,], id = 1:6)

  output[["mytable"]] <- renderDT({
    datatable(dat, 
              extensions = c("Select", "Buttons"), 
              selection = "none", 
              callback = JS(callback),
              options = list(
                rowId = JS(sprintf("function(data){return data[%d];}", ncol(dat))), 
                columnDefs = list(
                  list(visible = FALSE, targets = ncol(dat)),
                  list(className = "dt-center", targets = "_all"),
                  list(className = "notselectable", targets = 1),
                  list(targets = 1, render = JS(render)) 
                ),
                dom = "Bt",
                buttons = list("copy", "csv",
                               list(
                                 extend = "collection",
                                 text = 'Select all rows', 
                                 action = JS(restore)
                               )
                ),
                select = list(style = "single", selector = "td:not(.notselectable)")
              )
    )
  }, server = FALSE)

    output$excludedRows <- renderPrint({
      input[["excludedRows"]]
    })

    output$includedRows <- renderPrint({
      setdiff(1:nrow(dat), input[["excludedRows"]])
    })

}

shinyApp(ui, server)

Answer 3

Вот попытка.

library(shiny)
library(DT)

rowCallback <- function(rows){
  c(
    "function(row, data, num, index){",
    sprintf("  var rows = [%s];", paste0(rows-1, collapse = ",")),
    "  if(rows.indexOf(index) > -1){",
    "    for(var i=1; i<data.length; i++){",
    "      $('td:eq('+i+')', row)",
    "        .css({'background-color': 'rgb(211,211,211)', 'font-style': 'italic'});",
    "    }",
    "  }",
    "}"  
  )
}

ui <- fluidPage(
  actionButton('SubmitRemoval', 'Exclude selected rows'),
  actionButton('UndoRemoval', 'Include full data'),
  br(),
  DTOutput('mytable')

)

server <- function(input, output,session) {

  output[["mytable"]] <- renderDT({
    input[["SubmitRemoval"]]
    input[["UndoRemoval"]]
    rows <- isolate(input[["mytable_rows_selected"]])
    datatable(mtcars, 
              options = list(
                rowCallback = JS(rowCallback(rows))
              )
    )
  })

  proxy <- dataTableProxy("mytable")

  observeEvent(input[["UndoRemoval"]], { 
    proxy %>% selectRows(NULL)
  })

}

shinyApp(ui, server)