shiny - 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, then on click of a button deselect the rows, and turn the previously selected rows that are now part of the list of rows submitted for removal grayed out font (color: light gray) and in italic. This to indicate that these will be excluded from further analysis. Secondly a button to undo the entire selection should change all rows back to normal format

I've gotten as far as recording the selected rows and adding the deselect feature, but to then restyle the rows before resetting them escapes me....

Output that I hope to achieve:

Not sure whether it is the right approach, but my thought was to use both values$selected_rows and values$removed_rows, where the first holds the selection until it is submitted, and removed holds the potentially growing list of rows selected for removal if the user decides to remove more rows on another submit

removed_rows is then also the list of rows that need to be styled (grayed out in italic)

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: I tried to move your javascript functions for submit and undo inside the DT::JS() part of embedded buttons, but I could not get it to work. I guess i'm close, but no idea where the problem is.

The table output code would follow this structure:

 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

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

Update

Here is the version including icons:

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)

Update

To get the indices of the excluded rows in 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);",
  "  });",
  "}"
)

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