How can I style format some rows in a data frame depending on the input of a checkbox in a shiny app?

Question

I am working on a shiny app in which the user filters interactively a data frame using some widgets. One of my checkbox is called "LOT". What this checkbox is intended to do is to colour yellow those rows in which the value of the column x_LOT or Y_LOT is "true".

I have tried to include a conditional inside renderTable, so that if the input of the checkbox is true, the correspondent rows are coloured, but it did not work. I have tried to write the conditional inside reactive function that I have for the rest of the filters, but it did not work either.

My code is as follows:

# MY DATA FRAME
df <- data.frame(Consequence = c(rep("x",4),rep("y",4),rep("z",4)),
                 CANONICAL = rep(c("YES","NO"),6),
                 x_LOT = c(rep("False", 3), rep("True", 5), rep("False",2), "True","False"),
                 y_LOT = c(rep("False", 8), rep("True",2), rep("False",2)),
                 x3=c(12,43,64,34,93,16,32,74,84,89,45,67))
write.csv(df, "df.csv")


# MY APP
library(shiny)
library(DT)    #  for data tables
library(dplyr)
library(shinyWidgets)
library(lazyeval)
library(data.table)

ui <- function(request) {
  fluidPage(
    sidebarLayout(
      sidebarPanel(
        fileInput("file1", "Upload your File",multiple = FALSE,
                  accept = c("text/csv", "text/comma-separated-values,text/plain",".csv")),
        pickerInput("Consequence", "Consequence:", choices = NULL, options = list(`actions-box` = TRUE),
                    selected = NULL, multiple = TRUE ),
        prettyCheckbox(inputId = "CANONICAL", label = "CANONICAL", value = FALSE,
                       outline = TRUE, fill = TRUE, bigger = TRUE, status = 'success',width = NULL),
        prettyCheckbox(inputId="LOT", label = "LOT", value = FALSE, 
                     outline= TRUE, fill = TRUE, status = 'success', width = NULL)),

      mainPanel(
        dataTableOutput("contents")
      )))}

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

  df <- reactive({
    req(input$file1)
    df <- read.csv(input$file1$datapath)
  })

  observeEvent(df(), {
    req(df())
    updatePickerInput(session, inputId = "Consequence", choices = levels(df()$Consequence),  selected = levels(df()$Consequence))
  })


  filtered_df <- reactive({
    df() %>% 
      filter( Consequence %in% input$Consequence ) %>%
      filter(if (input$CANONICAL == TRUE) CANONICAL == "YES" else !is.na(CANONICAL))
  })

  output$contents <- renderDT(
    filtered_df(),
    class = "display nowrap compact", # style
    filter = "top")

  # if(input$LOT == TRUE){
  #   cols = names(df())[grepl( "LOT", names(filtered_df()))]
  #   datatable(filtered_df) %>% formatStyle(
  #     columns = cols,
  #     target = 'row',
  #     backgroundColor = styleEqual("TRUE", 'yellow')
  #   )}
}
shinyApp(ui, server)

So, in this case, I would expect to have the rows 4 to 11 coloured in yellow when the checkbox "LOT" is pressed.

Thanks,

Rachael

Answer 1

Here is a solution which only partially works. I don't understand the issue. (Edit: issue solved, see at the end)

Firstly, I have removed your file upload, in order not to have to upload a file. This has nothing to do with the issue. I call the dataframe DF.

