Original Question

(See update with partial solution below.)

I have an RMarkdown document which summarizes how many records (rows) have various attributes by group. I would like to be able to manipulate which records are included in the table by filtering before the summarizing. I've created a minimal but similar mockup below.

What I would like is an interactive checkbox that would effectively "comment or uncomment" out the line

  # filter(weight_class == "Heavy") %>% 

below.

I know I could do this with Shiny, but I need to be able to share the resulting HTML file with colleagues directly (through a shared Box folder in my case), so a Shiny solution is not viable, at least for now. Also, I've considered using the features of DT/datatable, but as far as I can see the filtering needs to happen before it gets there (although I'm open to being shown I'm wrong about that).

I have seen packages like htmltools, htmlwidgets, and crosstalk that seem like they could facilitate this, but I'm not familiar enough with them yet and can't seem to find an example online close enough to modify for my purposes.

In actuality I have multiple conditions I would like to be able to filter on and multiple tables and plots I would like to produce from the filtered data, but I hope the minimal example below serves as a viable starting point.

How may I add such a checkbox (or similar) to create this type of interactivity without resorting to Shiny?

Demo RMarkdown:

---
title: "Table Demo"
output: html_document
---

```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
library(tidyverse)
library(DT)
```

```{r data}
set.seed(42)
df <- tibble(
  group = sample(paste0("Group ", LETTERS[1:4]), 100, replace = T),
  weight_class = sample(c("Heavy", "Light"), 100, replace = T, prob = c(.3, .7)),
  is_ready = sample(c(TRUE, FALSE), 100, replace = T, prob = c(.4, .6))
)
```

```{r table}
df %>% 
  # filter(weight_class == "Heavy") %>% 
  count(group, is_ready) %>% 
  pivot_wider(names_from = "is_ready", values_from = n) %>% 
  rename(Ready = `TRUE`, not_ready = `FALSE`) %>% 
  mutate(Total = Ready + not_ready, Ready_Percentage = Ready/Total) %>% 
  select(group, Ready, Total, Ready_Percentage, -not_ready) %>% 
  datatable() %>% 
  formatPercentage("Ready_Percentage")
```

Resulting HTML:

Update with partial solution

I've got a nearly working solution from @user2554330's suggestion:

---
title: "Table Demo"
output: html_document
---

```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
library(tidyverse)
library(DT)
```

```{r data}
set.seed(42)
df <- tibble(
  group = sample(paste0("Group ", LETTERS[1:4]), 100, replace = T),
  weight_class = sample(c("Heavy", "Light"), 100, replace = T, prob = c(.3, .7)),
  is_ready = sample(c(TRUE, FALSE), 100, replace = T, prob = c(.4, .6))
)
```

```{r solution}
library(reactable)
library(crosstalk)
shared_df <- SharedData$new(df)

shared_df %>% 
  reactable(
    groupBy = "group",
    columns = list(
      is_ready = colDef(aggregate = "frequency")
    )
  ) -> tb

bscols(
  widths = c(2, 10),
  list(filter_checkbox("weight_class", "Weight Class", shared_df, ~weight_class)),
  tb
)
```

Unfortunately, the filtering does not affect the aggregation (see screenshots).

Screenshot with All Records Selected:

Screenshot with Heavy Records Only Selected:

The filtering affects the group counts but not the is_ready frequency aggregation. I expect the filtering to affect this column as well, with something like this result:

df %>% filter(weight_class == "Heavy") %>% count(group, is_ready)
#> # A tibble: 8 x 3
#>   group   is_ready     n
#>   <chr>   <lgl>    <int>
#> 1 Group A FALSE        8
#> 2 Group A TRUE         1
#> 3 Group B FALSE        7
#> 4 Group B TRUE         3
#> 5 Group C FALSE        4
#> 6 Group C TRUE         1
#> 7 Group D FALSE       11
#> 8 Group D TRUE         2

^{Created on 2021-12-14 by the reprex package (v1.0.0)}

What am I doing wrong?

Try adding a JS aggregate function callback, instead of using the built-in aggregation:

shared_df %>% 
  reactable(
    groupBy = "group",
    columns = list(
      # is_ready = colDef(aggregate = "frequency"),
      is_ready = colDef(aggregated = JS("function(cellInfo) {
        let total_rows = cellInfo.subRows.length
        let total_ready_rows = cellInfo.subRows.filter(val => val.is_ready === true).length
        let percent = Math.round(total_ready_rows * 100 / total_rows) + '%'
        
        return percent
      }"))
    )
  ) -> tb

For some reason, if you use frequency function, or any other default one, it won't get updated, but JS always uses dynamic data; henceforth, use JS function to calculate aggregations for the filtered data.

The full code:

---
title: "Table Demo"
output: html_document
---

```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
library(tidyverse)
library(DT)
```

```{r data}
set.seed(42)
df <- tibble(
  group = sample(paste0("Group ", LETTERS[1:4]), 100, replace = T),
  weight_class = sample(c("Heavy", "Light"), 100, replace = T, prob = c(.3, .7)),
  is_ready = sample(c(TRUE, FALSE), 100, replace = T, prob = c(.4, .6))
)
```

```{r solution}
library(reactable)
library(crosstalk)
shared_df <- SharedData$new(df)

shared_df %>% 
  reactable(
    groupBy = "group",
    columns = list(
      # is_ready = colDef(aggregate = "frequency"),
      is_ready = colDef(aggregated = JS("function(cellInfo) {
        let total_rows = cellInfo.subRows.length
        let total_ready_rows = cellInfo.subRows.filter(val => val.is_ready === true).length
        let percent = Math.round(total_ready_rows * 100 / total_rows) + '%'
        
        return percent
      }"))
    )
  ) -> tb

bscols(
  widths = c(2, 10),
  list(filter_checkbox("weight_class", "Weight Class", shared_df, ~weight_class)),
  tb
)
```