From 71cdf5228c9906387a9de77533973b66056b1cf9 Mon Sep 17 00:00:00 2001 From: Duncan Murdoch Date: Wed, 24 May 2023 10:10:30 -0400 Subject: [PATCH 1/4] Add "aria-labelledby" attribute to default widget_html() output. --- NEWS.md | 5 ++++- R/htmlwidgets.R | 6 ++++-- tests/testthat/test-htmlwidgets.R | 2 +- 3 files changed, 9 insertions(+), 4 deletions(-) diff --git a/NEWS.md b/NEWS.md index a4ebc950..6979765c 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,11 +1,14 @@ htmlwidgets 1.6.2.9000 ------------------------------------------------------ +* Added `aria-labelledby` attribute to the `widget_html.default()` +output to work with accessibility improvements in `knitr` version +1.42.12. htmlwidgets 1.6.2 ------------------------------------------------------ -* Closed #452: `as.tag.htmlwidget()` now includes `...` in it's function signature (for compatibility with the `htmltools::as.tags` generic). +* Closed #452: `as.tag.htmlwidget()` now includes `...` in its function signature (for compatibility with the `htmltools::as.tags` generic). htmlwidgets 1.6.1 ------------------------------------------------------ diff --git a/R/htmlwidgets.R b/R/htmlwidgets.R index 2c78cec2..ea9113a2 100644 --- a/R/htmlwidgets.R +++ b/R/htmlwidgets.R @@ -286,9 +286,11 @@ widget_html <- function(name, package, id, style, class, inline = FALSE, ...) { widget_html.default <- function (name, package, id, style, class, inline = FALSE, ...) { if (inline) { - tags$span(id = id, style = style, class = class) + tags$span(id = id, style = style, class = class, + "aria-labelledby" = paste0(id, "-aria")) } else { - tags$div(id = id, style = style, class = class) + tags$div(id = id, style = style, class = class, + "aria-labelledby" = paste0(id, "-aria")) } } diff --git a/tests/testthat/test-htmlwidgets.R b/tests/testthat/test-htmlwidgets.R index cac418b6..4bdcec0b 100644 --- a/tests/testthat/test-htmlwidgets.R +++ b/tests/testthat/test-htmlwidgets.R @@ -33,7 +33,7 @@ test_that("New-style widget html methods do not trigger warning on non-tag outpu test_that("Fallback logic still works", { res <- widget_html("does_not_exist", "htmlwidgets", id = "id", style = NULL, class = NULL) - expect_identical(res, tags$div(id = "id")) + expect_identical(res, tags$div(id = "id", "aria-labelledby" = "id-aria")) }) test_that("Legacy methods work with tagList() and HTML()", { From 0f75439f6be6a3b36d56dd365701398539675186 Mon Sep 17 00:00:00 2001 From: Duncan Murdoch Date: Wed, 31 May 2023 08:16:01 -0400 Subject: [PATCH 2/4] Make use of `aria-labelledby` conditional on `htmlwidgets.USE_ARIA` option if present, otherwise in recent version of `knitr` with `fig.alt` in the chunk options. --- NEWS.md | 11 ++++++++--- R/htmlwidgets.R | 24 ++++++++++++++++++------ tests/testthat/test-htmlwidgets.R | 9 ++++++++- 3 files changed, 34 insertions(+), 10 deletions(-) diff --git a/NEWS.md b/NEWS.md index 6979765c..b6aefe90 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,9 +1,14 @@ htmlwidgets 1.6.2.9000 ------------------------------------------------------ -* Added `aria-labelledby` attribute to the `widget_html.default()` -output to work with accessibility improvements in `knitr` version -1.42.12. +* `widget_html.*` methods can now support a `use_aria` +argument to support accessibility. By default, this will be +`TRUE` in `knitr` version 1.42.12 if a `fig.alt` chunk option is +supplied. The default can be overridden by setting the +`"htmlwidgets.USE_ARIA"` option. +* Added optional `aria-labelledby` attribute to the +`widget_html.default()` output to work with accessibility improvements in `knitr`. `knitr` will insert the specified +`fig.alt` or `fig.cap` text if `use_aria` is `TRUE`. htmlwidgets 1.6.2 ------------------------------------------------------ diff --git a/R/htmlwidgets.R b/R/htmlwidgets.R index ea9113a2..f2ec2661 100644 --- a/R/htmlwidgets.R +++ b/R/htmlwidgets.R @@ -167,6 +167,12 @@ addHook <- function(x, hookName, jsCode, data = NULL) { x } +do_use_aria <- function(knitrOptions) { + getOption("htmlwidgets.USE_ARIA") %||% + ("fig.alt" %in% names(knitrOptions) && + requireNamespace("knitr") && + packageVersion("knitr") >= "1.42.12") +} toHTML <- function(x, standalone = FALSE, knitrOptions = NULL) { @@ -192,7 +198,8 @@ toHTML <- function(x, standalone = FALSE, knitrOptions = NULL) { if (sizeInfo$fill) "html-fill-item-overflow-hidden" ), width = sizeInfo$width, - height = sizeInfo$height + height = sizeInfo$height, + use_aria = do_use_aria(knitrOptions) ) html <- bindFillRole(html, item = sizeInfo$fill) @@ -257,18 +264,22 @@ lookup_widget_html_method <- function(name, package) { list(fn = widget_html.default, name = "widget_html.default", legacy = FALSE) } -widget_html <- function(name, package, id, style, class, inline = FALSE, ...) { +widget_html <- function(name, package, id, style, class, inline = FALSE, use_aria = FALSE, ...) { fn_info <- lookup_widget_html_method(name, package) fn <- fn_info[["fn"]] # id, style, and class have been required args for years, but inline is fairly new - # and undocumented, so unsuprisingly there are widgets out there are don't have an + # and undocumented, so unsurprisingly there are widgets out there that don't have an # inline arg https://github.com/renkun-ken/formattable/blob/484777/R/render.R#L79-L88 args <- list(id = id, style = style, class = class, ...) if ("inline" %in% names(formals(fn))) { args$inline <- inline } + # use_aria was added to support accessibility in knitr + if ("use_aria" %in% names(formals(fn))) { + args$use_aria <- use_aria + } fn_res <- do.call(fn, args) if (isTRUE(fn_info[["legacy"]])) { # For the PACKAGE:::NAME_html form (only), we worry about false positives; @@ -284,10 +295,11 @@ widget_html <- function(name, package, id, style, class, inline = FALSE, ...) { fn_res } -widget_html.default <- function (name, package, id, style, class, inline = FALSE, ...) { +widget_html.default <- function (name, package, id, style, class, inline = FALSE, use_aria = FALSE, ...) { if (inline) { - tags$span(id = id, style = style, class = class, - "aria-labelledby" = paste0(id, "-aria")) + tags$span(id = id, style = style, class = class) + } else if (!use_aria) { + tags$div(id = id, style = style, class = class) } else { tags$div(id = id, style = style, class = class, "aria-labelledby" = paste0(id, "-aria")) diff --git a/tests/testthat/test-htmlwidgets.R b/tests/testthat/test-htmlwidgets.R index 4bdcec0b..1797bf89 100644 --- a/tests/testthat/test-htmlwidgets.R +++ b/tests/testthat/test-htmlwidgets.R @@ -33,7 +33,7 @@ test_that("New-style widget html methods do not trigger warning on non-tag outpu test_that("Fallback logic still works", { res <- widget_html("does_not_exist", "htmlwidgets", id = "id", style = NULL, class = NULL) - expect_identical(res, tags$div(id = "id", "aria-labelledby" = "id-aria")) + expect_identical(res, tags$div(id = "id")) }) test_that("Legacy methods work with tagList() and HTML()", { @@ -42,3 +42,10 @@ test_that("Legacy methods work with tagList() and HTML()", { widget_html("widgetF", "htmlwidgets", id = "id", style = NULL, class = NULL) }, NA) }) + +test_that("The widget_html.default respects use_aria option", { + res <- widget_html("does_not_exist", "htmlwidgets", id = "id", style = NULL, class = NULL, use_aria = TRUE) + expect_identical(res, tags$div(id = "id", "aria-labelledby" = "id-aria")) + res <- widget_html("does_not_exist", "htmlwidgets", id = "id", style = NULL, class = NULL, use_aria = FALSE) + expect_identical(res, tags$div(id = "id")) +}) From f5b93f52a6d6d51d5bea0b387c8eee3d65fc3ae7 Mon Sep 17 00:00:00 2001 From: Duncan Murdoch Date: Wed, 31 May 2023 13:14:17 -0400 Subject: [PATCH 3/4] Add "Accessibility" subsection to advanced vignette. --- vignettes/develop_advanced.Rmd | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/vignettes/develop_advanced.Rmd b/vignettes/develop_advanced.Rmd index 3182acbd..b5c28572 100644 --- a/vignettes/develop_advanced.Rmd +++ b/vignettes/develop_advanced.Rmd @@ -187,3 +187,31 @@ Note that this function is looked up within the package implementing the widget (**htmlwidgets** 1.5.2 and earlier used a convention of widgetname_html. This is still supported for now, but the new widget_html.widgetname convention is recommended going forward, as it seems less likely to lead to false positives.) Most widgets won't need a custom HTML function but if you need to generate custom HTML for your widget (e.g. you need an `` or a `` rather than a `
`) then you should use the **htmltools** package (as demonstrated by the code above). + +### Accessibility + +By default, widgets will usually be invisible to screen readers +and other accessibility aids, but there is now some support +in `htmlwidgets` when used with `knitr` version 1.42.12 or higher. +That version added support for including alternate text in a +widget: if the +HTML housing for the widget contains an `aria-labelledby` +attribute, `knitr` will construct a label based on the +`fig.alt` or `fig.cap` text provided in the chunk options. + +To support this, the `widget_html.default` function has a +new argument `use_aria`. If `TRUE`, it will insert an +`aria-labelledby` attribute containing `-aria`, where +`` is the id of the widget. If custom widgets have that +argument, they'll also receive the value. + +The value will be automatically set to `TRUE` if the installed version +of `knitr` is sufficient and the `htmlwidgets::toHTML` function detects +a `fig.alt` setting in `knitrOptions`. This setting can +be overridden by setting `options("htmlwidgets.USE_ARIA")` to +`TRUE` or `FALSE`. + +Widget developers are advised to test this feature with one or +more screen readers, as they are not entirely consistent in +supporting it. For example, the `rgl` package added a `role="img"` +attribute so that one screen reader would detect its figures. From cda6f67fec44ea906589277204724acdff70d30f Mon Sep 17 00:00:00 2001 From: dmurdoch Date: Tue, 20 Jun 2023 18:02:42 -0400 Subject: [PATCH 4/4] Avoid loading knitr if it wasn't loaded. Co-authored-by: Carson Sievert --- R/htmlwidgets.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/htmlwidgets.R b/R/htmlwidgets.R index f2ec2661..163ac92b 100644 --- a/R/htmlwidgets.R +++ b/R/htmlwidgets.R @@ -170,7 +170,7 @@ addHook <- function(x, hookName, jsCode, data = NULL) { do_use_aria <- function(knitrOptions) { getOption("htmlwidgets.USE_ARIA") %||% ("fig.alt" %in% names(knitrOptions) && - requireNamespace("knitr") && + isNamespaceLoaded("knitr") && packageVersion("knitr") >= "1.42.12") }