r语言 - 反应式单选按钮与工具提示BS在闪亮

Question

我想使用 shinyBS 创建一个带有工具提示的 radioButtons 小部件。我想要实现的是创建一个带有 3 个按钮的小部件，其中包含 tooltip 中的不同信息。基于此解决方案，它创建了 3 个具有不同 id 值的独立单选按钮。是否可以做同样的事情，但使用一个带有 3 个按钮（即一个 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的剽窃。它还需要一个参数，即您希望将工具提示分配到的radioButton的choice。这允许更精细的选择。现在的区别在于在文档中选择元素的方式。在不深入 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来说，不能只是改变一点点，但必须有一个全新的功能。主要有一个原因。虽然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的人发送一个功能请求，以可能将其包含在他们的工作中。

Answer 2

您可以使用 jQuery 向单选按钮添加 id 属性：

library(shiny)
library(shinyBS)
js <- '$("#radioSelection :input").each(function() {
    $(this).attr("id", "radio_" + $(this).val());
});'
ui <- shinyUI(
  fluidPage(
    fluidRow(
      column(3,
             radioButtons("radioSelection", label = "So many options!", choices = c("A", "B", "C"))
      ),
      tags$script(js),
      bsTooltip("radio_A", title="Tooltip for A"),
      bsTooltip("radio_B", title="Tooltip for B"),
      bsTooltip("radio_C", title="Tooltip for C"),
      column(9,'Plot')
    )
  )
)
server <- function(input, output, session) {}
runApp(list(ui = ui, server = server), launch.browser = TRUE)