Add popover() API

DESCRIPTION

@@ -81,6 +81,7 @@ Collate:
     'navs.R'
     'onLoad.R'
     'page.R'
+    'popover.R'
     'precompiled.R'
     'print.R'
     'shiny-devmode.R'

NAMESPACE

@@ -115,6 +115,7 @@ export(page_fixed)
 export(page_fluid)
 export(page_navbar)
 export(page_sidebar)
+export(popover)
 export(precompiled_css_path)
 export(remove_all_fill)
 export(run_with_themer)
@@ -124,10 +125,12 @@ export(sidebar)
 export(sidebar_toggle)
 export(theme_bootswatch)
 export(theme_version)
+export(toggle_popover)
 export(toggle_sidebar)
 export(toggle_switch)
 export(toggle_tooltip)
 export(tooltip)
+export(update_popover)
 export(update_switch)
 export(update_tooltip)
 export(value_box)

NEWS.md

@@ -3,6 +3,7 @@
 ## New features
 
 * Added `tooltip()`, `update_tooltip()`, and `toggle_tooltip()` for easy creation (and server-side updating) of [Bootstrap tooltips](https://getbootstrap.com/docs/5.2/components/tooltips/) (a way to display additional information when focusing (or hovering over) a UI element). (#662)
+* Added `popover()`, `update_popover()`, and `toggle_popover()` for easy creation (and server-side updating) of [Bootstrap popovers](https://getbootstrap.com/docs/5.2/components/popovers/). Popovers are similar to tooltips, but are more persistent, and should primarily be used with button-like UI elements (e.g., `actionButton()`, `bsicons::bs_icon()`, etc). (#702)
 * Added `input_switch()` and `update_switch()` for easy creation (and server-side updating) of a [Bootstrap's switch input](https://getbootstrap.com/docs/5.2/forms/checks-radios/#switches) (an on-off toggle for binary input values). (#483)
 * Added two new toggle functions: `toggle_switch()` for toggling the state of an `input_switch()` element and `toggle_sidebar()` for toggling the state of a `sidebar()` element (`sidebar_toggle()` remains as an alias of `toggle_sidebar()`). (#709)
 

R/popover.R

@@ -0,0 +1,165 @@
+#' Add a popover to a UI element
+#'
+#' Display additional information when clicking on a UI element (typically a
+#' button).
+#'
+#' @param trigger The UI element to serve as the popover trigger (typically a
+#'   [shiny::actionButton()] or similar). If `trigger` renders as multiple HTML
+#'   elements (e.g., it's a `tagList()`), the last HTML element is used for the
+#'   trigger. If the `trigger` should contain all of those elements, wrap the
+#'   object in a [div()] or [span()].
+#' @param ... UI elements for the popover's body. Character strings are
+#'   [automatically escaped][htmlEscape()] unless marked as [HTML()].
+#' @param title A title (header) for the popover.
+#' @param id A character string. Required to re-actively respond to the
+#'   visibility of the popover (via the `input[[id]]` value) and/or update the
+#'   visibility/contents of the popover.
+#' @param placement The placement of the popover relative to its trigger.
+#' @param options A list of additional
+#'   [options](https://getbootstrap.com/docs/5.3/components/popovers/#options).
+#'
+#' @section Closing popovers:
+#'
+#'   In addition to clicking the `close_button`, popovers can be closed by
+#'   pressing the Esc/Space key when the popover (and/or its trigger) is
+#'   focused.
+#'
+#' @section Theming/Styling:
+#'
+#'   Like other bslib components, popovers can be themed by supplying [relevant
+#'   theming
+#'   variables](https://rstudio.github.io/bslib/articles/bs5-variables.html#popover-bg)
+#'   to [bs_theme()], which effects styling of every popover on the page. To
+#'   style a _specific_ popover differently from other popovers, utilize the
+#'   `customClass` option:
+#'
+#'   ```
+#'   popover(
+#'     "Trigger", "Popover message",
+#'     options = list(customClass = "my-pop")
+#'   )
+#'   ```
+#'
+#'   And then add relevant rules to [bs_theme()] via [bs_add_rules()]:
+#'
+#'   ```
+#'   bs_theme() |> bs_add_rules(".my-pop { max-width: none; }")
+#'   ```
+#'
+#' @describeIn popover Add a popover to a UI element
+#' @references <https://getbootstrap.com/docs/5.3/components/popovers/>
+#' @export
+#' @seealso [tooltip()]
+#' @examplesIf interactive()
+#'
+#' popover(
+#'   shiny::actionButton("btn", "A button"),
+#'   "Popover body content...",
+#'   title = "Popover title"
+#' )
+#'
+#' library(shiny)
+#'
+#' ui <- page_fixed(
+#'   card(class = "mt-5",
+#'     card_header(
+#'       popover(
+#'         uiOutput("card_title", inline = TRUE),
+#'         title = "Provide a new title",
+#'         textInput("card_title", NULL, "An editable title")
+#'       )
+#'     ),
+#'     "The card body..."
+#'   )
+#' )
+#'
+#' server <- function(input, output) {
+#'   output$card_title <- renderUI({
+#'     list(input$card_title, bsicons::bs_icon("pencil-square"))
+#'   })
+#' }
+#'
+#' shinyApp(ui, server)
+popover <- function(
+  trigger,
+  ...,
+  title = NULL,
+  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 `...`.")
+  }
+
+  bad_opts <- intersect(c("content", "title", "placement"), names(options))
+  if (length(bad_opts) > 0) {
+    rlang::abort(
+      sprintf("The `%s` option cannot be specified directly.", bad_opts[1])
+    )
+  }
+
+  res <- web_component(
+    "bslib-popover",
+    id = id,
+    placement = rlang::arg_match(placement),
+    bsOptions = to_json(options),
+    !!!attribs,
+    # Use display:none instead of <template> since shiny.js
+    # doesn't bind to the contents of the latter
+    div(
+      style = "display:none;",
+      div(!!!children),
+      div(title)
+    ),
+    trigger
+  )
+
+  res <- tag_require(res, version = 5, caller = "popover()")
+  as_fragment(res)
+}
+
+#' @describeIn popover Programmatically show/hide a popover.
+#'
+#' @param show Whether to show (`TRUE`) or hide (`FALSE`) the popover. The
+#'   default (`NULL`) will show if currently hidden and hide if currently shown.
+#'   Note that a popover 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_popover <- 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 popover Update the contents of a popover.
+#' @export
+update_popover <- function(id, ..., title = NULL, session = get_current_session()) {
+
+  body <- tagList(...)
+
+  msg <- dropNulls(list(
+    method = "update",
+    content = if (length(body) > 0) processDeps(body, session),
+    header = if (length(title) > 0) processDeps(title, session)
+  ))
+
+  force(id)
+  callback <- function() {
+    session$sendInputMessage(id, msg)
+  }
+  session$onFlush(callback, once = TRUE)
+}

R/tooltip.R

@@ -3,27 +3,44 @@
 #' 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.
+#'   as the tooltip trigger. If `trigger` renders as multiple HTML
+#'   elements (e.g., it's a `tagList()`), the last HTML element is used for the
+#'   trigger. If the `trigger` should contain all of those elements, wrap the
+#'   object in a [div()] or [span()].
 #' @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).
+#' @param options A list of additional [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()].
+#' @section Theming/Styling:
+#'
+#'   Like other bslib components, tooltips can be themed by supplying [relevant
+#'   theming
+#'   variables](https://rstudio.github.io/bslib/articles/bs5-variables.html#tooltip-bg)
+#'   to [bs_theme()], which effects styling of every popover on the page. To
+#'   style a _specific_ popover differently from other popovers, utilize the
+#'   `customClass` option:
+#'
+#'   ```
+#'   tooltip(
+#'     "Trigger", "Tooltip message",
+#'     options = list(customClass = "my-tip")
+#'   )
+#'   ```
+#'
+#'   And then add relevant rules to [bs_theme()] via [bs_add_rules()]:
+#'
+#'   ```
+#'   bs_theme() |> bs_add_rules(".my-tip { max-width: none; }")
+#'   ```
 #'
 #' @describeIn tooltip Add a tooltip to a UI element
 #' @references <https://getbootstrap.com/docs/5.3/components/tooltips/>
 #' @export
+#' @seealso [popover()]
 #' @examplesIf interactive()
 #'
 #' tooltip(
@@ -57,11 +74,18 @@ tooltip <- function(
     abort("At least one value must be provided to `...`.")
   }
 
+  bad_opts <- intersect(c("title", "placement"), names(options))
+  if (length(bad_opts) > 0) {
+    rlang::abort(
+      sprintf("The `%s` option cannot be specified directly.", bad_opts[1])
+    )
+  }
+
   res <- web_component(
     "bslib-tooltip",
     id = id,
     placement = rlang::arg_match(placement),
-    options = jsonlite::toJSON(options, auto_unbox = TRUE),
+    bsOptions = to_json(options),
     !!!attribs,
     # Use display:none instead of <template> since shiny.js
     # doesn't bind to the contents of the latter
@@ -123,3 +147,8 @@ normalize_show_value <- function(show) {
 
   if (show) "show" else "hide"
 }
+
+
+to_json <- function(..., auto_unbox = TRUE, null = "null") {
+  jsonlite::toJSON(..., auto_unbox = auto_unbox, null = null)
+}

_pkgdown.yml

@@ -111,11 +111,12 @@ reference:
     Highlight important findings
   contents:
     - value_box
-- title: Tooltips
+- title: Tooltips & Popovers
   description: |
-    Provide additional context
+    Provide details on demand
   contents:
     - tooltip
+    - popover
 - title: Input controls
   description: |
     UI controls for capturing user input