Shiny / DT/ save changes when switching & coloring cells after change

Question

basically, I'm trying to connect the answers of YBS here Shiny app with editable datatable: How can I enable the modification of the table when I use selectInput option? and Stéphane Laurent's from here Change backgorund color of cell of data table while its value is edited in Rshiny.

Here I have tried to combine the codes: so what I want is to keep the changes when I switch between the categories on the left (works now) and that each changed cell is highlighted in color (does not work now).

library(tidyverse)
library(shiny)
library(DT)
library(shinyjs)

js <- HTML(
  "function colorizeCell(i, j){
    var selector = '#dtable tr:nth-child(' + i + ') td:nth-child(' + j + ')';
    $(selector).css({'background-color': 'yellow'});
  }"
)

colorizeCell <- function(i, j){
  sprintf("colorizeCell(%d, %d)", i, j)
}

ui<-fluidPage(  useShinyjs(),
                tags$head(
                  tags$script(js)
                ),
  
                 sidebarLayout(
                   sidebarPanel(width = 3,
                                inputPanel(
                                  selectInput("Species", label = "Choose species",
                                              choices = levels(as.factor(iris$Species)))
                                )),
                   
                   

                   mainPanel( tabsetPanel(
                     tabPanel("Data Table",DTOutput("iris_datatable"),
                             hr()))
                 )
               )

)


server <- function(input, output, session) {
  my_iris <- reactiveValues(df=iris,sub=NULL, sub1=NULL)

  observeEvent(input$Species, {
    my_iris$sub <- my_iris$df %>% filter(Species==input$Species)
    my_iris$sub1 <- my_iris$df %>% filter(Species!=input$Species)
  }, ignoreNULL = FALSE)
  
  output$iris_datatable <- renderDT({
    n <- length(names(my_iris$sub))
    DT::datatable(my_iris$sub,
                  options = list(pageLength = 10),
                  selection='none', editable= list(target = 'cell'), 
                  rownames= FALSE)
  }, server = FALSE)
  # 
  observeEvent(input$iris_datatable_cell_edit,{
    edit <- input$iris_datatable_cell_edit
    i <- edit$row
    j <- edit$col + 1
    v <- edit$value
    runjs(colorizeCell(i, j+1))
    my_iris$sub[i, j] <<- DT::coerceValue(v, my_iris$sub[i, j])

    my_iris$df <<- rbind(my_iris$sub1,my_iris$sub)
  })
  

  
}
shinyApp(ui, server)

Answer 1

Here is a way using a rowCallback.

The idea is to add some 0/1 columns to the data, a 1 indicates that the cell is colorized. Obviously we hide these columns in the datatable, but they are in the table: the rowCallback has access to them. Then the rowCallback, which is triggered each time the datatable is redrawn, assigns the colors to the cells by reading the hidden 0/1 columns. And each time we color a cell when we edit it, we put a 1 in the corresponding hidden 0/1 column.

library(tidyverse)
library(shiny)
library(DT)
library(shinyjs)

js <- HTML(
  "function colorizeCell(i, j){
    var selector = '#iris_datatable tr:nth-child(' + i + ') td:nth-child(' + j + ')';
    $(selector).css({'background-color': 'yellow'});
  }"
)

colorizeCell <- function(i, j){
  sprintf("colorizeCell(%d, %d)", i, j)
}

rowCallback <- '
function(row, data) {
  for(var j = 5; j <= 9; j++) {
    var colorized = data[j] == 1;
    if(colorized) {
      $("td:eq(" + (j-5) + ")", row).css({"background-color": "yellow"});
    }
  }
}
'

isColorized <- sapply(levels(iris$Species), function(species) {
  m <- length(iris$Species[iris$Species == species])
  as.data.frame(matrix(0L, nrow = m, ncol = ncol(iris)))
}, simplify = FALSE)

