Creating tooltip for radioGroupButtons while using bslib

Question

I want to get a tooltip for a shinywidgets::radiogroupButton (or shiny::radioButton) that warns the user about the consecuences of choosing each option, sepparately. I want to achieve the exact same output mentioned in this answer. The problem is the afore-mentioned solution won't work y I lay out my dashboard using bslib.

This is the function defined in the post

# function creeated to display tooltips
radioTooltip <- function(id, choice, title, placement = "bottom", trigger = "hover", options = NULL){
  
  options = shinyBS:::buildTooltipOrPopoverOptionsList(title, placement, trigger, options)
  options = paste0("{'", paste(names(options), options, sep = "': '", collapse = "', '"), "'}")
  bsTag <- shiny::tags$script(shiny::HTML(paste0("
    $(document).ready(function() {
      setTimeout(function() {
        $('input', $('#", id, "')).each(function(){
          if(this.getAttribute('value') == '", choice, "') {
            opts = $.extend(", options, ", {html: true});
            $(this.parentElement).tooltip('destroy');
            $(this.parentElement).tooltip(opts);
          }
        })
      }, 500)
    });
  ")))
  htmltools::attachDependencies(bsTag, shinyBS:::shinyBSDep)
}

This is what I'd like to se working:

library(shiny)
library(bslib)

# small shiny app
ui <- page_sidebar(title = "App ",
    sidebar = sidebar(
      shinyWidgets::radioGroupButtons("radioSelection", label = "So many options!", choices = c("A", "B", "C")),
      radioTooltip(id = "radioSelection", choice = "A", title = "Button 1 Explanation", placement = "right", trigger = "hover"),
      radioTooltip(id = "radioSelection", choice = "B", title = "Button 2 Explanation", placement = "right", trigger = "hover"),
      radioTooltip(id = "radioSelection", choice = "C", title = "Button 3 Explanation", placement = "right", trigger = "hover")
    ),
    page_fillable(
      column(9,'Plot')
      )
    )

server <- function(input, output, session) {}
shinyApp(ui = ui, server = server)

For reference, this work perfectly, the only difference is that no bslib functions are used here

## it works perfectly if you instead run:
ui <- shinyUI(
  fluidPage(
    fluidRow(
      column(3,
        radioGroupButtons("radioSelection", label = "So many options!", choices = c("A", "B", "C"))
      ),
      radioTooltip(id = "radioSelection", choice = "A", title = "Button 1 Explanation", placement = "right", trigger = "hover"),
      radioTooltip(id = "radioSelection", choice = "B", title = "Button 2 Explanation", placement = "right", trigger = "hover"),
      radioTooltip(id = "radioSelection", choice = "C", title = "Button 3 Explanation", placement = "right", trigger = "hover"),
      column(9,'Plot')
      )
    )
  )

I tried to use the functions defined above. It stops working when you lay out the dashboead using bslib functions.

score 0 · Accepted Answer · answered Jul 07 '23 at 08:52

You have to:

replace destroy with dispose
remove the html dependency
use ordinary radio buttons, not those of shinyWidgets

radioTooltip <- function(id, choice, title, placement = "bottom", trigger = "hover", options = NULL){
  
  options = shinyBS:::buildTooltipOrPopoverOptionsList(title, placement, trigger, options)
  options = paste0("{'", paste(names(options), options, sep = "': '", collapse = "', '"), "'}")
  bsTag <- shiny::tags$script(shiny::HTML(paste0("
    $(document).ready(function() {
      setTimeout(function() {
        $('input', $('#", id, "')).each(function(){
          if(this.getAttribute('value') == '", choice, "') {
            opts = $.extend(", options, ", {html: true});
            $(this.parentElement).tooltip('dispose');
            $(this.parentElement).tooltip(opts);
          }
        })
      }, 500)
    });
  ")))
}

library(shiny)
library(bslib)

# small shiny app
ui <- page_sidebar(
  title = "App ",
  sidebar = sidebar(
    radioButtons("radioSelection", label = "So many options!", choices = c("A", "B", "C")),
    radioTooltip(id = "radioSelection", choice = "A", title = "Button 1 Explanation", placement = "right", trigger = "hover"),
    radioTooltip(id = "radioSelection", choice = "B", title = "Button 2 Explanation", placement = "right", trigger = "hover"),
    radioTooltip(id = "radioSelection", choice = "C", title = "Button 3 Explanation", placement = "right", trigger = "hover")
  ),
  page_fillable(
    column(9,'Plot')
  )
)

server <- function(input, output, session) {}

shinyApp(ui = ui, server = server)

score 0 · Answer 2 · answered Jul 10 '23 at 19:10

You can use htmltools::tagQuery() + bootstrap tooltips.

Here is a reprex of how to achieve that:

#' Radio buttons with tooltip
#' 
#' @param explanation Character vector containing explanations to be shown in
#' the tooltips of the choices
#' @inheritDotParams [shiny::radioButtons]
#' @return shiny::tagList
radioButtonsWithTooltip <- \(..., explanations = NULL) {
  radios <- shiny::radioButtons(...)
  choices <- list(...)$choices
  if (is.null(explanations) || is.null(choices)) {
    return(radios)
  }
  radios_tag_q <- htmltools::tagQuery(radios)
  explanations <- rep(explanations, length.out = length(choices))
  labels <- radios_tag_q$find(".radio label")$selectedTags()
  labels <- lapply(seq_along(labels), \(i) {
    label_tag_q <- labels[[i]] |> htmltools::tagQuery()
    label_tag_q$addAttrs(
      `data-bs-toggle` = "tooltip",
      `data-bs-title` = explanations[[i]],
      `data-bs-placement` = "right",
      `data-bs-trigger` = "hover focus"
    )
    tags$div(class = "radio", label_tag_q$allTags())
  })
  radios_tag_q$find(".radio")$remove()
  radios_tag_q$append(labels)
  
  tagList(
    radios_tag_q$allTags(),
    # re-initialize tooltips incase of `uiOutput` + `renderUI`:
    tags$script(
      shiny::HTML(
        r"{
        tooltipTriggerList = document.querySelectorAll('[data-bs-toggle="tooltip"]');
        tooltipList = [...tooltipTriggerList].map(tooltipTriggerEl => new bootstrap.Tooltip(tooltipTriggerEl));
        }"
      )
    )
  )
}

`ui.R`

ui <- bslib::page(
  title = "RadioGroup tooltip",
  theme = bslib::bs_theme(version = 5),
  tags$div(
    class = "container",
    radioButtonsWithTooltip(
      inputId = "dist",
      label = "Distribution type:",
      choices = c(
        "Normal" = "norm",
        "Uniform" = "unif",
        "Log-normal" = "lnorm",
        "Exponential" = "exp"
      ),
      explanations = c(
        "The normal distribution",
        "This is the uniform dist",
        "Log normal here!",
        "Exponential dwistibushion"
      )
    ),
    tags$p(
      class = "muted",
      "Placeholder text to demonstrate some",
      tags$a(
        href = "#",
        `data-bs-toggle` = "tooltip",
        `data-bs-title` = "Default tooltip",
        `data-bs-trigger` = "hover focus",
        "inline links"
      )
    )
  ),
  # initialize bootstrap tooltips:
  tags$script(
    shiny::HTML(
      r"{
      let tooltipTriggerList = document.querySelectorAll('[data-bs-toggle="tooltip"]');
      let tooltipList = [...tooltipTriggerList].map(tooltipTriggerEl => new bootstrap.Tooltip(tooltipTriggerEl));
      }"
    )
  )
)

server.R

server <- function(input, output, session) {
  
}

Creating tooltip for radioGroupButtons while using bslib

2 Answers2

ui.R

`ui.R`