r - 带工具提示的响应式(Reactive)单选按钮BS，闪闪发亮

Question

我想使用radioButtons使用工具提示创建shinyBS小部件。我要实现的是用tooltip中的3个按钮创建一个带有不同信息的按钮的小部件。基于此solution，创建了3个具有不同id值的单独的单选按钮。
是否可以使用一个带有3个按钮的 radio 小部件(即具有一个id值)来执行相同的操作？

library(shiny)
library(shinyBS)

ui <- shinyUI(
  fluidPage(
    fluidRow(
      column(3,
             HTML("<div class='container'><br>
                  <h1>Test</h1>
                  <div>
                  <label id='radio_venue_1'> 
                  <input type='radio' value='1' role='button'> button 1 
                  </label>
                  </div>
                  <div>
                  <label id='radio_venue_2'>
                  <input type='radio' value='2' role='button'> button 2
                  </label>
                  </div>
                  <div>
                  <label id='radio_venue_3'>
                  <input type='radio' value='3' role='button'> button 3
                  </label>
                  </div>
                  </div>")), 
      bsTooltip(id = "radio_venue_1", title = "Button 1 Explanation", placement = "right", trigger = "hover"),
      bsTooltip(id = "radio_venue_2", title = "Button 2 Explanation", placement = "right", trigger = "hover"),
      bsTooltip(id = "radio_venue_3", title = "Button 3 Explanation", placement = "right", trigger = "hover"),
      column(9,'Plot')
      )
    )
  )

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

Answer 1

初始答案:为单选按钮创建工具提示

较晚的答案，但是在这里:

如您所见，shinyBS的工具提示功能仅设计用于按ID选择。您需要比这更好的东西，因此我们需要构造一些新函数来代替较粗的bsTooltip。

新功能称为radioTooltip，基本上是从bsTooltip窃取的。还需要进行另一项争论，即要将工具提示分配给的choice的radioButton。这样可以进行更好的选择。现在的区别是在文档上选择元素的方式。无需过多介绍JavaScript细节，我们选择具有给定ID的元素，并保留提供的radioButton choice(内部元素，因此您可以通过input$radioButtonId获得的值)。

下面的代码。我建议您尝试一下。

library(shiny)
library(shinyBS)

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)
}

ui <- shinyUI(
  fluidPage(
    fluidRow(
      column(3,
        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"),
      column(9,'Plot')
      )
    )
  )

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

玩得开心!

编辑:为selectInput/selectizeInput 创建工具提示

对于selectInput，一个人不能仅仅改变一点，但必须有一个全新的功能。主要有一个原因。尽管radioButtons的所有选择都清晰可见并就在附近，但是selectizeInput会四处移动选择，重新渲染选择，仅在首次显示它们时进行渲染，依此类推。发生了很多事情。这就是为什么此解决方案获取周围的div并不断监听所添加的childNodes的原因。剩下的只是(希望高效)过滤。

下面的示例代码:

library(shiny)
library(shinyBS)

selectizeTooltip <- 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() {
      var opts = $.extend(", options, ", {html: true});
      var selectizeParent = document.getElementById('", id, "').parentElement;
      var observer = new MutationObserver(function(mutations) {
        mutations.forEach(function(mutation){
          $(mutation.addedNodes).filter('div').filter(function(){return(this.getAttribute('data-value') == '", choice, "');}).each(function() {
            $(this).tooltip('destroy');
            $(this).tooltip(opts);
          });
        });
      });
      observer.observe(selectizeParent, { subtree: true, childList: true });
    });
  ")))
  htmltools::attachDependencies(bsTag, shinyBS:::shinyBSDep)
}

ui <- shinyUI(
  fluidPage(
    actionButton("but", "Change choices!"),
    selectizeInput(inputId = "lala", label = "Label!", choices = LETTERS),
    selectizeTooltip(id = "lala", choice = "c", title = "Tooltip for c", placement = "right"),
    selectizeTooltip(id = "lala", choice = "C", title = "Tooltip for C", placement = "right"),
    selectizeTooltip(id = "lala", choice = "F", title = "Tooltip for F", placement = "right")
  )
)

server <- function(input, output, session){
  observeEvent(input$but, {
    updateSelectizeInput(session, "lala", choices = c("C", letters))
  })
}

shinyApp(ui, server)

请注意，工具提示也可以保留在updateSelectizeInput中，并且可能存在一些最初不存在的选择的工具提示。

如果人们感兴趣，我可以向ShinyBS家伙发送功能请求，以将其包含在他们的工作中。