Accessible alternatives for radioButtons, checkboxGroupInput and fileInput added

DESCRIPTION

@@ -10,3 +10,8 @@ License: GPL (>= 3)
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.3.3
+Imports: 
+    htmltools,
+    jsonlite
+Suggests: 
+    shiny

NAMESPACE

@@ -1,2 +1,5 @@
 # Generated by roxygen2: do not edit by hand
 
+export(a11yCheckboxGroupInput)
+export(a11yFileInput)
+export(a11yRadioButtons)

R/a11yCheckboxGroupInput.R

@@ -0,0 +1,64 @@
+#' Checkbox Group Input Control
+#'
+#' Creates more accessible shiny group of shiny checkboxes
+#'
+#' @inheritParams shiny::checkboxGroupInput
+#'
+#' @param withSelectAll Create additional "select all"/"clear all" controls
+#'
+#' @seealso [shiny::checkboxGroupInput()]
+#'
+#' @export
+a11yCheckboxGroupInput <- function(
+	inputId, label, choices = NULL, selected = NULL, inline = FALSE,
+    width = NULL, choiceNames = NULL, choiceValues = NULL, withSelectAll = FALSE
+) {
+    args <- shiny:::normalizeChoicesArgs(
+    	choices, choiceNames, choiceValues, FALSE
+	)
+
+    selected <- shiny::restoreInput(id = inputId, default = selected)
+    if (!is.null(selected)) {
+        selected <- as.character(selected)
+    }
+
+    options <- shiny:::generateOptions(
+    	inputId, selected, inline, "checkbox", args$choiceNames,
+    	args$choiceValues
+	)
+
+    ctnrClass <- "form-group shiny-input-a11ycheckboxgroup shiny-input-container"
+    if (inline) {
+        ctnrClass <- paste(ctnrClass, "shiny-input-container-inline")
+    }
+
+    selectAll <- NULL
+    if (withSelectAll) {
+    	sa <- htmltools::tags$a(
+			href = "#",
+			onclick = "return checkAll(event)",
+			"select all",
+			class = "link select-all"
+		)
+		sn <- htmltools::tags$a(
+			href = "#",
+			onclick = "return clearAll(event)",
+			"clear all",
+			class = "link select-none"
+		)
+		selectAll <- htmltools::tags$div(
+			"(", sa, "/", sn, ")", class = "select-all-container"
+		)
+    }
+
+    fieldset <- htmltools::tags$fieldset(
+    	id = inputId,
+    	style = htmltools::css(width = htmltools::validateCssUnit(width)),
+        class = ctnrClass,
+        htmltools::tags$legend(label),
+        options,
+        selectAll
+    )
+
+	htmltools::attachDependencies(fieldset, accessibleShinyInputsDependency())
+}

R/a11yFileInput.R

@@ -0,0 +1,72 @@
+#' File Upload Control
+#'
+#' Creates more accessible shiny file upload input.
+#'
+#' @inheritParams shiny::fileInput
+#'
+#' @seealso [shiny::fileInput()]
+#'
+#' @export
+a11yFileInput <- function(
+	inputId, label, multiple = FALSE, accept = NULL, width = NULL,
+    buttonLabel = "Browse...", placeholder = "No file selected",
+    capture = NULL
+) {
+    restoredValue <- shiny::restoreInput(id = inputId, default = NULL)
+    if (!is.null(restoredValue) && !is.data.frame(restoredValue)) {
+        warning("Restored value for ", inputId, " has incorrect format.")
+        restoredValue <- NULL
+    }
+    if (!is.null(restoredValue)) {
+        restoredValue <- jsonlite::toJSON(restoredValue, strict_atomic = FALSE)
+    }
+
+    inputTag <- htmltools::tags$input(
+    	id = inputId,
+    	class = "shiny-input-file",
+        name = inputId,
+        type = "file",
+        style = "position: absolute !important; top: -99999px !important; left: -99999px !important;",
+        `data-restore` = restoredValue
+    )
+    if (multiple) {
+        inputTag$attribs$multiple <- "multiple"
+    }
+    if (length(accept) > 0) {
+        inputTag$attribs$accept <- paste(accept, collapse = ",")
+    }
+    if (!is.null(capture)) {
+        inputTag$attribs$capture <- capture
+    }
+    htmltools::tags$div(
+    	class = "form-group shiny-input-container",
+    	style = htmltools::css(width = htmltools::validateCssUnit(width)),
+        htmltools::tags$label(
+            label,
+            class = "control-label",
+            class = if (is.null(label)) "shiny-label-null",
+            id = paste0(inputId, "-label"),
+            `for` = inputId
+        ),
+        htmltools::tags$div(
+        	class = "input-group",
+            htmltools::tags$label(
+            	class = "input-group-btn input-group-prepend",
+                htmltools::tags$span(
+                    class = "btn btn-default btn-file", buttonLabel, inputTag
+                )),
+            	htmltools::tags$input(
+            		type = "text",
+            		class = "form-control",
+            		placeholder = placeholder,
+            		readonly = "readonly",
+            		`aria-label` = "Uploaded file name"
+            	)
+            ),
+        htmltools::tags$div(
+        	id = paste(inputId, "_progress", sep = ""),
+            class = "progress active shiny-file-input-progress",
+            htmltools::tags$div(class = "progress-bar")
+        )
+    )
+}