The issue is here: in the code below, I do renderDT(DT, ....... This works, as you can see. But when I do renderDT(filtered_df(), ....), this doesn't work, and I don't understand why.

DF <- df <- data.frame(Consequence = c(rep("x",4),rep("y",4),rep("z",4)),
                       CANONICAL = rep(c("YES","NO"),6),
                       x_LOT = c(rep("False", 3), rep("True", 5), rep("False",2), "True","False"),
                       y_LOT = c(rep("False", 8), rep("True",2), rep("False",2)),
                       x3=c(12,43,64,34,93,16,32,74,84,89,45,67))
#write.csv(df, "df.csv")


# MY APP
library(shiny)
library(DT)    #  for data tables
library(dplyr)
library(shinyWidgets)
# library(lazyeval)
# library(data.table)

callback <- function(rows){
  c(
    sprintf("var rows = [%s];", toString(rows)),
    "$('#LOT').on('click', function(){",
    "  if($(this).prop('checked')){",
    "    for(var i=0; i<rows.length; ++i){",
    "      var row = table.row(rows[i]);",
    "      row.node().style.backgroundColor = 'yellow';",
    "    }",
    "  }else{",
    "    for(var i=0; i<rows.length; ++i){",
    "      var row = table.row(rows[i]);",
    "      row.node().style.backgroundColor = '';",
    "    }",
    "  }",
    "})"
  )
}


ui <- function(request) {
  fluidPage(
    sidebarLayout(
      sidebarPanel(
        fileInput("file1", "Upload your File",multiple = FALSE,
                  accept = c("text/csv", "text/comma-separated-values,text/plain",".csv")),
        pickerInput("Consequence", "Consequence:", choices = NULL, options = list(`actions-box` = TRUE),
                    selected = NULL, multiple = TRUE ),
        prettyCheckbox(inputId = "CANONICAL", label = "CANONICAL", value = FALSE,
                       outline = TRUE, fill = TRUE, bigger = TRUE, status = 'success',width = NULL),
        prettyCheckbox(inputId="LOT", label = "LOT", value = FALSE, 
                       outline= TRUE, fill = TRUE, status = 'success', width = NULL)),

      mainPanel(
        DTOutput("contents")
      )))}

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

  df <- reactive({
    # req(input$file1)
    # df <- read.csv(input$file1$datapath)
    DF
  })

  yellowRows <- reactive({
    req(df())
    which(df()$x_LOT == "True" | df()$y_LOT == "True") - 1L
  })

  observeEvent(df(), {
    req(df())
    updatePickerInput(session, inputId = "Consequence", 
                      choices = levels(df()$Consequence), 
                      selected = levels(df()$Consequence))
  })      

  filtered_df <- reactive({
    df() %>% 
      filter( Consequence %in% input$Consequence ) %>%
      filter(if (input$CANONICAL == TRUE) CANONICAL == "YES" else !is.na(CANONICAL))
  })

  output$contents <- renderDT({
    req(filtered_df())
    datatable(
      DF,
      class = "display nowrap compact", 
      filter = "top", 
      callback = JS(callback(yellowRows())),
      options = list(
        pageLength = 12)
    )}, 
    server = FALSE
  )

}

shinyApp(ui, server)

EDIT: issue solved

Just replace yellowRows with:

  yellowRows <- reactive({
    req(filtered_DAT())
    which(filtered_DAT()$x_LOT == "True" | filtered_DAT()$y_LOT == "True") - 1L
  })

  output$contents <- renderDT({
    req(filtered_DAT())
    datatable(
      filtered_DAT(),
      class = "display nowrap compact", 
      filter = "top", 
      callback = JS(callback(yellowRows())),
      options = list(
        pageLength = 12)
    )}, 
    server = FALSE
  )

---

EDIT: version which works with several pages

DF <- df <- data.frame(Consequence = c(rep("x",4),rep("y",4),rep("z",4)),
                       CANONICAL = rep(c("YES","NO"),6),
                       x_LOT = c(rep("False", 3), rep("True", 5), rep("False",2), "True","False"),
                       y_LOT = c(rep("False", 8), rep("True",2), rep("False",2)),
                       x3=c(12,43,64,34,93,16,32,74,84,89,45,67))
#write.csv(df, "df.csv")


# MY APP
library(shiny)
library(DT)    #  for data tables
library(dplyr)
library(shinyWidgets)
# library(lazyeval)
# library(data.table)

callback <- function(rows){
  c(
    sprintf("var rows = [%s];", toString(rows)),
    "$('#LOT').on('click', function(){",
    "    for(var i=0; i<rows.length; ++i){",
    "      var row = table.row(rows[i]);",
    "      if(row.length){",
    "        row.node().style.backgroundColor = ",
    "         $(this).prop('checked') ? 'yellow' : '';",
    "      }",
    "    }",
    "})"
  )
}


