Update style of nested data

[algo-se]

Hi, following up on this issue, I´m having trouble trying to update the tags and badges cookbook example, grouped by client, using a button in shiny.

1. Would it be possible to apply the badges style using JS? (This would be ideal... I don´t know JS, I´ve done some research and found nothing).
2. Would it be possible (through JS) to "refresh" the style of the table when pressing the button without losing the sorting/filtering done?

Here is the reprex:

library(shiny)
library(reactable)
library(htmltools)
library(RSQLite)

pool <- dbPool(RSQLite::SQLite(), dbname = "db.sqlite")

# load data only once
t <- try(dbReadTable(pool, "orders"), silent=T)

if ("try-error" %in% class(t)) {
    orders <- data.frame(
        Order = 2300:2304,
        Created = seq(as.Date("2019-04-01"), by = "day", length.out = 5),
        Customer = c("Cortona", "Cortona", "Del Sarto", "Del Sarto", "Del Sarto"),
        Status = sample(c("Pending", "Paid", "Canceled"), 5, replace = TRUE),
        stringsAsFactors = FALSE
    )
    dbWriteTable(pool, "orders", orders, overwrite = TRUE)
}

status_badge <- function(color = "#aaa", width = "9px", height = width) {
    span(style = list(
        display = "inline-block",
        marginRight = "8px",
        width = width,
        height = height,
        backgroundColor = color,
        borderRadius = "50%"
    ))
}


ui <- fluidPage(
    titlePanel("Good looking tables!"),
    sidebarLayout(
        sidebarPanel(
            actionButton("ok_button", "⠀Approve order", icon("check")),
            actionButton("notok_button", "⠀Reject order", icon("times-circle"))
        ),
        mainPanel(
            reactableOutput("orders_table")
        )
    )
)

server <- function(input, output) {
    
    orders_rv <- reactive({
        input$ok_button
        input$notok_button
        dbReadTable(pool, "orders")
    })
    
    orders_table_selected <- reactive(getReactableState("orders_table", "selected"))
    
    approve_order <- function(data){
        df <- orders_rv()
        row_selection <- orders_table_selected()
        df[row_selection, "Status"] <- "Paid"
        
        dbWriteTable(pool, "orders", df, overwrite = TRUE)
    }
    
    reject_order <- function(data){
        df <- orders_rv()
        row_selection <- orders_table_selected()
        df[row_selection, "Status"] <- "Canceled"
        
        dbWriteTable(pool, "orders", df, overwrite = TRUE)
    }
    
    observeEvent(input$ok_button, priority = 20,{
        approve_order()
    })
    
    observeEvent(input$notok_button, priority = 20,{
        reject_order()
    })
    
    output$orders_table <- renderReactable({
        reactable(
            orders_rv(), 
            groupBy = "Customer",
            defaultExpanded = TRUE,
            selection = "single",
            onClick = "select",
            columns = list(
                Status = colDef(cell = function(value) {
                    color <- switch(
                        value,
                        Paid = "hsl(214, 45%, 50%)",
                        Pending = "hsl(30, 97%, 70%)",
                        Canceled = "hsl(3, 69%, 50%)"
                    )
                    badge <- status_badge(color = color)
                    tagList(badge, value)
                })
        ))
    })
    
}

shinyApp(ui = ui, server = server)

[glin]

For 1, yes, here's the same status badges example but using a JavaScript render function instead. The JavaScript is similar to the R code, except it generates a raw HTML string like <span style="display: inline-block; margin-right: 8px; width: 9px; height: 9px; background-color: hsl(214, 45%, 50%); border-radius: 50%"></span>, rather than building it using htmltools functions.

library(reactable)

set.seed(20)

orders <- data.frame(
  Order = 2300:2304,
  Created = seq(as.Date("2019-04-01"), by = "day", length.out = 5),
  Customer = sample(rownames(MASS::painters), 5),
  Status = sample(c("Pending", "Paid", "Canceled"), 5, replace = TRUE),
  stringsAsFactors = FALSE
)

