A couple useful JavaScript aggregation and formatting functions for {reactable}

Series on runtime-free content delivery

Jul 31, 2022 10 min read

In my last post we demonstrated how to build a filterable map widget into an HTML output that was free of R runtime dependency. In continuation of that theme, this article focuses on the reactable package, which enables you to embed interactive data tables into your document. Specifically, we’ll look at how we can use its built-in JavaScript interface to define custom functions for commonly-desired aggregation and formatting.

The Basics

Let’s start with loading some packages.

library(reactable)
library(tidyverse)
## ── Attaching packages ─────────────────────────────────────── tidyverse 1.3.2 ──
## ✔ ggplot2 3.4.0     ✔ purrr   1.0.0
## ✔ tibble  3.1.8     ✔ dplyr   1.1.0
## ✔ tidyr   1.2.1     ✔ stringr 1.4.1
## ✔ readr   2.1.3     ✔ forcats 0.5.2
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag()    masks stats::lag()

Make a summary dataset

First we’ll need to create a data frame with group-level summary statistics that we want to display. For this example, we’ll look at the 30-day hospital readmission rate for heart failure patients on Medicare at the top five (5) most voluminous hospitals in a handful of Midwest states.

# Import dataset
readmission_rates <-
  read_csv(
    file = "https://data.cms.gov/provider-data/sites/default/files/resources/37e3c1486ad47b7a0eb471ecf3f7e428_1689206737/Unplanned_Hospital_Visits-Hospital.csv",
    na = c("", " ", "NA", "N/A", "Not Available")
  ) %>%
  
  # Filter to states with non-null values
  filter(
    State %in% c("WI", "MN", "MI", "IL"),
    `Measure ID` == "READM_30_HF",
    !is.na(Denominator),
    !is.na(Score)
  ) %>%
  
  # Convert to proportion
  mutate(
    Score = Score / 100
  ) %>%
  
  # Keep a few columns
  select(
    State,
    Hospital = `Facility Name`,
    Cases = Denominator,
    `30-Day Readmission Rate` = Score
  ) %>%
  
  # For each state, keep the top 5 most voluminous hospitals
  group_by(State) %>%
  slice_max(
    n = 5,
    order_by = Cases,
    with_ties = FALSE
  ) %>%
  ungroup()
## Warning: One or more parsing issues, call `problems()` on your data frame for details,
## e.g.:
##   dat <- vroom(...)
##   problems(dat)
## Rows: 67732 Columns: 20
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (15): Facility ID, Facility Name, Address, City/Town, State, ZIP Code, C...
## dbl  (5): Denominator, Score, Lower Estimate, Higher Estimate, Footnote
## 
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.
readmission_rates
## # A tibble: 20 × 4
##    State Hospital                                               Cases 30-Day R…¹
##    <chr> <chr>                                                  <dbl>      <dbl>
##  1 IL    NORTHSHORE UNIVERSITY HEALTHSYSTEM - EVANSTON HOSPITAL  1968      0.207
##  2 IL    PALOS COMMUNITY HOSPITAL                                1249      0.208
##  3 IL    NORTHWESTERN MEMORIAL HOSPITAL                          1146      0.2  
##  4 IL    ADVOCATE CHRIST HOSPITAL & MEDICAL CENTER               1096      0.219
##  5 IL    NORTHWESTERN MEDICINE MCHENRY                           1029      0.18 
##  6 MI    BEAUMONT HOSPITAL ROYAL OAK                             1438      0.208
##  7 MI    BEAUMONT HOSPITAL, TROY                                 1401      0.216
##  8 MI    ASCENSION PROVIDENCE HOSPITAL, SOUTHFIELD AND NOVI      1020      0.205
##  9 MI    TRINITY HEALTH ANN ARBOR HOSPITAL                        930      0.184
## 10 MI    SPECTRUM HEALTH                                          925      0.169
## 11 MN    MAYO CLINIC HOSPITAL ROCHESTER                          1273      0.173
## 12 MN    ABBOTT NORTHWESTERN HOSPITAL                             632      0.183
## 13 MN    PARK NICOLLET METHODIST HOSPITAL                         590      0.228
## 14 MN    MERCY HOSPITAL                                           589      0.174
## 15 MN    MINNEAPOLIS VA MEDICAL CENTER                            546      0.207
## 16 WI    AURORA ST LUKES MEDICAL CENTER                          1097      0.194
## 17 WI    FROEDTERT MEMORIAL LUTHERAN HOSPITAL                     532      0.205
## 18 WI    UNIVERSITY OF WI  HOSPITALS & CLINICS AUTHORITY          531      0.221
## 19 WI    MERITER HOSPITAL                                         522      0.197
## 20 WI    MILWAUKEE VA MEDICAL CENTER                              499      0.231
## # … with abbreviated variable name ¹​`30-Day Readmission Rate`

The default table

As a starting point, let’s see what we get when we call the reactable function without any additional arguments.

readmission_rates %>% reactable()

We get about what we’d expect: a basic, paginated table where each row from our dataset is represented verbatim. There are many things we could clean up here such as rounding, number representations, formatting, and, of course, aggregating the statistics to get state-specific readmission rates.

Built-in aggregation

There are a number of built-in aggregation functions available to us by default. We just need to specify:

  1. The groups we want the aggregation applied within using the groupBy argument
  2. The columns we want to aggregate, and how, using colDef within the columns argument

