R/radio_button_input.R

In shinyGovstyle: Custom Gov Style Inputs for Shiny

#' Radio Button Function
#'
#' This function create radio buttons
#' @inheritParams id_arg
#' @inheritParams control_label_params
#' @param 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)
#' @param selected The initially selected value.
#' @param inline  If you want the radio inline or not,  Default is FALSE
#' @param small  If you want the smaller versions of radio buttons,  Default
#' is FALSE
#' @param choiceNames,choiceValues Same as in
#' [shiny::checkboxGroupInput()]. List of names and values,
#' respectively, that are displayed to the user in the app and correspond to
#' the each choice (for this reason they must have the same length). If either
#' of these arguments is provided, then the other must be provided and choices
#' must not be provided. The advantage of using both of these over a named list
#' for choices is that choiceNames allows any type of UI object to be passed
#' through (tag objects, icons, HTML code, ...), instead of just simple text
#' @inheritParams error_args
#' @param custom_class If you want to add additional classes to the radio
#' buttons
#' @inheritParams fieldset_args
#' @return radio buttons HTML shiny tag object
#' @family Govstyle select inputs
#' @export
#' @examples
#' ui <- shinyGovstyle::gov_page(
#'   # Required for error handling function
#'   shinyjs::useShinyjs(),
#'   shinyGovstyle::header(
#'     org_name = "Example",
#'     service_name = "User Examples",
#'     logo = "shinyGovstyle/images/moj_logo.png"
#'   ),
#'   shinyGovstyle::phase_banner(
#'     inputId = "banner", type = "beta", "This is a new service"
#'   ),
#'   shinyGovstyle::gov_main_layout(
#'     # Simple radio
#'     shinyGovstyle::radio_button_Input(
#'       inputId = "radio1",
#'       choices = c("Yes", "No", "Maybe"),
#'       label = "Choice option"
#'     ),
#'     # Error radio
#'     shinyGovstyle::radio_button_Input(
#'       inputId = "radio2",
#'       choices = c("Yes", "No", "Maybe"),
#'       label = "Choice option",
#'       hint_label = "Select the best fit",
#'       inline = TRUE,
#'       error = TRUE,
#'       error_message = "Select one"
#'     ),
#'     # Rich content: a link in the hint
#'     shinyGovstyle::radio_button_Input(
#'       inputId = "radio3",
#'       choices = c("Yes", "No", "Maybe"),
#'       label = "Choice option",
#'       hint_label = shiny::tagList(
#'         "See the ",
#'         shinyGovstyle::external_link(
#'           "https://www.gov.uk",
#'           "GOV.UK guidance"
#'         )
#'       )
#'     ),
#'     # Button to trigger error
#'     shinyGovstyle::button_Input(inputId = "submit", label = "Submit")
#'   ),
#'   shinyGovstyle::footer(full = TRUE)
#' )
#'
#' server <- function(input, output, session) {
#'   # Trigger error on blank submit of eventId2
#'   observeEvent(input$submit, {
#'     if (is.null(input$radio2)) {
#'       shinyGovstyle::error_on(inputId = "radio2")
#'     } else {
#'       shinyGovstyle::error_off(
#'         inputId = "radio2"
#'       )
#'     }
#'   })
#' }
#' if (interactive()) shinyApp(ui = ui, server = server)
radio_button_Input <- # nolint
  function(
    inputId, # nolint
    label,
    choices = NULL,
    selected = NULL,
    inline = FALSE,
    small = FALSE,
    choiceNames = NULL, # nolint
    choiceValues = NULL, # nolint
    hint_label = NULL,
    error = FALSE,
    error_message = NULL,
    custom_class = "",
    label_size = c("m", "s", "l", "xl"),
    heading_level = NULL
  ) {
    args <- normalizeChoicesArgs2(choices, choiceNames, choiceValues)
    selected <- shiny::restoreInput(id = inputId, default = selected)
    selected <- as.character(selected)
    if (length(selected) > 1) {
      stop("The 'selected' argument must be of length 1")
    }
    options <- generateOptions2(
      inputId,
      selected,
      inline,
      small,
      "radio",
      args$choiceNames,
      args$choiceValues
    )
    div_class <- paste("govuk-form-group govuk-radios", custom_class)
    gov_radio <- shiny::tags$div(
      id = inputId,
      class = div_class,
      shiny::tags$div(
        class = "govuk-form-group",
        id = paste0(inputId, "div"),
        govFieldset(
          inputId = inputId,
          label = label,
          content = options,
          hint_label = hint_label,
          error = error,
          error_message = error_message,
          label_size = label_size,
          heading_level = heading_level
        )
      )
    )

    attachDependency(gov_radio, "radio")
  }

