Row-wise conditional formatting in Shiny Reactable table

Question

I have the following dataframe that I am importing into a Shiny app:

final_odds <- structure(list(player_prop = c("Aaron Jones: Rush + Rec Yards", 
                                             "Aaron Jones: Rush + Rec Yards", "Aaron Rodgers: Interceptions", 
                                             "Aaron Rodgers: Interceptions", "Aaron Rodgers: Pass TDs", "Aaron Rodgers: Pass TDs", 
                                             "Aaron Rodgers: Pass Yards", "Aaron Rodgers: Pass Yards", "Adam Thielen: Rec Yards", 
                                             "Adam Thielen: Rec Yards"), Side = c("Over", "Under", "Over", 
                                                                                  "Under", "Over", "Under", "Over", "Under", "Over", "Under"), 
                             DraftKings = c("1300.5 (-115)", "1300.5 (-115)", "7.5 (115)", 
                                            "7.5 (-140)", "31.5 (-120)", "31.5 (100)", "4050.5 (-110)", 
                                            "4050.5 (-110)", "750.5 (-110)", "750.5 (-120)"), BetMGM = c("-", 
                                                                                                         "-", "-", "-", "-", "-", "-", "-", "699.5 (-125)", "699.5 (-105)"
                                            ), FanDuel = c("-", "-", "-", "-", "30.5 (-112)", "30.5 (-112)", 
                                                           "3950.5 (-112)", "3950.5 (-112)", "750.5 (-112)", "750.5 (-112)"
                                            ), Caesars = c("-", "-", "-", "-", "30.5 (-115)", "30.5 (-115)", 
                                                           "4000.5 (-115)", "4000.5 (-115)", "775.5 (-115)", "775.5 (-115)"
                                            )), row.names = c(NA, -10L), class = c("tbl_df", "tbl", "data.frame"
                                            ))

What I want to do is make it so that the lowest value (of the numbers not in parentheses) in columns 3-6 is highlighted in green for each row of data. The complications here are two-fold: 1) there isn't always a value in each of the columns, and 2) I just need to evaluate the numbers outside of the parentheses.

Here is a basic outline of the Shiny app as it stands:

library(shiny)
library(tidyverse)
library(dplyr)
library(reactable)


final_odds <- structure(list(player_prop = c("Aaron Jones: Rush + Rec Yards", 
                                             "Aaron Jones: Rush + Rec Yards", "Aaron Rodgers: Interceptions", 
                                             "Aaron Rodgers: Interceptions", "Aaron Rodgers: Pass TDs", "Aaron Rodgers: Pass TDs", 
                                             "Aaron Rodgers: Pass Yards", "Aaron Rodgers: Pass Yards", "Adam Thielen: Rec Yards", 
                                             "Adam Thielen: Rec Yards"), Side = c("Over", "Under", "Over", 
                                                                                  "Under", "Over", "Under", "Over", "Under", "Over", "Under"), 
                             DraftKings = c("1300.5 (-115)", "1300.5 (-115)", "7.5 (115)", 
                                            "7.5 (-140)", "31.5 (-120)", "31.5 (100)", "4050.5 (-110)", 
                                            "4050.5 (-110)", "750.5 (-110)", "750.5 (-120)"), BetMGM = c("-", 
                                                                                                         "-", "-", "-", "-", "-", "-", "-", "699.5 (-125)", "699.5 (-105)"
                                            ), FanDuel = c("-", "-", "-", "-", "30.5 (-112)", "30.5 (-112)", 
                                                           "3950.5 (-112)", "3950.5 (-112)", "750.5 (-112)", "750.5 (-112)"
                                            ), Caesars = c("-", "-", "-", "-", "30.5 (-115)", "30.5 (-115)", 
                                                           "4000.5 (-115)", "4000.5 (-115)", "775.5 (-115)", "775.5 (-115)"
                                            )), row.names = c(NA, -10L), class = c("tbl_df", "tbl", "data.frame"
                                            ))



ui <- fluidPage(
  reactableOutput("odds_table")
)

server <- function(input, output) {

    output$odds_table <- renderReactable({
    reactable(final_odds)
  })
}

# Run the application 
shinyApp(ui = ui, server = server)

Answer 1

We may get the index of the min values from columns 3 to 6 by looping across those columns, get the number outside the () with parse_number, find the min and get the index with which

library(dplyr)
library(reactable)
final_odds1 <-  final_odds %>%
          summarise(across(3:6, ~ {
              x1 <- readr::parse_number(.x)
              which(x1 %in% min(x1, na.rm = TRUE))
          }))

Now, we create the reactable object by specifying the columns and loop over the row index in style to highlight the rows where they are minimum by comparing with the index stored data from 'final_odds1'

reactable(final_odds, columns = list(
  DraftKings = colDef(
    style = function(value, index) {
      if(index %in% final_odds1$DraftKings) {
        color <- "green"
      } else {
        color <- "black"
      }
      list(color = color)
        
      
      
    }
  ),
  BetMGM = colDef(
    style = function(value, index) {
      if(index %in% final_odds1$BetMGM) {
        color <- "green"
      } else {
        color <- "black"
      }
      list(color = color)
      
      
      
    }
  ),
  FanDuel = colDef(
    style = function(value, index) {
      if(index %in% final_odds1$FanDuel) {
        color <- "green"
      } else {
        color <- "black"
      }
      list(color = color)
      
      
      
    }
  ), 
  
  
  Caesars = colDef(
    style = function(value, index) {
      if(index %in% final_odds1$Caesars) {
        color <- "green"
      } else {
        color <- "black"
      }
      list(color = color)
      
      
      
    }
  )
  
  
))

-output

---

If there are many columns, create a function wrapper and then loop over the names with map or imap

library(purrr)
final_odds1 <-  final_odds %>%
          summarise(across(3:6, ~ {
              x1 <- readr::parse_number(.x)
              which(x1 %in% min(x1, na.rm = TRUE))
          }))


style_fun <- function(colnm) {
        colDef(
          style =  function(value, index) {
            if(index %in% final_odds1[[colnm]]) {
              color <- "green"
            } else {
              color <- "black"
            }
            list(color = color)
            
            
            
          }
        )
  
  
  
}
reactable(final_odds, 
 columns = setNames(map(names(final_odds)[3:6], 
      ~ style_fun(.x)), names(final_odds[3:6])))

---

If it is grouped by 'player_prop'

library(stringr)
final_odds1 <-  final_odds %>%
          mutate(rn = row_number()) %>%
          group_by(player_prop) %>%
          mutate(across(DraftKings:Caesars, ~ {
              x1 <- as.numeric(na_if(str_remove(.x, "\\s*\\(.*"), "-"))
              
              list(if(all(is.na(x1))) NA_integer_ else 
      rn[x1 %in% min(x1, na.rm = TRUE)])
              
          })) %>%
        ungroup


style_fun <- function(colnm) {
        colDef(
          style =  function(value, index) {
            if(index %in% final_odds1[[colnm]][[index]]) {
              color <- "green"
            } else {
              color <- "black"
            }
            list(color = color)
            
            
            
          }
        )
  
  
  
}
reactable(final_odds, columns = setNames(map(names(final_odds)[3:6],
      ~ style_fun(.x)), names(final_odds[3:6])))