R/datatable.R

In a11yShiny: Accessibility Enhancements to Popular R Shiny Functions

#' Accessible DataTable renderer
#'
#' A wrapper for [DT::renderDataTable()] that enables keyboard navigation
#' (KeyTable extension) by default and provides built-in German/English
#' translations.
#'
#' @param expr Table expression
#' @param lang Language code (`"de"` or `"en"`), or `NULL` if `dt_language` is
#'   set in `expr()`
#' @param dt_language (optional) DT language list (see DT docs); required when
#'   using a language other than `"de"`/`"en"`
#' @param ... Other [DT::renderDataTable()] arguments
#' @return A Shiny render function
#'
#' @examples
#' \donttest{
#' # Inside a Shiny server function
#' if (interactive()) {
#'   library(shiny)
#'   server <- function(input, output, session) {
#'     output$table <- a11y_renderDataTable(
#'       expr = mtcars[, 1:5],
#'       lang = "en"
#'     )
#'   }
#' }
#'
#' # German-language table with Buttons extension and accessible export options
#' if (interactive()) {
#'   library(shiny)
#'   server <- function(input, output, session) {
#'     output$table_de <- a11y_renderDataTable(
#'       expr = head(iris[, 1:4], 10),
#'       lang = "de",
#'       selection = "none",
#'       extensions = c("Buttons"),
#'       options = list(
#'         pageLength = 5,
#'         dom = "Bfrtip",
#'         buttons = c("excel", "csv")
#'       )
#'     )
#'   }
#' }
#' }
#'
#' @importFrom utils modifyList
#' @export
a11y_renderDataTable <- function(expr,
                                 lang = NULL,
                                 dt_language = NULL,
                                 ...) {
  args <- list(...)
  # Extract and remove options from ... to prevent duplication in DT::datatable
  options_list <- if (!is.null(args$options)) args$options else list()
  args$options <- NULL

  # Active KeyTable per Default (for enhanced keyboard usage)
  extensions_list <- if (!is.null(args$extensions)) args$extensions else character()
  if (!"KeyTable" %in% extensions_list) {
    extensions_list <- unique(c(extensions_list, "KeyTable"))
  }
  args$extensions <- extensions_list
  if (is.null(options_list$keys)) {
    options_list$keys <- TRUE
  }

  # Check for copy, pdf, and print in buttons-options
  all_extensions <- unique(c("Buttons", unlist(args$extensions, use.names = FALSE)))
  has_inaccessible_button <- FALSE
  inaccessible_buttons <- c()
  for (btn in c("copy", "pdf", "print")) {
    if (!is.null(options_list$buttons) && (btn %in% options_list$buttons || any(grepl(btn, options_list$buttons)))) {
      has_inaccessible_button <- TRUE
      inaccessible_buttons <- c(inaccessible_buttons, btn)
    }
  }
  # Warning if any of these buttons is used
  if ("Buttons" %in% all_extensions && has_inaccessible_button) {
    warning(
      "a11y_renderDataTable: The Copy, Pdf and Print DataTable (Buttons extension) buttons are not accessible; ",
      "the modal dialog and the opening of tabs is difficult for screenreader and keyboard users. ",
      "Consider disabling these buttons or offering accessible alternatives",
      call. = FALSE
    )
  }
  # Warning if filter is used
  filter_is_set <- (!is.null(args$filter)) && (tolower(args$filter) %in% c("top", "bottom"))
  if (filter_is_set) {
    warning(
      "a11y_renderDataTable: DataTable column filters (filter = \"top\"/\"bottom\") are not accessible by default; ",
      "especially the numeric range filter is not screenreader and keyboard accessible. ",
      "Consider documenting this or using accessible alternatives",
      call. = FALSE
    )
  }

  # dt_language is passed to DT::datatable during the render process
  DT::renderDataTable({
    table <- eval(expr)
    # Language object may be passed if needed (CDN)
    if (!is.null(dt_language)) {
      do.call(DT::datatable, c(list(table,
        language = dt_language,
        options = options_list
      ), args))
    } else if (!is.null(lang) && lang == "de") {
      options_list$language$url <- NULL
      do.call(
        DT::datatable,
        c(list(table,
          options = modifyList(
            list(
              language =
                get_german_translation()
            ),
            options_list
          )
        ), args)
      )
    } else if (!is.null(lang) && lang == "en") {
      do.call(DT::datatable, c(list(table, options = options_list), args))
    } else {
      # Internationalisation is only set for de/en by default, other languages must be set via plug-in explicitly
      stop("a11y_renderDataTable: Please set 'lang' (de/en) or 'dt_language' (see DT::datatable documentation for details) explicitly", call. = FALSE)
    }
  })
}

#' German translations for DataTables
#'
#' Returns a list with German language strings that can be used with the
#' **DataTables** jQuery plugin (e.g., via the `language` option of the
#' `datatable()` function from the **DT** package).
#'
#' @return A nested list containing all translation strings required by
#'   DataTables. Sub-lists are provided for `oPaginate`, `oAria`,
#'   `select$rows`, and `buttons$copySuccess` to match the JSON structure
#'   expected by DataTables.
#'
#' @noRd
get_german_translation <- function() {
  list(
    sEmptyTable = "Keine Daten in der Tabelle vorhanden",
    sInfo = "_START_ bis _END_ von _TOTAL_ Eintr\u00e4gen",
    sInfoEmpty = "Keine Daten vorhanden",
    sInfoFiltered = "(gefiltert von _MAX_ Eintr\u00e4gen)",
    sInfoPostFix = "",
    sInfoThousands = ".",
    sLengthMenu = "_MENU_ Eintr\u00e4ge anzeigen",
    sLoadingRecords = "Wird geladen ..",
    sProcessing = "Bitte warten ..",
    sSearch = "Suchen",
    sZeroRecords = "Keine Eintr\u00e4ge vorhanden",
    oPaginate = list(
      sFirst    = "Erste",
      sPrevious = "Zur\u00fcck",
      sNext     = "N\u00e4chste",
      sLast     = "Letzte"
    ),
    oAria = list(
      sSortAscending  = ": aktivieren, um Spalte aufsteigend zu sortieren",
      sSortDescending = ": aktivieren, um Spalte absteigend zu sortieren"
    ),
    select = list(
      rows = list(
        `0`       = "",
        `1`       = "1 Zeile ausgew\u00e4hlt",
        `_`       = "%d Zeilen ausgew\u00e4hlt"
      )
    ),
    buttons = list(
      print = "Drucken",
      colvis = "Spalten",
      copy = "Kopieren",
      copyTitle = "In Zwischenablage kopieren",
      copyKeys = "Taste <i>ctrl</i> oder <i>\u2318</i> + <i>C</i> um Tabelle<br>in Zwischenspeicher zu kopieren.<br><br>Um abzubrechen die Nachricht anklicken oder Escape dr\u00fccken.",
      copySuccess = list(
        `_` = "%d Spalten kopiert",
        `1` = "1 Spalte kopiert"
      )
    )
  )
}