reactable(
  orders,
  columns = list(
    Status = colDef(
      cell = JS("function(cellInfo) {
        let color
        switch (cellInfo.value) {
          case 'Paid':
            color = 'hsl(214, 45%, 50%)'
            break
          case 'Pending':
            color = 'hsl(30, 97%, 70%)'
            break
          case 'Canceled':
            color = 'hsl(3, 69%, 50%)'
            break
        }
        const badgeStyle = 'display: inline-block; margin-right: 8px; width: 9px; height: 9px;' +
          'background-color: ' + color + '; border-radius: 50%'
        const badge = '<span style=\"' + badgeStyle + '\"></span>'
        return badge + cellInfo.value
      }"),
      html = TRUE
    )
  )
)

For 2, you'll have to use updateReactable(data = ) if you want to keep the sorting/filtering state. You could use reactable() on a reactive data value, but that resets sorting/filtering on data changes because the new data could be completely different.

However, I still might recommend using reactable() with a reactive data value. updateReactable(data =) unfortunately doesn't work with R render functions because of the bug you mentioned (#109), and updateReactable(data =) currently has a limitation of collapsing all expanded rows.

Here's the same example from the reprex, but with some tweaks to update the data immediately on approve/reject button clicks. Before, the orders_rv() value was being read before the approve/reject changes could happen.

library(shiny)
library(reactable)
library(htmltools)
library(RSQLite)

pool <- pool::dbPool(RSQLite::SQLite(), dbname = "db.sqlite")

# load data only once
t <- try(dbReadTable(pool, "orders"), silent=T)

if ("try-error" %in% class(t)) {
  orders <- data.frame(
    Order = 2300:2304,
    Created = seq(as.Date("2019-04-01"), by = "day", length.out = 5),
    Customer = c("Cortona", "Cortona", "Del Sarto", "Del Sarto", "Del Sarto"),
    Status = sample(c("Pending", "Paid", "Canceled"), 5, replace = TRUE),
    stringsAsFactors = FALSE
  )
  dbWriteTable(pool, "orders", orders, overwrite = TRUE)
}

ui <- fluidPage(
  titlePanel("Good looking tables!"),
  sidebarLayout(
    sidebarPanel(
      actionButton("ok_button", "⠀Approve order", icon("check")),
      actionButton("notok_button", "⠀Reject order", icon("times-circle"))
    ),
    mainPanel(
      reactableOutput("orders_table")
    )
  )
)

status_badge <- function(color = "#aaa", width = "9px", height = width) {
  span(style = list(
    display = "inline-block",
    marginRight = "8px",
    width = width,
    height = height,
    backgroundColor = color,
    borderRadius = "50%"
  ))
}

server <- function(input, output) {
  
  orders_rv <- reactiveVal()
  
  update_orders <- function() {
    orders <- dbReadTable(pool, "orders")
    orders_rv(orders)
  }
  
  update_orders()
  
  orders_table_selected <- reactive(getReactableState("orders_table", "selected"))
  
  approve_order <- function(data){
    df <- orders_rv()
    row_selection <- orders_table_selected()
    df[row_selection, "Status"] <- "Paid"
    
    dbWriteTable(pool, "orders", df, overwrite = TRUE)
  }
  
  reject_order <- function(data){
    df <- orders_rv()
    row_selection <- orders_table_selected()
    df[row_selection, "Status"] <- "Canceled"
    
    dbWriteTable(pool, "orders", df, overwrite = TRUE)
  }
  
  observeEvent(input$ok_button, {
    approve_order()
    update_orders()
  })
  
  observeEvent(input$notok_button, {
    reject_order()
    update_orders()
  })
  
  output$orders_table <- renderReactable({
    reactable(
      orders_rv(), 
      groupBy = "Customer",
      defaultExpanded = TRUE,
      selection = "single",
      onClick = "select",
      columns = list(
        Status = colDef(cell = function(value) {
          color <- switch(
            value,
            Paid = "hsl(214, 45%, 50%)",
            Pending = "hsl(30, 97%, 70%)",
            Canceled = "hsl(3, 69%, 50%)"
          )
          badge <- status_badge(color = color)
          tagList(badge, value)
        })
      ))
  })
  
}

