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

Healthcare
Tables
Javascript
Embedding tables into your analytical HTML document
Author

Alex Zajichek

Published

July 31, 2022

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.

Table of Contents

The Basics

Let’s start with loading some packages.

Code 
library(reactable)
library(tidyverse)
── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
✔ dplyr     1.1.4     ✔ readr     2.1.5
✔ forcats   1.0.0     ✔ stringr   1.5.1
✔ ggplot2   3.5.1     ✔ tibble    3.2.1
✔ lubridate 1.9.3     ✔ tidyr     1.3.1
✔ purrr     1.0.2     
── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
✖ dplyr::filter() masks stats::filter()
✖ dplyr::lag()    masks stats::lag()
ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors

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.

Code 
# Import dataset
readmission_rates <-
  read_csv(
    file = "/Users/alexzajichek/Documents/GitHub/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: 66906 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.
Code 
readmission_rates
# A tibble: 20 × 4
   State Hospital                                   Cases 30-Day Readmission R…¹
   <chr> <chr>                                      <dbl>                  <dbl>
 1 IL    NORTHSHORE UNIVERSITY HEALTHSYSTEM - EVAN…  2294                  0.212
 2 IL    PALOS COMMUNITY HOSPITAL                    1436                  0.214
 3 IL    NORTHWESTERN MEMORIAL HOSPITAL              1315                  0.187
 4 IL    ADVOCATE CHRIST HOSPITAL & MEDICAL CENTER   1287                  0.202
 5 IL    NORTHWESTERN MEDICINE MCHENRY               1286                  0.177
 6 MI    BEAUMONT HOSPITAL, TROY                     1683                  0.21 
 7 MI    BEAUMONT HOSPITAL ROYAL OAK                 1611                  0.2  
 8 MI    ASCENSION PROVIDENCE HOSPITAL, SOUTHFIELD…  1191                  0.206
 9 MI    TRINITY HEALTH ANN ARBOR HOSPITAL           1121                  0.191
10 MI    SPECTRUM HEALTH                             1065                  0.172
11 MN    MAYO CLINIC HOSPITAL ROCHESTER              1551                  0.173
12 MN    ABBOTT NORTHWESTERN HOSPITAL                 778                  0.189
13 MN    PARK NICOLLET METHODIST HOSPITAL             747                  0.213
14 MN    MERCY HOSPITAL                               742                  0.176
15 MN    ST CLOUD HOSPITAL                            623                  0.18 
16 WI    AURORA ST LUKES MEDICAL CENTER              1362                  0.188
17 WI    FROEDTERT MEMORIAL LUTHERAN HOSPITAL         621                  0.195
18 WI    UNIVERSITY OF WI  HOSPITALS & CLINICS AUT…   609                  0.219
19 WI    WAUKESHA MEMORIAL HOSPITAL                   605                  0.171
20 WI    MILWAUKEE VA MEDICAL CENTER                  604                  0.222
# ℹ abbreviated 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.

Code 
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.

Code 
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.

Code 
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:

Code 
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.

Code 
national_rate <-
  read_csv(
    file = "/Users/alexzajichek/Documents/GitHub/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.
Code 
national_rate <- national_rate / 100
national_rate
[1] 0.198

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.

Code 
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:

Code 
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 19.8%.

Final touches

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

Code 
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()
  )