Add tooltip() API (#662)

Co-authored-by: Garrick Aden-Buie <[email protected]>
Co-authored-by: cpsievert <[email protected]>

Author: cpsievert

DESCRIPTION

@@ -86,6 +86,7 @@ Collate:
     'shiny-devmode.R'
     'sidebar.R'
     'staticimports.R'
+    'tooltip.R'
     'utils-deps.R'
     'utils-shiny.R'
     'utils-tags.R'

NAMESPACE

@@ -124,7 +124,10 @@ export(sidebar)
 export(sidebar_toggle)
 export(theme_bootswatch)
 export(theme_version)
+export(toggle_tooltip)
+export(tooltip)
 export(update_switch)
+export(update_tooltip)
 export(value_box)
 export(version_default)
 export(versions)

R/card.R

@@ -271,13 +271,13 @@ is.card_item <- function(x) {
 
 
 full_screen_toggle <- function() {
-  tags$span(
-    class = "bslib-full-screen-enter",
-    class = "badge rounded-pill bg-dark",
-    "data-bs-toggle" = "tooltip",
-    "data-bs-placement" = "bottom",
-    title = "Expand",
-    full_screen_toggle_icon()
+  tooltip(
+    tags$span(
+      class = "bslib-full-screen-enter",
+      class = "badge rounded-pill bg-dark",
+      full_screen_toggle_icon()
+    ),
+    "Expand"
   )
 }
 

R/layout.R

@@ -55,9 +55,9 @@ layout_column_wrap <- function(
 
   heights_equal <- match.arg(heights_equal)
 
-  args <- list_split_named(rlang::list2(...))
-  attribs <- args[["named"]]
-  children <- dropNulls(args[["unnamed"]])
+  args <- separate_arguments(...)
+  attribs <- args$attribs
+  children <- args$children
 
   if (length(width) > 1) {
     stop("`width` of length greater than 1 is not currently supported.")
@@ -189,9 +189,9 @@ layout_columns <- function(
   class = NULL,
   height = NULL
 ) {
-  args <- list_split_named(rlang::list2(...))
-  attribs <- args[["named"]]
-  children <- dropNulls(args[["unnamed"]])
+  args <- separate_arguments(...)
+  attribs <- args$attribs
+  children <- args$children
   n_kids <- length(children)
 
   # Resolve missing value(s) for col_widths, etc.

R/tooltip.R

@@ -0,0 +1,125 @@
+#' Add a tooltip to a UI element
+#'
+#' Display additional information when focusing (or hovering over) a UI element.
+#'
+#' @param trigger A UI element (i.e., [htmltools tag][htmltools::tags]) to serve
+#'   as the tooltips trigger. It's good practice for this element to be a
+#'   keyboard-focusable and interactive element (e.g., `actionButton()`,
+#'   `actionLink()`, etc) so that the tooltip is accessible to keyboard and
+#'   assistive technology users.
+#' @param ... UI elements for the tooltip. Character strings are [automatically
+#'   escaped][htmlEscape()] unless marked as [HTML()].
+#' @param id A character string. Required to re-actively respond to the
+#'   visibility of the tooltip (via the `input[[id]]` value) and/or update the
+#'   visibility/contents of the tooltip.
+#' @param placement The placement of the tooltip relative to its trigger.
+#' @param options A list of additional [Bootstrap
+#'   options](https://getbootstrap.com/docs/5.3/components/tooltips/#options).
+#'
+#' @details If `trigger` yields multiple HTML elements (e.g., a `tagList()` or
+#'   complex `{htmlwidgets}` object), the last HTML element is used as the
+#'   trigger. If the `trigger` should contain all of those elements, wrap the
+#'   object in a [div()] or [span()].
+#'
+#' @describeIn tooltip Add a tooltip to a UI element
+#' @references <https://getbootstrap.com/docs/5.3/components/tooltips/>
+#' @export
+#' @examplesIf interactive()
+#'
+#' tooltip(
+#'   shiny::actionButton("btn", "A button"),
+#'   "A message"
+#' )
+#'
+#' card(
+#'   card_header(
+#'     tooltip(
+#'       span("Card title ", bsicons::bs_icon("question-circle-fill")),
+#'       "Additional info",
+#'       placement = "right"
+#'     )
+#'   ),
+#'   "Card body content..."
+#' )
+tooltip <- function(
+  trigger,
+  ...,
+  id = NULL,
+  placement = c("auto", "top", "right", "bottom", "left"),
+  options = list()
+) {
+
+  args <- separate_arguments(...)
+  children <- args$children
+  attribs <- args$attribs
+
+  if (length(children) == 0) {
+    abort("At least one value must be provided to `...`.")
+  }
+
+  res <- web_component(
+    "bslib-tooltip",
+    id = id,
+    placement = rlang::arg_match(placement),
+    options = jsonlite::toJSON(options, auto_unbox = TRUE),
+    !!!attribs,
+    # Use display:none instead of <template> since shiny.js
+    # doesn't bind to the contents of the latter
+    div(!!!children, style = "display:none;"),
+    trigger
+  )
+
+  res <- tag_require(res, version = 5, caller = "tooltip()")
+  as_fragment(res)
+}
+
+#' @describeIn tooltip Programmatically show/hide a tooltip.
+#'
+#' @param id a character string that matches an existing tooltip id.
+#' @param show Whether to show (`TRUE`) or hide (`FALSE`) the tooltip. The
+#'   default (`NULL`) will show if currently hidden and hide if currently shown.
+#'   Note that a tooltip will not be shown if the trigger is not visible (e.g.,
+#'   it's hidden behind a tab).
+#' @param session A Shiny session object (the default should almost always be
+#'   used).
+#'
+#' @export
+toggle_tooltip <- function(id, show = NULL, session = get_current_session()) {
+  show <- normalize_show_value(show)
+
+  msg <- list(method = "toggle", value = show)
+  force(id)
+  callback <- function() {
+    session$sendInputMessage(id, msg)
+  }
+  session$onFlush(callback, once = TRUE)
+}
+
+
+#' @describeIn tooltip Update the contents of a tooltip.
+#' @export
+update_tooltip <- function(id, ..., session = get_current_session()) {
+
+  title <- tagList(...)
+
+  msg <- dropNulls(list(
+    method = "update",
+    title = if (length(title) > 0) processDeps(title, session)
+  ))
+
+  force(id)
+  callback <- function() {
+    session$sendInputMessage(id, msg)
+  }
+  session$onFlush(callback, once = TRUE)
+}
+
+normalize_show_value <- function(show) {
+  if (is.null(show)) return("toggle")
+
+  if (length(show) != 1 || !is.logical(show)) {
+    abort("`show` must be `TRUE`, `FALSE`, or `NULL`.")
+  }
+
+  if (show) "show" else "hide"
+}

R/utils-deps.R

@@ -1,12 +1,21 @@
-component_dependency_js <- function(name) {
+web_component <- function(tagName, ...) {
+  js_dep <- component_dependency_js("webComponents", type = "module")
+  args <- c(list(js_dep), rlang::list2(...))
+  tag(tagName, args)
+}
+
+component_dependency_js <- function(name, ...) {
   minified <- get_shiny_devmode_option("shiny.minified", default = TRUE)
 
   htmlDependency(
     name = paste0("bslib-", name, "-js"),
     version = get_package_version("bslib"),
     package = "bslib",
     src = file.path("components", "dist", name),
-    script = paste0(name, if (minified) ".min", ".js"),
+    script = list(
+      src = paste0(name, if (minified) ".min", ".js"),
+      ...
+    ),
     all_files = TRUE
   )
 }

R/utils.R

@@ -88,19 +88,20 @@ any_unnamed <- function(x) {
   is.null(nms) || !all(nzchar(nms))
 }
 
-list_split_named <- function(x) {
+separate_arguments <- function(...) {
+  x <- rlang::list2(...)
   x_names <- rlang::names2(x)
   is_named <- nzchar(x_names)
 
   if (all(is_named)) {
-    return(list(named = x, unnamed = list()))
+    return(list(attribs = x, children = list()))
   }
 
   if (!any(is_named)) {
-    return(list(named = list(), unnamed = x))
+    return(list(attribs = list(), children = x))
   }
 
-  list(named = x[is_named], unnamed = unname(x[!is_named]))
+  list(attribs = x[is_named], children = unname(dropNulls(x[!is_named])))
 }
 
 #' Rename a named list