R/shiny.R

In glin/reactable: Interactive Data Tables for R

#' Update a reactable instance
#'
#' `updateReactable()` updates a reactable instance within a Shiny application.
#'
#' @param outputId The Shiny output ID of the `reactable` instance.
#' @param data Table data. A data frame or matrix.
#'
#'   `data` should have the same columns as the original table data.
#'   When updating `data`, the selected rows, expanded rows, and current page
#'   will reset unless explicitly specified. All other state will persist,
#'   including sorting, filtering, and grouping state.
#' @param selected Selected rows. Either a numeric vector of row indices,
#'   or `NA` to deselect all rows.
#' @param expanded Expanded rows. Either `TRUE` to expand all rows, or `FALSE`
#'   to collapse all rows.
#' @param page The current page. A single, positive integer.
#' @param meta Custom table metadata. Either a named list with new values, or `NA`
#'   to clear all metadata. New values are merged into the current metadata, so only
#'   the values specified in `meta` will be updated.
#' @param session The Shiny session object. Defaults to the current Shiny session.
#' @return None
#'
#' @examples
#' # Run in an interactive R session
#' if (interactive()) {
#'
#' library(shiny)
#' library(reactable)
#'
#' data <- MASS::Cars93[, 1:7]
#'
#' ui <- fluidPage(
#'   actionButton("select_btn", "Select rows"),
#'   actionButton("clear_btn", "Clear selection"),
#'   actionButton("expand_btn", "Expand rows"),
#'   actionButton("collapse_btn", "Collapse rows"),
#'   actionButton("page_btn", "Change page"),
#'   selectInput("filter_type", "Filter type", unique(data$Type), multiple = TRUE),
#'   reactableOutput("table")
#' )
#'
#' server <- function(input, output) {
#'   output$table <- renderReactable({
#'     reactable(
#'       data,
#'       filterable = TRUE,
#'       searchable = TRUE,
#'       selection = "multiple",
#'       details = function(index) paste("Details for row:", index)
#'     )
#'   })
#'
#'   observeEvent(input$select_btn, {
#'     # Select rows
#'     updateReactable("table", selected = c(1, 3, 5))
#'   })
#'
#'   observeEvent(input$clear_btn, {
#'     # Clear row selection
#'     updateReactable("table", selected = NA)
#'   })
#'
#'   observeEvent(input$expand_btn, {
#'     # Expand all rows
#'     updateReactable("table", expanded = TRUE)
#'   })
#'
#'   observeEvent(input$collapse_btn, {
#'     # Collapse all rows
#'     updateReactable("table", expanded = FALSE)
#'   })
#'
#'   observeEvent(input$page_btn, {
#'     # Change current page
#'     updateReactable("table", page = 3)
#'   })
#'
#'   observe({
#'     # Filter data
#'     filtered <- if (length(input$filter_type) > 0) {
#'       data[data$Type %in% input$filter_type, ]
#'     } else {
#'       data
#'     }
#'     updateReactable("table", data = filtered)
#'   })
#' }
#'
#' shinyApp(ui, server)
#' }
#'
#' @export
updateReactable <- function(outputId, data = NULL, selected = NULL, expanded = NULL,
                            page = NULL, meta = NULL, session = NULL) {
  if (is.null(session)) {
    if (requireNamespace("shiny", quietly = TRUE)) {
      session <- shiny::getDefaultReactiveDomain()
    }
    if (is.null(session)) {
      # Not in an active Shiny session
      return(invisible(NULL))
    }
  }

  if (!is.character(outputId)) {
    stop("`outputId` must be a character string")
  }
  outputId <- session$ns(outputId)

  dataKey <- NULL
  if (!is.null(data)) {
    if (!is.data.frame(data) && !is.matrix(data)) {
      stop("`data` must be a data frame or matrix")
    }
    dataKey <- digest::digest(data)
    # Reset selected, expanded, and page state by default
    selected <- if (is.null(selected)) NA else selected
    expanded <- if (is.null(expanded)) FALSE else expanded
    page <- if (is.null(page)) 1 else page
  }

  if (!is.null(selected)) {
    if (!is.numeric(selected) && !is.na(selected)) {
      stop("`selected` must be numeric or NA")
    }
    selected <- stats::na.omit(selected)
    # Convert to 0-based indexing
    selected <- as.list(as.integer(selected) - 1)
  }

  if (!is.null(expanded) && !is.logical(expanded)) {
    stop("`expanded` must be TRUE or FALSE")
  }

  if (!is.null(page)) {
    if (!is.numeric(page) || length(page) != 1 || page <= 0) {
      stop("`page` must be a single, positive integer")
    }
    # Convert to 0-based indexing
    page <- as.integer(page - 1)
  }

  if (!is.null(meta)) {
    if (!isNamedList(meta) && !is.na(meta)) {
      stop("`meta` must be a named list or NA")
    }
    # Allow empty lists, but don't serialize them as an empty array, []
    if (identical(meta, list())) {
      meta <- NULL
    }
  }

  # Get JS evals for meta. Exclude other props like data - although data could
  # potentially have JS() code within list-columns, it's not supported by reactable(), and
  # JS() code just ends up as a string.
  jsEvals <- htmlwidgets::JSEvals(list(meta = meta))
  if (length(jsEvals) == 0) {
    jsEvals <- NULL
  }

  newState <- filterNulls(list(
    data = data,
    dataKey = dataKey,
    selected = selected,
    expanded = expanded,
    page = page,
    meta = meta,
    jsEvals = jsEvals
  ))

  if (length(newState) > 0) {
    session$sendCustomMessage(sprintf("__reactable__%s", outputId), newState)
  }
}

