First pass on tooltip()

DESCRIPTION

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

NAMESPACE

@@ -123,6 +123,9 @@ export(sidebar)
 export(sidebar_toggle)
 export(theme_bootswatch)
 export(theme_version)
+export(tooltip)
+export(tooltip_toggle)
+export(tooltip_update)
 export(value_box)
 export(version_default)
 export(versions)

R/accordion.R

@@ -114,7 +114,7 @@ accordion <- function(..., id = NULL, open = NULL, multiple = TRUE, class = NULL
     ),
     !!!attrs,
     !!!children,
-    accordion_dependency()
+    component_js_dependency("accordion")
   )
 
   tag <- tag_require(tag, version = 5, caller = "accordion()")
@@ -276,7 +276,3 @@ check_character <- function(x, max_length = Inf, min_length = 1, call = rlang::c
   }
   x
 }
-
-accordion_dependency <- function(minified = NULL) {
-  component_js_dependency("accordion", minified = minified)
-}

R/card.R

@@ -71,7 +71,7 @@ card <- function(..., full_screen = FALSE, height = NULL, max_height = NULL, min
     !!!attribs,
     !!!children,
     if (full_screen) full_screen_toggle(),
-    card_dependency(),
+    component_js_dependency("card"),
     card_init_js()
   )
 
@@ -270,20 +270,17 @@ 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",
+      title = "Expand",
+      full_screen_toggle_icon()
+    ),
+    placement = "bottom"
   )
 }
 
-card_dependency <- function(minified = NULL) {
-  component_js_dependency("card", minified = minified)
-}
-
 card_init_js <- function() {
   tags$script(
     `data-bslib-card-init` = NA,

R/sidebar.R

@@ -229,7 +229,7 @@ layout_sidebar <- function(
       "--bslib-sidebar-max-height-mobile" = max_height_mobile
     ),
     !!!contents,
-    sidebar_dependency(),
+    component_js_dependency("sidebar"),
     sidebar_init_js()
   )
 
@@ -278,10 +278,6 @@ collapse_icon <- function() {
   bsicons::bs_icon("chevron-down", class = "collapse-icon", size = NULL)
 }
 
-sidebar_dependency <- function(minified = NULL) {
-  component_js_dependency("sidebar", minified = minified)
-}
-
 sidebar_init_js <- function() {
   # Note: if we want to avoid inline `<script>` tags in the future for
   # initialization code, we might be able to do so by turning the sidebar layout

R/tooltip.R

@@ -0,0 +1,117 @@
+#' Add a tooltip to a UI element
+#'
+#' Tooltips are useful for showing additional information when focusing (or
+#' hovering over) a UI element.
+#'
+#' @param ... Unnamed arguments can be any valid child of an [htmltools
+#'   tag][htmltools::tags]. Named arguments become HTML attributes on returned
+#'   UI element. Attributes starting with `data-bs-*` may be supplied to further
+#'   customize [tooltip
+#'   options](https://getbootstrap.com/docs/5.3/components/tooltips/).
+#' @param body Content to display in the tooltip.
+#' @param placement The placement of the tooltip relative to the target element.
+#' @param html Whether to treat `body` as HTML. WARNING: setting this `TRUE`
+#'   when the `body` is a function of user `inputs` is dangerous and not
+#'   recommended.
+#' @param sanitize Whether to sanitize HTML (only relevant when `html = TRUE`).
+#'   This can be useful if `body` is a function of user `inputs`, but should
+#'   also be treated as HTML.
+#' @param id If provided, you can use `input$id` in your server logic to
+#'   determine whether the tooltip is currently shown/hidden.
+#'
+#' @details If multiple UI elements are provided to `...`, the last element is
+#' used as the tooltip's target. If the target should contain multiple elements,
+#' then wrap those elements in a [span()] or [div()].
+#'
+#' @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"),
+#'   body = "A message"
+#' )
+#'
+#' card(
+#'   card_header(
+#'     tooltip(
+#'       span("Card title ", bsicons::bs_icon("question-circle-fill")),
+#'       body = "Additional info",
+#'       placement = "right"
+#'     )
+#'   ),
+#'   "Card body content..."
+#' )
+tooltip <- function(
+  ...,
+  body = "Tooltip",
+  placement = c("auto", "top", "right", "bottom", "left"),
+  html = FALSE,
+  sanitize = FALSE,
+  id = NULL
+) {
+
+  res <- web_component(
+    "bslib-tooltip",
+    placement = rlang::arg_match(placement),
+    html = if (html) NA,
+    sanitize = if (sanitize) NA,
+    id = id,
+    # Use display:none instead of <template> since shiny.js
+    # doesn't bind to the contents of the latter
+    div(body, style = "display:none;"),
+    ...
+  )
+
+  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.
+#' @param session A Shiny session object (the default should almost always be
+#'   used).
+#'
+#' @export
+tooltip_toggle <- 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 `body` of a tooltip.
+#' @export
+tooltip_update <- function(id, body = NULL, session = get_current_session()) {
+
+  msg <- dropNulls(list(
+    method = "update",
+    title = if (!is.null(body)) processDeps(body, 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,14 +1,22 @@
-component_js_dependency <- function(name, minified = NULL) {
-  minified <-
-    minified %||%
-    get_shiny_devmode_option("shiny.minified", default = TRUE)
+web_component <- function(tagName, ...) {
+  js_dep <- component_js_dependency("webComponents", type = "module")
+  args <- c(list(js_dep), rlang::list2(...))
+  tag(tagName, args)
+}
+
+
+component_js_dependency <- function(name, ...) {
+  minified <- get_shiny_devmode_option("shiny.minified", default = TRUE)
 
   htmlDependency(
     name = paste0("bslib-", name),
     version = get_package_version("bslib"),
     package = "bslib",
     src = file.path("components", "dist", name),
     all_files = TRUE,
-    script = paste0(name, if (minified) ".min", ".js")
+    script = list(
+      src = paste0(name, if (minified) ".min", ".js"),
+      ...
+    )
   )
 }