ui <- function(request) {
  fluidPage(
    sidebarLayout(
      sidebarPanel(
        fileInput("file1", "Upload your File",multiple = FALSE,
                  accept = c("text/csv", "text/comma-separated-values,text/plain",".csv")),
        pickerInput("Consequence", "Consequence:", choices = NULL, options = list(`actions-box` = TRUE),
                    selected = NULL, multiple = TRUE ),
        prettyCheckbox(inputId = "CANONICAL", label = "CANONICAL", value = FALSE,
                       outline = TRUE, fill = TRUE, bigger = TRUE, status = 'success',width = NULL),
        prettyCheckbox(inputId="LOT", label = "LOT", value = FALSE, 
                       outline= TRUE, fill = TRUE, status = 'success', width = NULL)),

      mainPanel(
        DTOutput("contents")
      )))}

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

  df <- reactive({
    # req(input$file1)
    # df <- read.csv(input$file1$datapath)
    DF
  })

  observeEvent(df(), {
    req(df())
    updatePickerInput(session, inputId = "Consequence", 
                      choices = levels(df()$Consequence), 
                      selected = levels(df()$Consequence))
  })      

  filtered_df <- reactive({
    df() %>% 
      filter( Consequence %in% input$Consequence ) %>%
      filter(if (input$CANONICAL == TRUE) CANONICAL == "YES" else !is.na(CANONICAL))
  })

  yellowRows <- reactive({
    req(filtered_df())
    which(filtered_df()$x_LOT == "True" | filtered_df()$y_LOT == "True") - 1L
  })

  output$contents <- renderDT({
    req(filtered_df())
    datatable(
      filtered_df(),
      class = "display nowrap compact", 
      filter = "top", 
      callback = JS(callback(yellowRows())),
      options = list(
        pageLength = 6)
    )}, 
    server = FALSE
  )  
}

shinyApp(ui, server)

Answer 2

Nice question, I learned a lot.

Here is another solution building on these other similar questions: Conditional formatStyle in DT Shiny datatable: Format row depending on two conditions

The sticky part was figuring out how to color the row by conditions in two columns (second link above). Turns out its best to create a separate column that check whether any of the *_LOT columns are True, color by that column, and then hide it when rendering the table. This works with the filtered_df() reactive.

# MY DATA FRAME
df <- data.frame(Consequence = c(rep("x",4),rep("y",4),rep("z",4)),
                 CANONICAL = rep(c("YES","NO"),6),
                 x_LOT = c(rep("False", 3), rep("True", 5), rep("False",2), "True","False"),
                 y_LOT = c(rep("False", 8), rep("True",2), rep("False",2)),
                 x3=c(12,43,64,34,93,16,32,74,84,89,45,67))
write.csv(df, "df.csv")


# MY APP
library(shiny)
library(DT)    #  for data tables
library(dplyr)
library(shinyWidgets)
library(lazyeval)
library(data.table)

ui <- function(request) {
  fluidPage(
    sidebarLayout(
      sidebarPanel(
        fileInput("file1", "Upload your File",multiple = FALSE,
                  accept = c("text/csv", "text/comma-separated-values,text/plain",".csv")),
        pickerInput("Consequence", "Consequence:", choices = NULL, options = list(`actions-box` = TRUE),
                    selected = NULL, multiple = TRUE ),
        prettyCheckbox(inputId = "CANONICAL", label = "CANONICAL", value = FALSE,
                       outline = TRUE, fill = TRUE, bigger = TRUE, status = 'success',width = NULL),
        prettyCheckbox(inputId="LOT", label = "LOT", value = FALSE, 
                       outline= TRUE, fill = TRUE, status = 'success', width = NULL)),

      mainPanel(
        dataTableOutput("contents")
      )))}

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

  df <- reactive({
    req(input$file1)
    df <- read.csv(input$file1$datapath)
  })

  observeEvent(df(), {
    req(df())
    updatePickerInput(session, inputId = "Consequence", choices = levels(df()$Consequence),  selected = levels(df()$Consequence))
  })


  filtered_df <- reactive({
    df() %>% 
      filter( Consequence %in% input$Consequence ) %>%
      filter(if (input$CANONICAL == TRUE) CANONICAL == "YES" else !is.na(CANONICAL))
  })

  make_dt <- reactive({
    if (input$LOT == TRUE) {
      cols = names(df())[grepl("LOT", names(filtered_df()))]
      fd <- filtered_df() 
      fd <- fd %>% 
        mutate(bg=ifelse(!!as.name(cols[1]) == "True" | !!as.name(cols[2])=="True", "True", "False"))

      x <- datatable(fd, options = list(
        columnDefs = list(list(targets = 7, visible = FALSE)))) %>%
        formatStyle(
          columns = names(fd),
          valueColumns = "bg",
          target = 'row',
          backgroundColor = styleEqual("True", "yellow")
        ) 
    } else {
      x <-  datatable(filtered_df(),
                      class = "display nowrap compact", # style
                      filter = "top")
    }
    return(x)

  })

  output$contents <-  renderDT({
    make_dt()
  })
}
shinyApp(ui, server)