#' Get the state of a reactable instance
#'
#' `getReactableState()` gets the state of a reactable instance within a Shiny application.
#'
#' @param outputId The Shiny output ID of the `reactable` instance.
#' @param name Character vector of state value(s) to get. Values must be one of `"page"`,
#'   `"pageSize"`, `"pages"`, `sorted`, or `"selected"`. If unspecified, all values will
#'   be returned.
#' @param session The Shiny session object. Defaults to the current Shiny session.
#' @return If `name` is specified, one of the following values:
#'
#'   - `page`: the current page
#'   - `pageSize`: the page size
#'   - `pages`: the number of pages
#'   - `sorted`: the sorted columns - a named list of columns with values of `"asc"` for
#'      ascending order or `"desc"` for descending order, or `NULL` if no columns are sorted
#'   - `selected`: the selected rows - a numeric vector of row indices, or `NULL` if no rows are selected
#'
#'  If `name` contains more than one value, `getReactableState()` returns a named list of
#'  the specified values.
#'
#'  If `name` is unspecified, `getReactableState()` returns a named list containing all values.
#'
#'  If the table has not been rendered yet, `getReactableState()` returns `NULL`.
#'
#' @examples
#' # Run in an interactive R session
#' if (interactive()) {
#'
#' library(shiny)
#' library(reactable)
#' library(htmltools)
#'
#' ui <- fluidPage(
#'   actionButton("prev_page_btn", "Previous page"),
#'   actionButton("next_page_btn", "Next page"),
#'   reactableOutput("table"),
#'   verbatimTextOutput("table_state"),
#'   uiOutput("selected_row_details")
#' )
#'
#' server <- function(input, output) {
#'   output$table <- renderReactable({
#'     reactable(
#'       MASS::Cars93[, 1:5],
#'       showPageSizeOptions = TRUE,
#'       selection = "multiple",
#'       onClick = "select"
#'     )
#'   })
#'
#'   output$table_state <- renderPrint({
#'     state <- req(getReactableState("table"))
#'     print(state)
#'   })
#'
#'   observeEvent(input$prev_page_btn, {
#'     # Change to the previous page
#'     page <- getReactableState("table", "page")
#'     if (page > 1) {
#'       updateReactable("table", page = page - 1)
#'     }
#'   })
#'
#'   observeEvent(input$next_page_btn, {
#'     # Change to the next page
#'     state <- getReactableState("table")
#'     if (state$page < state$pages) {
#'       updateReactable("table", page = state$page + 1)
#'     }
#'   })
#'
#'   output$selected_row_details <- renderUI({
#'     selected <- getReactableState("table", "selected")
#'     req(selected)
#'     details <- MASS::Cars93[selected, -c(1:5)]
#'     tagList(
#'       h2("Selected row details"),
#'       tags$pre(
#'         paste(capture.output(print(details, width = 1200)), collapse = "\n")
#'       )
#'     )
#'   })
#' }
#'
#' shinyApp(ui, server)
#' }
#'
#' @export
getReactableState <- function(outputId, name = NULL, session = NULL) {
  if (is.null(session)) {
    if (requireNamespace("shiny", quietly = TRUE)) {
      session <- shiny::getDefaultReactiveDomain()
    }
    if (is.null(session)) {
      # Not in an active Shiny session
      return(NULL)
    }
  }
  if (!is.character(outputId)) {
    stop("`outputId` must be a character string")
  }

  getState <- function(outputId, name) {
    # NOTE: input IDs must always come first to work with Shiny modules
    session$input[[sprintf("%s__reactable__%s", outputId, name)]]
  }

  props <- c("page", "pageSize", "pages", "sorted", "selected")
  if (!is.null(name)) {
    if (!is.character(name) || any(!name %in% props)) {
      stop(paste("`name` values must be one of", paste(sprintf('"%s"', props), collapse = ", ")))
    }
    if (length(name) == 1) {
      return(getState(outputId, name))
    } else {
      props <- name
    }
  }

  state <- stats::setNames(
    lapply(props, function(prop) {
      getState(outputId, prop)
    }),
    props
  )

  if (length(filterNulls(state)) == 0) {
    return(NULL)
  }

  state
}

