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

Stéphane Laurent · Accepted Answer · 2019-08-29T16:14:30.810

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)

@Stephane Laurent Hi, this code does not work if the table is divide in in more than one page (if pageLength = 10). I am working with a much bigger table than in the example and i need to divide the table in several pages.. Thanks a lot! — Rachael, Aug 29 '19 at 15:56

teofil · Answer 2 · 2019-08-27T15:05:56.823

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)

Nice, but a potential problem with this solution is that the datatable is reactive to `input$LOT`. Therefore it is rerendered whenever `input$LOT` changes. This could cause some problems, for example this could reset the filters. — Stéphane Laurent, Aug 23 '19 at 13:27
Yes, the table will be re-rendered every time checkboxes change. But I thought that since `make_dt()` works with `filtered_df()`, it should respect the filters irrespective of LOT. When `LOT` is not clicked, the unpainted, but filtered, data frame should be rendered. — teofil, Aug 23 '19 at 13:47
@ teofil, I'm talking about the filters of the table (at the top). There could be a problem also if you sort the data, clicking the `LOT` will unsort it. — Stéphane Laurent, Aug 23 '19 at 13:56
Yes, I see what you mean. In this case, `LOT` will mess with sorting/filtering. — teofil, Aug 23 '19 at 14:28
@teofil, what if there are more than two *_LOT columns? It could be the case with my program. Is there any way to select the columns without specifying the value per each column? something like a python comprehension list — Rachael, Aug 27 '19 at 09:29
Yes, I included one way this can be done as an edit in my answer above. — teofil, Aug 27 '19 at 15:07

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

2 Answers2

EDIT: issue solved

EDIT: version which works with several pages