EDIT: generalize to check any columns that contain LOT in the name

# MY DATA FRAME
df <- data.frame(Consequence = c(rep("x",4),rep("y",4),rep("z",4)),
                 CANONICAL = rep(c("YES","NO"),6),
                 x_LOT = c(rep("False", 3), rep("True", 5), rep("False",2), "True","False"),
                 y_LOT = c(rep("False", 8), rep("True",2), rep("False",2)),
                 x3=c(12,43,64,34,93,16,32,74,84,89,45,67))
write.csv(df, "df.csv")


# MY APP
library(shiny)
library(DT)    #  for data tables
library(dplyr)
library(shinyWidgets)
library(lazyeval)
library(data.table)

ui <- function(request) {
  fluidPage(
    sidebarLayout(
      sidebarPanel(
        fileInput("file1", "Upload your File",multiple = FALSE,
                  accept = c("text/csv", "text/comma-separated-values,text/plain",".csv")),
        pickerInput("Consequence", "Consequence:", choices = NULL, options = list(`actions-box` = TRUE),
                    selected = NULL, multiple = TRUE ),
        prettyCheckbox(inputId = "CANONICAL", label = "CANONICAL", value = FALSE,
                       outline = TRUE, fill = TRUE, bigger = TRUE, status = 'success',width = NULL),
        prettyCheckbox(inputId="LOT", label = "LOT", value = FALSE, 
                       outline= TRUE, fill = TRUE, status = 'success', width = NULL)),

      mainPanel(
        dataTableOutput("contents")
      )))}

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

  df <- reactive({
    req(input$file1)
    df <- read.csv(input$file1$datapath)
  })

  observeEvent(df(), {
    req(df())
    updatePickerInput(session, inputId = "Consequence", choices = levels(df()$Consequence),  selected = levels(df()$Consequence))
  })


  filtered_df <- reactive({
    df() %>% 
      filter( Consequence %in% input$Consequence ) %>%
      filter(if (input$CANONICAL == TRUE) CANONICAL == "YES" else !is.na(CANONICAL))
  })

  make_dt <- reactive({
    if (input$LOT == TRUE) {
      cols = names(df())[grepl("LOT", names(filtered_df()))]
      fd <- filtered_df() 
      # fd <- fd %>% 
      #   mutate(bg=ifelse(!!as.name(cols[1]) == "True" | !!as.name(cols[2])=="True", "True", "False"))
      # 
      color_column <- fd %>% 
        select(contains("LOT")) %>% 
        # not needed if *LOT columns have TRUE/FALSE or T/F values
        # you can rowSums those directly
        mutate_all(.funs = list(function(x) x == "True")) %>% 
        # do any of the rows have TRUE? if yes, label as 'True'
        mutate(check=ifelse(rowSums(.) > 0, "True", "False")) %>% 
        select(check)

      fd$color_column <- color_column$check

      x <- datatable(fd, options = list(
        columnDefs = list(list(targets = 7, visible = FALSE)))) %>%
        formatStyle(
          columns = names(fd),
          valueColumns = "color_column",
          target = 'row',
          backgroundColor = styleEqual("True", "yellow")
        ) 
    } else {
      x <-  datatable(filtered_df(),
                      class = "display nowrap compact", # style
                      filter = "top")
    }
    return(x)

  })

  output$contents <-  renderDT({
    make_dt()
  })
}
shinyApp(ui, server)