Conditional coloring of DT column in shiny

Question

I need to conditionally color background of 'weight' column with following rule: nonnegative values are green and negative are red, but if none values are positive then 0 should also be red. I've tried multiple things but it seems to me that conditional formatStyle does not work, at least in this format:

ui <- fluidPage(
  DT::dataTableOutput("weight_df")
)

server <- function(input, output, session){
  
  df <- data.frame(weight = rep(1, 3))
  
  rv <- reactiveValues(weight_df = df)
  
  output$weight_df <- renderDataTable({
    
    DT::datatable(
      data = df,
      caption  = htmltools::tags$caption("Weight table"),
      editable = list(target = "column"),
    ) %>%
      formatStyle(
        "weight", 
        fontWeight = "bold",
        backgroundColor = `if`(
          all(df[["weight"]] <= 0),
          "orangered",
          styleInterval(-10^(-32), c("orangered", "limegreen"))
        )
      ) 
  })
  table_proxy <- DT::dataTableProxy("weight_df")
  
  observeEvent(input$weight_df_cell_edit, {
    
    info <- input$weight_df_cell_edit

    new_weights <- info[["value"]]
    is_numeric <- checkmate::testNumeric(
      x = new_weights,
      finite = TRUE,
      any.missing = FALSE
    )
    
    if(is_numeric)
      rv$weight_df[["weight"]][info[["row"]]] <- info[["value"]]
    
    DT::replaceData(table_proxy, rv$weight_df)
  })
}

shinyApp(ui, server)

Note: without rendering table again. I can make it render again if all weights are 0.

Answer 1

I think this is not possible with formatStyle. Here is a partial solution. It is partial because it does not handle the case of 0 which must be red when none values are positive. I will think about it.

library(shiny)
library(DT)

ui <- fluidPage(
  br(),
  DTOutput("weight_df")
)

server <- function(input, output, session){
  
  df <- data.frame(weight = c(-1, 0, 2))
  
  rdf <- reactiveVal(df)
  
  output$weight_df <- renderDT({
    
    datatable(
      data = df,
      rownames = TRUE,
      caption  = htmltools::tags$caption("Weight table"),
      editable = list(target = "cell"),
      options = list(
        rowCallback = JS(js)
      )
    ) 
  })
  
  table_proxy <- dataTableProxy("weight_df")
  
  observeEvent(input$weight_df_cell_edit, {
    info <- input$weight_df_cell_edit
    dat <- rdf()
    rdf(editData(dat, info, table_proxy, rownames = TRUE))
  })
}

shinyApp(ui, server)

---

Update

This handles the particular case of 0:

library(shiny)
library(DT)

js <- c(
  "function(row, dat, displayNum, index){",
  "  var color = dat[1] >= 0 ? 'green' : 'red';",
  "  $('td:eq(1)', row).css('background-color', color);",
  "}"
)

js <-  c(
  "function(settings) {",
  "  var table = settings.oInstance.api();",
  "  var nrows = table.rows().count();",
  "  var allnegative = true;",
  "  var i = 0;",
  "  while(allnegative && i < nrows) {",
  "    var weight = table.cell(i, 1).data();",
  "    allnegative = allnegative && weight <= 0;",
  "    i++;",
  "  }",
  "  for(var k = 0; k < nrows; k++) {",
  "    var cell = table.cell(k, 1);",
  "    var weight = cell.data();",
  "    var color = allnegative ? 'red' : 'green';",
  "    if(weight > 0) {",
  "      color = 'green';",
  "    } else if(weight < 0) {",
  "      color = 'red';",
  "    }",
  "    cell.node().style.backgroundColor = color;",
  "  }",
  "}")

ui <- fluidPage(
  br(),
  DTOutput("weight_df")
)

server <- function(input, output, session){
  
  df <- data.frame(weight = c(-1, 0, 2))
  
  rdf <- reactiveVal(df)
  
  output$weight_df <- renderDT({
    
    datatable(
      data = df,
      rownames = TRUE,
      caption  = htmltools::tags$caption("Weight table"),
      editable = list(target = "cell"),
      options = list(
        drawCallback = JS(js)
      )
    ) 
  })
  
  table_proxy <- dataTableProxy("weight_df")
  
  observeEvent(input$weight_df_cell_edit, {
    info <- input$weight_df_cell_edit
    dat <- rdf()
    rdf(editData(dat, info, table_proxy, rownames = TRUE))
  })
}

shinyApp(ui, server)