#' Create custom server-side data backends for Shiny
#'
#' @description
#' Custom server-side data backends are created using the
#' [S3 object system](https://adv-r.hadley.nz/s3.html).
#'
#' To create a custom server-side data backend, provide an S3 object to the
#' `server` argument in [reactable()] with the following S3 methods defined:
#'
#' - `reactableServerInit` initializes the server backend (optional).
#' - `reactableServerData` handles requests for data and should return a
#'   [resolvedData()] object.
#'
#' Custom backend methods do not have to accept every argument, and can choose
#' not to implement certain features such as grouping, row expansion, or
#' row selection.
#'
#' If there is no server-side implementation for row expansion and row selection,
#' reactable will fall back to client-side row expansion and selection. This means
#' row expansion and selection will only work for rows on the current page, so for
#' example, selecting all rows in the table will only select rows on the current page.
#'
#' Custom backend methods should accept additional arguments via `...` in case
#' new arguments are added in the future.
#'
#' @param x The server backend.
#' @param data The original table data. A data frame.
#' @param columns Table columns. A list of [colDef()] objects.
#' @param pageIndex The current page index. Starts at zero.
#' @param pageSize The current page size.
#' @param sortBy The current sorted columns. `NULL` if empty.
#' @param filters The current column filters. `NULL` if empty.
#' @param searchValue The current global search value. `NULL` if empty.
#' @param searchMethod The custom search method. A [JS()] function.
#' @param groupBy The current grouped columns. `NULL` if empty.
#' @param pagination Whether pagination is enabled, `TRUE` or `FALSE`.
#' @param paginateSubRows Whether sub rows are paginated, `TRUE` or `FALSE`.
#' @param expanded The current expanded rows.
#' @param selectedRowIds The current selected rows.
#' @param ... Additional arguments passed to the S3 method.
#' @return
#' - `reactableServerData()` should return a [resolvedData()] object.
#' - `reactableServerData()` should not return any value.
#'
#' @name reactable-server
#'
#' @export
reactableServerInit <- function(
  x,
  data = NULL,
  columns = NULL,
  pageIndex = 0,
  pageSize = 0,
  sortBy = NULL,
  filters = NULL,
  searchValue = NULL,
  searchMethod = NULL,
  groupBy = NULL,
  pagination = NULL,
  paginateSubRows = NULL,
  selectedRowIds = NULL,
  expanded = NULL,
  ...
) {
  UseMethod("reactableServerInit")
}

