Format a vector of rows in italic and red font in R DT (datatable)

Question

A bit similar to this question: How to give color to a given interval of rows of a DT table?

but in my case I would like to let the user select rows in the table, th

Answer 1

Here is a better solution (it took me several hours). This one does not redraw the table when one clicks the button, and it doesn't go wrong when one sorts the table by a column.

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% selectRows(NULL)
  })

}

shinyApp(ui, server)

Update

Here is the version including icons:

library(shiny)
library(DT)

initComplete <- c(
  "function(settings) {",
  "  var table = settings.oInstance.api();", 
  "  var cross = ''",
  "  var checkmark = ''",
  "  $('#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 = ''
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% selectRows(NULL)
  })

}

shinyApp(ui, server)

Update

To get the indices of the excluded rows in input$excludedRows:

initComplete <- c(
  "function(settings) {",
  "  var table = settings.oInstance.api();", 
  "  var cross = ''",
  "  var checkmark = ''",
  "  $('#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);",
  "  });",
  "}"
)

Update

This is easier with the option server = FALSE of 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 "";',
  '  } 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)