Let’s add functionality to the table above to aggregate the total case count and the average 30-day readmission rate within each state.

readmission_rates %>%
  reactable(
    groupBy = "State",
    columns = 
      list(
        Cases = colDef(aggregate = "sum"),
        `30-Day Readmission Rate` = colDef(aggregate = "mean")
      )
  )

The problem with this table is that the displayed state-level readmission rates represent the averaged rates across the individual hospitals. What we really want in the aggregation is for the hospital-specific rates to be weighted by their respective case volumes so that the state-level readmission rates are correct. This is where JavaScript comes in.

Using the JavaScript Interface

During the call to reactable, our table is accessible through a JavaScript interface which makes it easy for us to customize the aggregation and formatting behavior when the default options won’t suffice. We can use the JS function from the htmlwidgets package to:

  1. Define a JavaScript function as a text string
  2. Supply that function as the argument to colDef applicable to the function’s context

Function 1: Weighted mean

Referring back to our example, we want to average the 30-day readmission rates over the hospitals within each state, but we need to weight them by their respective case volume. To do this, we can supply a custom JavaScript function to the aggregate argument. This function takes the entire vector of values within the group as its argument, as well as the group’s rows, and returns a scalar value. We can specify the column containing the case weights directly by name within the row.

weighted_mean <-
  function(weight) {
    JS(
      paste0(
        "function(values, rows) {
          var numerator = 0
          var denominator = 0
    
          rows.forEach(function(row, index) {
            numerator += row['", weight, "'] * values[index]
            denominator += row['", weight, "']
          })
    
          return numerator / denominator
  
        }"
      )
    )
  }

In our implementation, we encoded the JS function into an R function that calls for the weight column name so we can use it in any reactable in which we want this functionality applied. Let’s see what our table looks when we plug it in:

readmission_rates %>%
  reactable(
    groupBy = "State",
    columns = 
      list(
        Cases = colDef(aggregate = "sum"),
        `30-Day Readmission Rate` = colDef(aggregate = weighted_mean(weight = "Cases"))
      )
  )

Now we have correctly calculated the state-level 30-day readmission rates.

Function 2: Conditional coloring

Suppose we would like to differentiate readmission rates in our table that are above or below the national average. To do this, we can define another JavaScript function and supply it to the style argument within colDef. First, lets pull in the comparison value.

national_rate <-
  read_csv(
    file = "https://data.cms.gov/provider-data/sites/default/files/resources/6a36e0b7e124bc6f9afd036021cce397_1689206738/Unplanned_Hospital_Visits-National.csv",
    na = c("Not Available", "Not Applicable")
  ) %>%
  
  # Filter to the measure
  filter(
    `Measure ID` == "READM_30_HF"
  ) %>%
  
  # Pull the rate
  pull(`National Rate`)
## Warning: One or more parsing issues, call `problems()` on your data frame for details,
## e.g.:
##   dat <- vroom(...)
##   problems(dat)
## Rows: 14 Columns: 14
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (4): Measure ID, Measure Name, Start Date, End Date
## dbl (9): National Rate, Number of Hospitals Worse, Number of Hospitals Same,...
## lgl (1): Footnote
## 
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.
national_rate <- national_rate / 100
national_rate
## [1] 0.202

Next, lets define another JS function wrapped in an R function that takes the column to evaluate, the comparison value, and the colors to fill in the table cell when it is above or below (or the same as) that threshold. These arguments will feed into the JavaScript function that applies the specified HTML styling to each value in the column.

conditional_coloring <-
  function(column, threshold, color_above, color_below, color_same = "#fcfffd") {
    JS(
      paste0(
        "function(rowInfo) {
          var value = rowInfo.row['", column, "']
    
          if(value > ", threshold, ") {
            var color = '", color_above, "'
          } else if(value < ", threshold, ") {
            var color = '", color_below, "'
          } else {
            var color = '", color_same, "'
          }
    
          return {background:color}
        }"
      )
    )
  }

We can now add it to the table:

readmission_rates %>%
  reactable(
    groupBy = "State",
    columns = 
      list(
        Cases = colDef(aggregate = "sum"),
        `30-Day Readmission Rate` = 
          colDef(
            aggregate = weighted_mean(weight = "Cases"),
            style = 
              conditional_coloring(
                column = "30-Day Readmission Rate",
                threshold = national_rate,
                color_above = "#eb7554",
                color_below = "#54a637"
              )
          )
      )
  )

Note that the national 30-day readmission rate for heart failure patients on Medicare was 20.2%.

Final touches

Finally, let’s add a few finishing touches to really make the table pop.

readmission_rates %>%
  reactable(
    groupBy = "State",
    columns = 
      list(
        Cases = colDef(aggregate = "sum"),
        `30-Day Readmission Rate` = 
          colDef(
            aggregate = weighted_mean(weight = "Cases"),
            style = 
              conditional_coloring(
                column = "30-Day Readmission Rate",
                threshold = national_rate,
                color_above = "#eb7554",
                color_below = "#54a637"
              ),
            format = colFormat(digits = 2, percent = TRUE)
          )
      ),
    striped = TRUE,
    highlight = TRUE,
    bordered = TRUE,
    resizable = TRUE,
    theme = reactablefmtr::sandstone()
  )
rstats javascript
Alex Zajichek
Alex Zajichek
Statistician & Data Scientist
comments powered by Disqus

Related