R/a11yRadioButtons.R

@@ -0,0 +1,44 @@
+#' Create radio buttons
+#'
+#' Creates more accessible shiny radio buttons
+#'
+#' @inheritParams shiny::radioButtons
+#'
+#' @seealso [shiny::radioButtons()]
+#'
+#' @export
+a11yRadioButtons <- function(
+	inputId, label, choices = NULL, selected = NULL, inline = FALSE,
+    width = NULL, choiceNames = NULL, choiceValues = NULL
+) {
+    args <- shiny:::normalizeChoicesArgs(choices, choiceNames, choiceValues)
+
+    selected <- shiny::restoreInput(id = inputId, default = selected)
+    if (is.null(selected)) {
+    	selected <- args$choiceValues[[1]]
+    } else {
+    	selected <- as.character(selected)
+    }
+    if (length(selected) > 1) {
+        stop("The 'selected' argument must be of length 1")
+    }
+
+    options <- shiny:::generateOptions(
+    	inputId, selected, inline, "radio", args$choiceNames, args$choiceValues
+    )
+
+    ctnrClass <- "form-group shiny-input-radiogroup shiny-input-container"
+    if (inline) {
+        ctnrClass <- paste(ctnrClass, "shiny-input-container-inline")
+    }
+
+    fieldset <- htmltools::tags$fieldset(
+		id = inputId,
+		style = htmltools::css(width = htmltools::validateCssUnit(width)),
+	    class = ctnrClass,
+	    htmltools::tags$legend(label),
+	    options
+	)
+
+	htmltools::attachDependencies(fieldset, accessibleShinyInputsDependency())
+}

R/deps.R

@@ -0,0 +1,19 @@
+accessibleShinyInputsDependency <- function() {
+  if (getOption("shiny.minified", TRUE)) {
+    js <- c("js/a11yShinyInputs.min.js", "js/a11yCheckboxGroupInput.min.js")
+    css <- "css/a11yShinyInputs.min.css"
+  } else {
+    js <- c("js/a11yShinyInputs.js", "js/a11yCheckboxGroupInput.js")
+    css <- "css/a11yShinyInputs.css"
+  }
+
+  list(
+    htmltools::htmlDependency(
+      "A11yShinyInputs",
+      as.character(utils::packageVersion("AVSDevR.A11yShinyInputs")),
+      c(file = system.file(package = "AVSDevR.A11yShinyInputs")),
+      script = js,
+      stylesheet = css
+    )
+  )
+}

inst/css/a11yShinyInputs.css

@@ -0,0 +1,18 @@
+fieldset.shiny-input-container {
+  
+}
+
+fieldset.shiny-input-container .shiny-options-group div.radio:first-child,
+fieldset.shiny-input-container .shiny-options-group div.checkbox:first-child {
+  margin-top: 0px;
+}
+
+fieldset.shiny-input-container legend {
+  margin-bottom: 5px !important;
+  font-weight: 700 !important;
+}
+
+fieldset.shiny-input-container div.select-all-container {
+  margin-top: -5px;
+  margin-bottom: 10px;
+}

inst/js/a11yCheckboxGroupInput.js

