inst/examples/demo/app.R

In a11yShiny: Accessibility Enhancements to Popular R Shiny Functions

pkgname <- "a11yShiny"
if (!requireNamespace(pkgname, quietly = TRUE)) {
  if (requireNamespace("pkgload", quietly = TRUE)) {
    pkgload::load_all("../../")
  } else {
    stop(sprintf("Package '%s' not installed and 'pkgload' not available.", pkgname))
  }
} else {
  library(a11yShiny)
}

library(shiny)
library(shinyjs)
library(DT)
library(plotly)
library(ggplot2)

ui <-
  a11y_fluidPage(
    lang = "en-US",
    title = "Demo",

    # Optional header landmark (native HTML5 tag)
    header = tags$header(
      class = "page-header",
      tags$h1("Demo Dashboard"),
      tags$h2("A dashboard with elements from the a11yShiny R package for testing")
    ),
    useShinyjs(),

    # Optional aside landmark (complementary info)
    aside = tags$aside(
      class = "help-panel",
      tags$h2("Help"),
      tags$p(
        "Further information on the BITV 2.0 criteria can be found here: ",
        tags$a(
          href = "https://bitvtest.de/pruefverfahren/bitv-20-web",
          target = "_blank",
          rel = "noopener noreferrer",
          "https://bitvtest.de/pruefverfahren/bitv-20-web"
        )
      )
    ),

    # Optional footer landmark
    footer = tags$footer(
      tags$p("© 2025 Authors")
    ),

    # MAIN CONTENT (if you don't pass 'main=', everything in ... becomes <main>)
    a11y_fluidRow(
      a11y_column(
        8,
        p(
          HTML(
            "This demo compares standard R Shiny components with their accessible counterparts from the <strong>a11yShiny</strong> package.<br><br>
              Standard components are missing key accessibility features such as <code>aria-label</code>, <code>aria-describedby</code>, and other ARIA attributes.
              The accessible wrappers provided by a11yShiny add these attributes along with improved contrast, focus management, and keyboard navigation.<br><br>
              Each section below shows both versions side by side so you can see the differences.
              Use the <strong>High-Contrast</strong> button to toggle a high-contrast display mode."
          )
        )
      ),
      a11y_column(
        4,
        div(
          a11y_highContrastButton()
        ),
      )
    ),
    tags$hr(),
    a11y_fluidRow(
      a11y_column(4,
        aria_label = "Settings for the histogram",
        tags$p(id = "n_breaks_help", class = "a11y-help", "Choose a number of bins for the histogram."),
        selectInput("n_breaks", label = NULL, choices = c(10, 20, 35, 50)),
        a11y_selectInput(inputId = "n_breaks_1", label = "Number of bins (accessible)", choices = c(10, 20, 35, 50), selected = 20, heading_level = 3),
        a11y_selectInput(inputId = "n_breaks_2", label = "Number of bins (accessible)", choices = c(10, 20, 35, 50), selected = 20, describedby_text = "Choose the number of bins."),
      ),
      a11y_column(
        4,
        tags$p(id = "seed_help", class = "a11y-help", "Seed for random number generator."),
        numericInput("seed", label = NULL, value = 123),
        a11y_numericInput(inputId = "seed_3", label = "Seed (accessible)", value = 123, heading_level = 6, describedby_text = "Choose the seed for the random number generator."),
        a11y_numericInput(inputId = "seed_1", label = "Seed (accessible)", value = 123, describedby = "seed_help"),
      ),
      a11y_column(
        4,
        dateInput("mydate", "Choose a date:"),
        a11y_dateInput("mydate_acc", "Choose a date (accessible):", language = "en", heading_level = 2)
      )
    ),
    tags$hr(),
    a11y_fluidRow(
      a11y_column(
        3,
        textInput("mytext", "Your text:"),
        a11y_textInput("mytext_acc", "Your text (accessible):")
      ),
      a11y_column(
        3,
        tags$div(
          radioButtons("radio_choice", "Choose something:",
            choices = list("Choice 1" = 1, "Choice 2" = 2, "Choice 3" = 3),
            selected = 1
          ),
          a11y_radioButtons("radio_choice_acc", "Choose something (accessible):",
            choices = list("Choice 1" = 1, "Choice 2" = 2, "Choice 3" = 3),
            selected = 1
          )
        )
      ),
      a11y_column(
        6,
        div(
          id = "search-row",
          style = "display: flex; align-items: center; gap: 12px;",
          textInput("searchbox", label = NULL, placeholder = "Enter your question:", width = "100%"),
          actionButton(
            "do_search",
            label = NULL,
            icon = icon("search")
          )
        ),
        div(
          a11y_textButtonGroup(
            textId = "text-acc",
            buttonId = "btn-acc",
            label = "Enter your question (accessible):",
            value = "",
            placeholder = NULL,
            button_label = NULL,
            button_icon = icon("search"),
            button_aria_label = "Search",
            controls = NULL,
            layout = c("inline", "stack"),
            text_describedby = NULL,
            text_describedby_text = NULL,
            text_heading_level = NULL
          )
        )
      )
    ),
    tags$hr(),
    a11y_fluidRow(
      a11y_column(
        4,
        div(h3("Address")),
        textInput("adr_street", "Street and house number"),
        textInput("adr_postcode", "ZIP code"),
        textInput("adr_city", "City"),
        textInput("adr_country", "Country")
      ),
      a11y_column(
        4,
        a11y_textInputsGroup(
          groupId = "address_group",
          legend = "Address",
          inputs = list(
            list(
              inputId = "adr_street_acc",
              label   = "Street and house number"
            ),
            list(
              inputId = "adr_postcode_acc",
              label   = "ZIP code"
            ),
            list(
              inputId = "adr_city_acc",
              label   = "City"
            ),
            list(
              inputId = "adr_country_acc",
              label   = "Country"
            )
          ),
          describedby_text = "Please enter your full postal address here.",
          legend_heading_level = 3
        )
      ),
      a11y_column(
        2,
        tags$p(id = "buttons_help", class = "a11y-help", "Buttons to refresh."),
        actionButton(inputId = "refresh", label = NULL, icon = icon("refresh", lib = "font-awesome", class = "fa-refresh"), style = "margin: 5px;"),
        actionButton(inputId = "refresh_0", label = NULL, style = "margin: 5px;")
      ),
      a11y_column(
        2,
        tags$p(id = "buttons_help_1", class = "a11y-help", "Buttons to refresh (accessible)."),
        a11y_actionButton(inputId = "refresh_1", label = "Refresh", icon = icon("refresh", lib = "font-awesome", class = "fa-refresh"), style = "margin: 5px;"),
        a11y_actionButton(inputId = "refresh_2", icon = icon("refresh", lib = "font-awesome", class = "fa-refresh"), aria_label = "Click to refresh", style = "margin: 5px;"),
        a11y_actionButton(inputId = "refresh_3", label = "Refresh", aria_label = "Click to refresh", style = "margin: 5px;")
      )
    ),
    tags$hr(),
    a11y_fluidRow(
      a11y_column(
        6,
        tags$p(id = "plt_help", class = "a11y-help", "Simple bar chart.", style = "height: 40px; margin-top: 10px;"),
        plotlyOutput("plt_line"),
        plotlyOutput("plt_bar")
      ),
      a11y_column(
        6,
        tags$p(id = "plt_help_1", class = "a11y-help", "Simple bar chart (accessible).", style = "height: 40px; margin-top: 10px;"),
        plotlyOutput("plt_acc_line"),
        plotlyOutput("plt_acc_bar")
      )
    ),
    tags$hr(),
    a11y_fluidRow(
      a11y_column(
        6,
        tags$p(id = "tbl_help", class = "a11y-help", "Table of the first 10 observations.", style = "height: 40px; margin-top: 10px;"),
        dataTableOutput("tbl")
      ),
      a11y_column(
        6,
        tags$p(id = "tbl_help_1", class = "a11y-help", "Table of the first 10 observations (reduced barriers).", style = "height: 40px; margin-top: 10px;"),
        div(
          # Use the class "a11y-dt" for accessible DataTable styling
          class = "a11y-dt",
          dataTableOutput("tbl_acc")
        )
      )
    )
  )