#' Update a Govstyle radio button input on the client
#'
#' Server-side companion to [radio_button_Input()], mirroring
#' [shiny::updateRadioButtons()]. Use it to change the selected option, the
#' available choices, or the label of an existing radio button group from
#' within an observer, for example to keep a cookies settings radio in sync
#' with a choice the user made elsewhere.
#'
#' Only the arguments you supply are sent to the client; everything left at its
#' default of `NULL` is left untouched. Because it relies on
#' `session$sendInputMessage()`, the `inputId` is namespaced automatically when
#' called inside a Shiny module, so pass the unnamespaced id just as you would
#' to [shiny::updateRadioButtons()].
#'
#' This function is deliberately agnostic about why you are updating the radio,
#' which makes it a useful building block for packages that layer extra
#' behaviour (such as analytics cookie consent) on top of shinyGovstyle. See
#' the cookies and analytics vignette for an example of extending it.
#'
#' @param session The `session` object passed to the Shiny server function.
#' Defaults to the current reactive domain.
#' @param inputId The id of the [radio_button_Input()] to update
#' @param label New label for the input, or `NULL` to leave unchanged. Sent to
#' the client as plain text: if the group was created with `heading_level`
#' set, the `<hN>` heading wrapper around the legend is preserved, but rich
#' HTML/tag content is not — the legend always ends up as plain text after an
#' update, the same limitation this function has always had.
#' @param choices New vector of choices, or `NULL` to leave unchanged (if
#' elements of the vector are named then that name rather than the value is
#' displayed to the user)
#' @param selected The value to select, or `NULL` to leave unchanged
#' @param inline Whether the radios are inline. Only applies when `choices`
#' (or `choiceNames`/`choiceValues`) are also supplied, since regenerating the
#' options replaces the whole option container; if you do not re-pass it the
#' layout falls back to default. Defaults to FALSE
#' @param small Whether to use the smaller radios. Only applies when `choices`
#' (or `choiceNames`/`choiceValues`) are also supplied, since regenerating the
#' options replaces the whole option container; if you do not re-pass it the
#' layout falls back to default. Defaults to FALSE
#' @param choiceNames,choiceValues As in [radio_button_Input()], an alternative
#' to `choices` allowing richer labels. Both must be supplied together
#' @return Called for its side effect of sending a message to the client; no
#' return value
#' @seealso [radio_button_Input()]
#' @family Govstyle select inputs
#' @export
#' @examples
#' ui <- shinyGovstyle::gov_page(
#'   shinyjs::useShinyjs(),
#'   shinyGovstyle::radio_button_Input(
#'     inputId = "cookies",
#'     label = "Do you want to accept analytics cookies?",
#'     choices = c("Yes" = "yes", "No" = "no"),
#'     selected = "no",
#'     inline = TRUE
#'   ),
#'   shinyGovstyle::button_Input(inputId = "accept", label = "Accept cookies")
#' )
#'
#' server <- function(input, output, session) {
#'   # Keep the radio in sync with a choice made elsewhere
#'   shiny::observeEvent(input$accept, {
#'     shinyGovstyle::update_radio_button_Input(
#'       session,
#'       inputId = "cookies",
#'       selected = "yes"
#'     )
#'   })
#' }
#' if (interactive()) shinyApp(ui = ui, server = server)
update_radio_button_Input <- # nolint
  function(
    session = shiny::getDefaultReactiveDomain(),
    inputId, # nolint
    label = NULL,
    choices = NULL,
    selected = NULL,
    inline = FALSE,
    small = FALSE,
    choiceNames = NULL, # nolint
    choiceValues = NULL # nolint
  ) {
    args <- normalizeChoicesArgs2(
      choices,
      choiceNames,
      choiceValues,
      mustExist = FALSE
    )

    if (!is.null(selected)) {
      selected <- as.character(selected)
      if (length(selected) > 1) {
        stop("The 'selected' argument must be of length 1")
      }
    }

    # When new choices are supplied, render fresh option items on the server so
    # the client can swap them in. The option inputs use the namespaced id as
    # their `name`, matching the markup produced by radio_button_Input().
    options <- if (!is.null(args$choiceNames)) {
      as.character(
        generateOptions2(
          session$ns(inputId),
          selected,
          inline,
          small,
          "radio",
          args$choiceNames,
          args$choiceValues
        )
      )
    }

    message <- Filter(
      Negate(is.null),
      list(label = label, options = options, selected = selected)
    )

    session$sendInputMessage(inputId, message)
  }