@@ -0,0 +1,89 @@
+var a11yCheckboxGroupBinding = new Shiny.InputBinding();
+$.extend(a11yCheckboxGroupBinding, {
+  find: function(scope) {
+    return $(scope).find(".shiny-input-a11ycheckboxgroup");
+  },
+  getValue: function(el) {
+    // Select the checkbox objects that have name equal to the grouping div's id
+    const $objs = $('input:checkbox[name="' + el.id + '"]:checked');
+    const values = new Array($objs.length);
+
+    for (let i = 0; i < $objs.length; i++) {
+      values[i] = $objs[i].value;
+    }
+
+    return values;
+  },
+  setValue: function(el, value) {
+    // Null value should be treated as empty array
+    value = value || [];
+
+    // Clear all checkboxes
+    $('input:checkbox[name="' + el.id + '"]').prop("checked", false);
+
+    // Accept array
+    if (value instanceof Array) {
+      for (let i = 0; i < value.length; i++) {
+        $('input:checkbox[name="' + el.id + '"][value="' + value[i] + '"]')
+          .prop("checked", true);
+      }
+      // Else assume it's a single value
+    } else {
+      $('input:checkbox[name="' + el.id + '"][value="' + value + '"]')
+      .prop("checked", true);
+    }
+  },
+
+  getState: function(el) {
+    const $objs = $('input:checkbox[name="' + el.id + '"]');
+
+    // Store options in an array of objects, each with with value and label
+    const options = new Array($objs.length);
+
+    for (let i = 0; i < options.length; i++) {
+      options[i] = {
+        value: $objs[i].value,
+        label: getLabel($objs[i])
+      };
+    }
+
+    return {
+      label: getLabelNode(el).text(),
+      value: this.getValue(el),
+      options: options,
+    };
+  },
+  receiveMessage: async function(el, data) {
+    const $el = $(el);
+
+    // This will replace all the options
+    if (Object.prototype.hasOwnProperty.call(data, "options") && data["options"] !== undefined) {
+      // Clear existing options and add each new one
+      $el.find("div.shiny-options-group").remove();
+      // Backward compatibility: for HTML generated by shinybootstrap2 package
+      $el.find("label.checkbox").remove();
+      $el.append(data.options);
+      $el.find('.select-all-container').appendTo($el)
+    }
+
+    if (Object.prototype.hasOwnProperty.call(data, "value") && data["value"] !== undefined) {
+      this.setValue(el, data.value);
+    }
+
+    if (Object.prototype.hasOwnProperty.call(data, "label") && data["label"] !== undefined) {
+       await updateLabel(data.label, $el.find("legend"));
+    }
+
+    $(el).trigger("change");
+  },
+  subscribe: function(el, callback) {
+    $(el).on("change.checkboxGroupInputBinding", function () {
+      callback(false);
+    });
+  },
+  unsubscribe: function(el) {
+    $(el).off(".checkboxGroupInputBinding");
+  }
+});
+
+Shiny.inputBindings.register(a11yCheckboxGroupBinding);

inst/js/a11yShinyInputs.js

@@ -0,0 +1,14 @@
+const checkAll = function(event) {
+  event.preventDefault();
+  const $input = $(event.target).closest('.shiny-input-a11ycheckboxgroup');
+  $input.find('input[type=\"checkbox\"]').prop('checked', true);
+  $input.trigger('change');
+  return false;
+};
+const clearAll = function(event) {
+  event.preventDefault();
+  const $input = $(event.target).closest('.shiny-input-a11ycheckboxgroup');
+  $input.find('input[type=\"checkbox\"]').prop('checked', false);
+  $input.trigger('change');
+  return false;
+};

man/a11yCheckboxGroupInput.Rd

@@ -0,0 +1,54 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/a11yCheckboxGroupInput.R
+\name{a11yCheckboxGroupInput}
+\alias{a11yCheckboxGroupInput}
+\title{Checkbox Group Input Control}
+\usage{
+a11yCheckboxGroupInput(
+  inputId,
+  label,
+  choices = NULL,
+  selected = NULL,
+  inline = FALSE,
+  width = NULL,
+  choiceNames = NULL,
+  choiceValues = NULL,
+  withSelectAll = FALSE
+)
+}
+\arguments{
+\item{inputId}{The \code{input} slot that will be used to access the value.}
+
+\item{label}{Display label for the control, or \code{NULL} for no label.}
+
+\item{choices}{List of values to show checkboxes for. If elements of the list
+are named then that name rather than the value is displayed to the user. If
+this argument is provided, then \code{choiceNames} and \code{choiceValues}
+must not be provided, and vice-versa. The values should be strings; other
+types (such as logicals and numbers) will be coerced to strings.}
+
+\item{selected}{The values that should be initially selected, if any.}
+
+\item{inline}{If \code{TRUE}, render the choices inline (i.e. horizontally)}
+
+\item{width}{The width of the input, e.g. \code{'400px'}, or \code{'100\%'};
+see \code{\link[shiny:validateCssUnit]{validateCssUnit()}}.}
+
+\item{choiceNames, choiceValues}{List of names and values, respectively,
+that are displayed to the user in the app and correspond to the each
+choice (for this reason, \code{choiceNames} and \code{choiceValues}
+must have the same length). If either of these arguments is
+provided, then the other \emph{must} be provided and \code{choices}
+\emph{must not} be provided. The advantage of using both of these over
+a named list for \code{choices} is that \code{choiceNames} allows any
+type of UI object to be passed through (tag objects, icons, HTML code,
+...), instead of just simple text. See Examples.}
+
+\item{withSelectAll}{Create additional "select all"/"clear all" controls}
+}
+\description{
+Creates more accessible shiny group of shiny checkboxes
+}
+\seealso{
+\code{\link[shiny:checkboxGroupInput]{shiny::checkboxGroupInput()}}
+}