server <- function(input, output, session) {
  # Example data set (line chart)
  set.seed(123)
  n <- 50
  time <- seq.Date(from = as.Date("2025-01-01"), by = "month", length.out = n)
  group <- rep(c("A", "B", "C"), each = n)
  value <- c(
    cumsum(rnorm(n, 0.5, 2)),
    cumsum(rnorm(n, 0.2, 2)),
    cumsum(rnorm(n, -0.1, 2))
  )
  df <- data.frame(time = rep(time, 3), value = value, group = group)
  df_small <- df[df$time %in% head(unique(df$time), 10), ]

  # Example data set (bar chart)
  iris_mean <- aggregate(Sepal.Length ~ Species, data = iris, mean)

  # Multi-line time series chart for three groups
  output$plt_line <- plotly::renderPlotly({
    p <- ggplot(df_small, aes(x = time, y = value, color = group)) +
      geom_line() +
      geom_point() +
      scale_color_manual(values = c("A" = "#A8A8A8", "B" = "#FEF843", "C" = "#6E787F")) +
      labs(title = "Simulated time series by group", x = "Date", y = "Measurement") +
      theme_minimal()
    plotly::ggplotly(p)
  })

  output$plt_acc_line <- renderPlotly({
    p <- a11y_ggplot2_line(
      data = df_small,
      x = time,
      y = value,
      group = group,
      legend_title = "Group",
      title = "Simulated time series by group (reduced barriers)"
    )
    # Add additional ggplot2 layers/customizations
    p <- p +
      ggplot2::geom_hline(yintercept = 0, linetype = "dashed") +
      ggplot2::labs(
        x = "Date",
        y = "Measurement",
        subtitle = "Example with custom axis labels"
      )
    plotly::ggplotly(p)
  })

  output$plt_bar <- plotly::renderPlotly({
    p <- ggplot(iris_mean, aes(x = Species, y = Sepal.Length, fill = Species)) +
      geom_bar(stat = "identity") +
      scale_fill_manual(values = c("#A8A8A8", "#FEF843", "#6E787F")) +
      labs(
        title = "Average Sepal Length by Species (classic)",
        x = "Species",
        y = "Average Sepal Length (cm)"
      ) +
      theme_minimal() +
      ggplot2::geom_hline(yintercept = 4, linetype = "dashed") +
      ggplot2::labs(
        subtitle = "Example with custom axis labels"
      )
    plotly::ggplotly(p)
  })

  output$plt_acc_bar <- renderPlotly({
    p <- a11y_ggplot2_bar(
      data = iris_mean,
      x = Species,
      y = Sepal.Length,
      legend_title = "Species",
      title = "Average Sepal Length by Species (reduced barriers)"
    )
    # Add additional ggplot2 layers/customizations
    p <- p +
      ggplot2::geom_hline(yintercept = 4, linetype = "dashed") +
      ggplot2::labs(
        x = "Species",
        y = "Average Sepal Length (cm)",
        subtitle = "Example with custom axis labels"
      )
    plotly::ggplotly(p)
  })

  # Datatable

  output$tbl <- DT::renderDataTable({
    DT::datatable(
      head(iris[, 1:4], 10),
      filter = "top", selection = "none",
      options = list(
        pageLength = 5,
        dom = "Bfrtip", buttons = c("excel", "copy", "csv", "pdf", "print")
      )
    )
  })
  output$tbl_acc <- a11y_renderDataTable(
    {
      head(iris[, 1:4], 10)
    },
    lang = "en",
    selection = "none",
    extensions = c("Buttons"),
    options = list(pageLength = 5, dom = "Bfrtip", buttons = c("excel", "csv"))
  )
}

shinyApp(ui, server)