generateOptions2 <- # nolint
  function(
    inputId, # nolint
    selected,
    inline,
    small,
    type = "checkbox",
    choiceNames, # nolint
    choiceValues, # nolint
    session = shiny::getDefaultReactiveDomain()
  ) {
    options <- mapply(
      choiceValues,
      choiceNames,
      seq_along(choiceValues),
      FUN = function(value, name, idx) {
        option_id <- paste0(inputId, "-", idx)
        inputTag <- # nolint
          shiny::tags$input(
            type = type,
            name = inputId,
            id = option_id,
            value = value,
            class = "govuk-radios__input"
          )
        if (!is.null(selected) && value %in% selected) {
          inputTag$attribs$checked <- "checked" # nolint
        }
        pd <- processDeps2(name, session)
        shiny::tags$div(
          class = "govuk-radios__item",
          inputTag,
          shiny::tags$label(
            pd$html,
            pd$deps,
            `for` = option_id,
            class = "govuk-label govuk-radios__label"
          )
        )
      },
      SIMPLIFY = FALSE,
      USE.NAMES = FALSE
    )

    class_build <- "govuk-radios"

    if (inline) {
      class_build <- paste(class_build, "govuk-radios--inline")
    }

    if (small) {
      class_build <- paste(class_build, "govuk-radios--small")
    }

    shiny::div(class = class_build, options)
  }

processDeps2 <- # nolint
  function(tags, session) {
    ui <- htmltools::takeSingletons(
      tags,
      session$singletons,
      desingleton = FALSE
    )$ui
    ui <- htmltools::surroundSingletons(ui)
    dependencies <- lapply(
      htmltools::resolveDependencies(
        htmltools::findDependencies(ui)
      ),
      shiny::createWebDependency
    )
    names(dependencies) <- NULL
    list(html = htmltools::doRenderTags(ui), deps = dependencies)
  }

normalizeChoicesArgs2 <- # nolint
  function(
    choices,
    choiceNames, # nolint
    choiceValues, # nolint
    mustExist = TRUE # nolint
  ) {
    if (!is.null(choices)) {
      if (!is.null(choiceNames) || !is.null(choiceValues)) {
        warning(
          "Using `choices` argument; ignoring `choiceNames`
              and `choiceValues`."
        )
      }
      choices <- choicesWithNames2(choices)
      choiceNames <- names(choices) # nolint
      choiceValues <- unname(choices) # nolint
      list(
        choiceNames = as.list(choiceNames),
        choiceValues = as.list(as.character(choiceValues))
      )
    } else if (is.null(choiceNames) || is.null(choiceValues)) {
      if (mustExist) {
        stop(
          "Please specify a non-empty vector for `choices` (or, ",
          "alternatively, for both `choiceNames` AND `choiceValues`)."
        )
      } else if (is.null(choiceNames) && is.null(choiceValues)) {
        list(choiceNames = NULL, choiceValues = NULL)
      } else {
        stop(
          "One of `choiceNames` or `choiceValues` was set to ",
          "NULL, but either both or none should be NULL."
        )
      }
    } else {
      if (length(choiceNames) != length(choiceValues)) {
        stop("`choiceNames` and `choiceValues` must have the same length.")
      }
      if (anyNamed2(choiceNames) || anyNamed2(choiceValues)) {
        stop("`choiceNames` and `choiceValues` must not be named.")
      }
      list(
        choiceNames = as.list(choiceNames),
        choiceValues = as.list(as.character(choiceValues))
      )
    }
  }


choicesWithNames2 <- # nolint
  function(choices) {
    listify <- function(obj) {
      makeNamed <- # nolint
        function(x) {
          if (is.null(names(x))) {
            names(x) <- character(length(x))
          }
          x
        }
      res <- lapply(obj, function(val) {
        if (is.list(val)) {
          listify(val)
        } else if (length(val) == 1 && is.null(names(val))) {
          as.character(val)
        } else {
          makeNamed(as.list(val))
        }
      })
      makeNamed(res)
    }
    choices <- listify(choices)
    if (length(choices) == 0) {
      choices
    } else {
      choices <- mapply(
        choices,
        names(choices),
        FUN = function(choice, name) {
          if (!is.list(choice)) {
            choice
          } else {
            if (name == "") {
              stop("All sub-lists in \"choices\" must be named.")
            }
            choicesWithNames2(choice)
          }
        },
        SIMPLIFY = FALSE
      )
      missing <- names(choices) == ""
      names(choices)[missing] <- as.character(choices)[missing]
      choices
    }
  }

anyNamed2 <- # nolint
  function(x) {
    if (length(x) == 0 || is.null(names(x))) {
      FALSE
    } else {
      any(nzchar(names(x)))
    }
  }