man/a11yFileInput.Rd

@@ -0,0 +1,65 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/a11yFileInput.R
+\name{a11yFileInput}
+\alias{a11yFileInput}
+\title{File Upload Control}
+\usage{
+a11yFileInput(
+  inputId,
+  label,
+  multiple = FALSE,
+  accept = NULL,
+  width = NULL,
+  buttonLabel = "Browse...",
+  placeholder = "No file selected",
+  capture = NULL
+)
+}
+\arguments{
+\item{inputId}{The \code{input} slot that will be used to access the value.}
+
+\item{label}{Display label for the control, or \code{NULL} for no label.}
+
+\item{multiple}{Whether the user should be allowed to select and upload
+multiple files at once. \strong{Does not work on older browsers, including
+Internet Explorer 9 and earlier.}}
+
+\item{accept}{A character vector of "unique file type specifiers" which gives
+the browser a hint as to the type of file the server expects. Many browsers
+use this prevent the user from selecting an invalid file.
+
+A unique file type specifier can be:
+\itemize{
+\item A case insensitive extension like \code{.csv} or \code{.rds}.
+\item A valid MIME type, like \code{text/plain} or \code{application/pdf}
+\item One of \verb{audio/*}, \verb{video/*}, or \verb{image/*} meaning any audio, video,
+or image type, respectively.
+}}
+
+\item{width}{The width of the input, e.g. \code{'400px'}, or \code{'100\%'};
+see \code{\link[shiny:validateCssUnit]{validateCssUnit()}}.}
+
+\item{buttonLabel}{The label used on the button. Can be text or an HTML tag
+object.}
+
+\item{placeholder}{The text to show before a file has been uploaded.}
+
+\item{capture}{What source to use for capturing image, audio or video data.
+This attribute facilitates user access to a device's media capture
+mechanism, such as a camera, or microphone, from within a file upload
+control.
+
+A value of \code{user} indicates that the user-facing camera and/or microphone
+should be used. A value of \code{environment} specifies that the outward-facing
+camera and/or microphone should be used.
+
+By default on most phones, this will accept still photos or video. For
+still photos only, also use \code{accept="image/*"}. For video only, use
+\code{accept="video/*"}.}
+}
+\description{
+Creates more accessible shiny file upload input.
+}
+\seealso{
+\code{\link[shiny:fileInput]{shiny::fileInput()}}
+}

man/a11yRadioButtons.Rd

@@ -0,0 +1,52 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/a11yRadioButtons.R
+\name{a11yRadioButtons}
+\alias{a11yRadioButtons}
+\title{Create radio buttons}
+\usage{
+a11yRadioButtons(
+  inputId,
+  label,
+  choices = NULL,
+  selected = NULL,
+  inline = FALSE,
+  width = NULL,
+  choiceNames = NULL,
+  choiceValues = NULL
+)
+}
+\arguments{
+\item{inputId}{The \code{input} slot that will be used to access the value.}
+
+\item{label}{Display label for the control, or \code{NULL} for no label.}
+
+\item{choices}{List of values to select from (if elements of the list are
+named then that name rather than the value is displayed to the user). If
+this argument is provided, then \code{choiceNames} and \code{choiceValues} must not
+be provided, and vice-versa. The values should be strings; other types
+(such as logicals and numbers) will be coerced to strings.}
+
+\item{selected}{The initially selected value. If not specified, then it
+defaults to the first item in \code{choices}. To start with no items selected,
+use \code{character(0)}.}
+
+\item{inline}{If \code{TRUE}, render the choices inline (i.e. horizontally)}
+
+\item{width}{The width of the input, e.g. \code{'400px'}, or \code{'100\%'};
+see \code{\link[shiny:validateCssUnit]{validateCssUnit()}}.}
+
+\item{choiceNames, choiceValues}{List of names and values, respectively, that
+are displayed to the user in the app and correspond to the each choice (for
+this reason, \code{choiceNames} and \code{choiceValues} must have the same length).
+If either of these arguments is provided, then the other \emph{must} be provided
+and \code{choices} \emph{must not} be provided. The advantage of using both of these
+over a named list for \code{choices} is that \code{choiceNames} allows any type of UI
+object to be passed through (tag objects, icons, HTML code, ...), instead
+of just simple text. See Examples.}
+}
+\description{
+Creates more accessible shiny radio buttons
+}
+\seealso{
+\code{\link[shiny:radioButtons]{shiny::radioButtons()}}
+}