#' @rdname reactable-server
#'
#' @export
reactableServerData <- function(
    x,
    data = NULL,
    columns = NULL,
    pageIndex = 0,
    pageSize = 0,
    sortBy = NULL,
    filters = NULL,
    searchValue = NULL,
    searchMethod = NULL,
    groupBy = NULL,
    pagination = NULL,
    paginateSubRows = NULL,
    selectedRowIds = NULL,
    expanded = NULL,
    ...
) {
  UseMethod("reactableServerData")
}

# Default reactableServerInit method: no-op, since initialization is optional.
reactableServerInit.default <- function(...) {
  # No-op
}

# Default reactableServerData method
reactableServerData.default <- function(...) {
  stop(
    "reactable server backends must have a `reactableServerData` S3 method defined.\n\nFor more details, see `?reactable::reactableServerData`",
    call. = FALSE
  )
}

#' The result from handling a server-side data request
#'
#' @param data The current page of data. A data frame.
#' @param rowCount The row count of the current page.
#' @param maxRowCount The maximum row count. Optional. Used to determine whether
#'   the pagination bar should be kept visible when filtering or searching
#'   reduces the current rows to one page, or when expanding rows
#'   (when paginateSubRows is `TRUE`) would expand the table beyond one page.
#'
#' @seealso [reactableServerInit()] and [reactableServerData()] for creating custom
#'   server-side data backends.
#'
#' @export
resolvedData <- function(data, rowCount = NULL, maxRowCount = NULL) {
  if (!is.data.frame(data)) {
    stop("`data` must be a data frame")
  }
  if (!is.numeric(rowCount)) {
    stop("`rowCount` must be provided and numeric")
  }
  if (!is.null(maxRowCount) && !is.numeric(maxRowCount)) {
    stop("`maxRowCount` must be numeric")
  }
  structure(
    list(data = data, rowCount = rowCount, maxRowCount = maxRowCount),
    class = "reactable_resolvedData"
  )
}

is.resolvedData <- function(x) {
  inherits(x, "reactable_resolvedData")
}

reactableFilterFunc <- function(data, req) {
  body <- rawToChar(req$rook.input$read())
  params <- parseParams(body)

  start <- Sys.time()
  resolvedData <- do.call(reactableServerData, c(list(data$backend), mergeLists(data, params)))
  end <- Sys.time()

  if (!is.resolvedData(resolvedData)) {
    stop("reactable server backends must return a `resolvedData()` object from `reactableServerData()`")
  }

  debugLog(sprintf("(reactableFilterFunc) time to resolve data: %s\n%s", format(end - start, units = "secs"), toJSON(resolvedData)))

  shiny::httpResponse(
    status = 200L,
    content_type = "application/json",
    content = toJSON(resolvedData)
  )
}

# Parse data parameters from JSON, ensuring arrays always deserialize as lists,
# and arrays of objects deserialize as lists instead of data frames.
parseParams <- function(json) {
  params <- jsonlite::parse_json(json, simplifyDataFrame = FALSE)
  params
}

getServerBackend <- function(backend = NULL) {
  if (!is.null(backend) && !is.character(backend)) {
    return(backend)
  }

  backends <- list(
    v8 = serverV8,
    df = serverDf,
    dt = serverDt
  )

  if (is.null(backend) || !backend %in% names(backends)) {
    backend <- "v8"
  }

  debugLog("(getServerBackend) using server backend:", backend)

  backends[[backend]]()
}