Allow selection in interactive tables

[jonthegeek]

Summary

Add an option ihtml_selection (default NULL, can be "single" or "multiple") to enable selection in interactive gt tables. When this is on, make it available as an input in Shiny.

Related GitHub Issues and PRs

• Closes shiny get selected row from GT #354.
• Closes row selection reactive variable needed for shiny app #1368.

Checklist

• I understand and agree to the Code of Conduct.
• I have listed any major changes in the NEWS.
• I have added testthat unit tests to tests/testthat for any new functionality.

[jonthegeek]

So far I've just set up the option. I need to add tests, and then move on to the Shiny side.

[jonthegeek]

A test app to see it in action:

# Launch the ShinyApp (Do not remove this comment)
# To deploy, run: rsconnect::deployApp()
# Or use the blue button on top of this file
library(shiny)
pkgload::load_all(".", helpers = FALSE, attach_testthat = FALSE)

gt_tbl <-
  gtcars |>
  gt() |>
  fmt_currency(columns = msrp, decimals = 0) |>
  cols_hide(columns = -c(mfr, model, year, mpg_c, msrp)) |>
  cols_label_with(columns = everything(), fn = toupper) |>
  data_color(columns = msrp, method = "numeric", palette = "viridis") |>
  sub_missing() |>
  opt_interactive(use_compact_mode = TRUE, selection = "multiple")

ui <- fluidPage(
  gt_output(outputId = "table"),
  verbatimTextOutput("selected")
)

server <- function(input, output, session) {
  output$table <- render_gt(expr = gt_tbl)
  output$selected <- renderPrint({
    input$table
  })
}

shinyApp(ui = ui, server = server)

Add this to preview an alternate UI that I'm playing with (I'll probably add something like this as a separate function):

gt_tbl <-  opt_css(gt_tbl, "
/* Hide the selection column */
.rt-td-select {
  display: none;
}

/* Style for selected rows */
.rt-tr-selected {
  background-color: black;
  color: white;
}")

I'm hoping I can learn a better way to wait for the tables to be "done" via the Discord!

[jonthegeek]

A more exhaustive demo app, which caught some bugs:

# Launch the ShinyApp (Do not remove this comment)
# To deploy, run: rsconnect::deployApp()
# Or use the blue button on top of this file
library(shiny)
pkgload::load_all(".", helpers = FALSE, attach_testthat = FALSE)

ui <- bslib::page_navbar(
  bslib::nav_panel(
    title = "filter",
    shiny::selectInput(
      "manufacturer",
      "Manufacturer:",
      sort(unique(gtcars$mfr))
    )
  ),
  bslib::nav_panel(
    title = "table",
    gt_output(outputId = "gt_table"),
    verbatimTextOutput("selected")
  ),
  bslib::nav_panel(
    title = "table2",
    gt_output(outputId = "gt_table2"),
    verbatimTextOutput("selected2")
  )
)

server <- function(input, output, session) {
  gt_data <- reactive({
    req(input$manufacturer)
    return(dplyr::filter(gtcars, .data$mfr == input$manufacturer))
  })

  output$gt_table <- render_gt(expr = {
    gt_data() |>
      gt() |>
      fmt_currency(columns = msrp, decimals = 0) |>
      cols_hide(columns = -c(mfr, model, year, mpg_c, msrp)) |>
      cols_label_with(columns = everything(), fn = toupper) |>
      data_color(columns = msrp, method = "numeric", palette = "viridis") |>
      sub_missing() |>
      opt_interactive(use_compact_mode = TRUE, selection = "multiple") |>
      opt_css(
        "/* Hide the selection column */
.rt-td-select {
  display: none;
}

/* Style for selected rows */
.rt-tr-selected {
  background-color: black;
  color: white;
}"
      )
  })
  output$selected <- renderPrint({
    gt_data()$model[input$gt_table]
  })

  output$gt_table2 <- render_gt(expr = {
    gtcars |>
      gt() |>
      fmt_currency(columns = msrp, decimals = 0) |>
      cols_hide(columns = -c(mfr, model, year, mpg_c, msrp)) |>
      cols_label_with(columns = everything(), fn = toupper) |>
      data_color(columns = msrp, method = "numeric", palette = "viridis") |>
      sub_missing() |>
      opt_interactive(use_compact_mode = TRUE, selection = "multiple") |>
      opt_css(
        "/* Hide the selection column */
.rt-td-select {
  display: none;
}

/* Style for selected rows */
.rt-tr-selected {
  background-color: black;
  color: white;
}"
      )
  })
  output$selected2 <- renderPrint({
    input$gt_table2
  })
}

shinyApp(ui = ui, server = server)

I'd still like to get tests in place for the Shiny part, since it's much more involved now (but none of the Shiny is currently tested). I also need to test what happens if a gt table is added dynamically. I still feel like there HAS to be a way to get Shiny to see the gt tables without the bindAll() MutationObserver, but so far I can't get it to work right without that.

[jonthegeek]

Pulling this back to draft to add an update function. If we're highlighting selections, I want to be able to set the highlight.

[jonthegeek]

@rich-iannone I fixed the pkgdown issue. Let me know what else you need!

[jonthegeek]

Found another corner: sorting sends an event that causes the selection to update (potentially to "nothing selected"), which shouldn't be seen as a change. Fixing.

[jonthegeek]

Adding pre-selected values is proving tricky using the option system. I don't see a way for an option to be an integer or logical vector, and I'm not sure it would fit there even if it were possible. I can work around that not being there for my use case, so I think I'd rather hold onto that for a future PR.

Which is all to say... I think this is ready again!

[rich-iannone]

LGTM!

[jonthegeek]

@rich-iannone Sorry about that! Evidently I never ran that suite of tests after I renamed the fields. I was trying to make room to pass in pre-selected values, and forgot to fix the test after I rolled back almost everything (other than the name of the field).

Should be good now, for real this time!

[rich-iannone]

@jonthegeek thanks for all your work on this!