ui<-fluidPage(
  useShinyjs(),
  tags$head(
    tags$script(js)
  ),
  
  sidebarLayout(
    sidebarPanel(
      width = 3,
      inputPanel(
        selectInput("Species", label = "Choose species",
                    choices = levels(as.factor(iris$Species))
        )
      )
    ),
    
    mainPanel( 
      tabsetPanel(
        tabPanel(
          "Data Table",
          DTOutput("iris_datatable"),
          hr()
        )
      )
    )
  )
  
)


server <- function(input, output, session) {
  
  IsColorized <- reactiveVal(isColorized)
  
  dataSubset <- reactiveVal()
  
  observeEvent(input$Species, {
    colorized <- IsColorized()[[input$Species]]
    tableData <- cbind(iris %>% filter(Species == input$Species), colorized)
    dataSubset(tableData)
  })
  
  output$iris_datatable <- renderDT({
    datatable(
      dataSubset(),
      options = list(
        pageLength = 10,
        rowCallback = JS(rowCallback),
        columnDefs = list(
          list(targets = 5:9, visible = FALSE)
        )
      ),
      selection = 'none', 
      editable = list(target = 'cell'), 
      rownames= FALSE
    )
  }, server = FALSE)
  
  observeEvent(input$iris_datatable_cell_edit,{
    edit <- input$iris_datatable_cell_edit
    i <- edit$row
    j <- edit$col + 1
    iscolorized <- IsColorized()
    iscolorized[[input$Species]][i, j] <- 1L
    IsColorized(iscolorized)
    runjs(colorizeCell(i, j))
  })
}

shinyApp(ui, server)

Answer 2

This will work: Remove these two lines:

my_iris$sub[i, j] <<- DT::coerceValue(v, my_iris$sub[i, j])

my_iris$df <<- rbind(my_iris$sub1,my_iris$sub)

and adapt runjs

library(tidyverse)
library(shiny)
library(DT)
library(shinyjs)

js <- HTML(
  "function colorizeCell(i, j){
    var selector = '#iris_datatable tr:nth-child(' + i + ') td:nth-child(' + j + ')';
    $(selector).css({'background-color': 'yellow'});
  }"
)

colorizeCell <- function(i, j){
  sprintf("colorizeCell(%d, %d)", i, j)
}

ui<-fluidPage(  useShinyjs(),
                tags$head(
                  tags$script(js)
                ),
                
                sidebarLayout(
                  sidebarPanel(width = 3,
                               inputPanel(
                                 selectInput("Species", label = "Choose species",
                                             choices = levels(as.factor(iris$Species)))
                               )),
                  
                  
                  
                  mainPanel( tabsetPanel(
                    tabPanel("Data Table",DTOutput("iris_datatable"),
                             hr()))
                  )
                )
                
)


server <- function(input, output, session) {
  my_iris <- reactiveValues(df=iris,sub=NULL, sub1=NULL)
  
  observeEvent(input$Species, {
    my_iris$sub <- my_iris$df %>% filter(Species==input$Species)
    my_iris$sub1 <- my_iris$df %>% filter(Species!=input$Species)
  }, ignoreNULL = FALSE)
  
  output$iris_datatable <- renderDT({
    n <- length(names(my_iris$sub))
    DT::datatable(my_iris$sub,
                  options = list(pageLength = 10),
                  selection='none', editable= list(target = 'cell'), 
                  rownames= FALSE)
  }, server = FALSE)
  # 
  observeEvent(input$iris_datatable_cell_edit,{
    edit <- input$iris_datatable_cell_edit
    i <- edit$row
    j <- edit$col + 1
    v <- edit$value
    runjs(colorizeCell(i, j))
  })
}
shinyApp(ui, server)

Answer 3

In this JavaScript code:

js <- HTML(
  "function colorizeCell(i, j){
    var selector = '#dtable tr:nth-child(' + i + ') td:nth-child(' + j + ')';
    $(selector).css({'background-color': 'yellow'});
  }"
)

you can see #dtable. This is the selector of the HTML element with id dtable. But the id of your datatable is not dtable, it is iris_datatable. So you have to do the replacement.