shinyApp(ui = ui, server = server)

If you still want to use updateReactable() and keep sorting and filtering changes, here's an adapted example but with the caveat that sub rows are always expanded. Because updateReactable(data = ) collapses all rows, I added updateReactable(expanded = TRUE) to re-expand rows on data updates.

Also, you can still use a reactive data value with the table like this, but it has to be wrapped in isolate() so changes only come from updateReactable().

library(shiny)
library(reactable)
library(htmltools)
library(RSQLite)

pool <- pool::dbPool(RSQLite::SQLite(), dbname = "db.sqlite")

# load data only once
t <- try(dbReadTable(pool, "orders"), silent=T)

if ("try-error" %in% class(t)) {
  orders <- data.frame(
    Order = 2300:2304,
    Created = seq(as.Date("2019-04-01"), by = "day", length.out = 5),
    Customer = c("Cortona", "Cortona", "Del Sarto", "Del Sarto", "Del Sarto"),
    Status = sample(c("Pending", "Paid", "Canceled"), 5, replace = TRUE),
    stringsAsFactors = FALSE
  )
  dbWriteTable(pool, "orders", orders, overwrite = TRUE)
}

ui <- fluidPage(
  titlePanel("Good looking tables!"),
  sidebarLayout(
    sidebarPanel(
      actionButton("ok_button", "⠀Approve order", icon("check")),
      actionButton("notok_button", "⠀Reject order", icon("times-circle"))
    ),
    mainPanel(
      reactableOutput("orders_table")
    )
  )
)

server <- function(input, output) {

  orders_rv <- reactiveVal({
    dbReadTable(pool, "orders")
  })

  update_orders <- function() {
    orders <- dbReadTable(pool, "orders")
    orders_rv(orders)
    updateReactable("orders_table", data = orders, expanded = TRUE)
  }

  orders_table_selected <- reactive(getReactableState("orders_table", "selected"))

  approve_order <- function() {
    df <- orders_rv()
    row_selection <- orders_table_selected()
    df[row_selection, "Status"] <- "Paid"

    dbWriteTable(pool, "orders", df, overwrite = TRUE)
  }

  reject_order <- function() {
    df <- orders_rv()
    row_selection <- orders_table_selected()
    df[row_selection, "Status"] <- "Canceled"

    dbWriteTable(pool, "orders", df, overwrite = TRUE)
  }

  observeEvent(input$ok_button, {
    approve_order()
    update_orders()
  })

  observeEvent(input$notok_button, {
    reject_order()
    update_orders()
  })

  output$orders_table <- renderReactable({
    reactable(
      isolate(orders_rv()),
      groupBy = "Customer",
      defaultExpanded = TRUE,
      selection = "single",
      onClick = "select",
      columns = list(
        Status = colDef(
          cell = JS("function(cellInfo) {
            let color
            switch (cellInfo.value) {
              case 'Paid':
                color = 'hsl(214, 45%, 50%)'
                break
              case 'Pending':
                color = 'hsl(30, 97%, 70%)'
                break
              case 'Canceled':
                color = 'hsl(3, 69%, 50%)'
                break
            }
            const badgeStyle = 'display: inline-block; margin-right: 8px; width: 9px; height: 9px;' +
              'background-color: ' + color + '; border-radius: 50%'
            const badge = '<span style=\"' + badgeStyle + '\"></span>'
            return badge + cellInfo.value
          }"),
          html = TRUE
        )
      )
    )
  })
}

shinyApp(ui = ui, server = server)

[algo-se]

Thank you for the detailed answer, it helped me a lot!