Shiny：在 select 输入选项上添加 hover 按钮

Question

问题：我正在尝试将“悬停文本”添加到 shiny 中的 select 输入/多输入 function 中的可用选项中。 根据另一位用户的说法，ShinyBS 的工具提示 function 仅设计用于按 id 选择。 因此，我试图使用比这更好的东西来实现我的结果。

这是我正在尝试修改的绝佳解决方案。 该解决方案涉及创建一个名为selectizeInput的新 function ：（根据函数的创建者）

“[] 移动选项，重新呈现它们，仅在它们第一次显示时呈现它们等等。很多事情都会发生。这就是为什么这个解决方案会抓取周围的 div 并不断监听正在添加的子节点。”

我不太了解 function 发生了什么，但这里是一些可重现代码的示例。 包括上面提到的用户 function selectizeInput 。 如您所见，我正在尝试使用此 function 在我的multiInput中添加 hover 文本。 我想添加功能，以便当将鼠标悬停在“第 1 组”上时，会弹出“第 1 组定义”文本。

我愿意使用完全不同的解决方案来添加此功能！

我尝试过的：非常感谢任何建议，我最好使用 multiInput。 但是，将多个设置为 TRUE 的 selectInput 也是一个很好的解决方法。 当我这样做时，还会出现其他一些问题。

1. 一旦我选择了select，剩下的选项的标签就不显示了。 例如，当我 select 第 1 组和第 3 组时，当我在 hover 上看到第 2 组的 label 时，我看不到它。

2. 包含 label 的文本框（在下拉列表中）非常狭窄——不容易阅读定义

3. 选择后，定义将部分隐藏

这是我的代码：

     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 <- fluidPage(theme = shinytheme("superhero"),  # shinythemes::themeSelector(), #
    
    
                     br(),
                     br(),
                     headerPanel(h2(" ", align = 'center')),
                     br(),
                     sidebarLayout(
                       sidebarPanel(
                         uiOutput("choose_prog"),
    
                         uiOutput("choose_name"),
                         br(),
                         selectizeTooltip(id="choose_name", choice = "group 1", title = "group 1 definition this is a long definition that does not really display well within the narrow text box", placement = "right", trigger = "hover"),
                         selectizeTooltip(id="choose_name", choice = "group 2", title = "group 2 definition this is another long definition. WHen group 1 and group 3 is is selected, you no longer see this definition", placement = "right", trigger = "hover"),
                         selectizeTooltip(id="choose_name", choice = "group 3", title = "group 3 definition this does not show if all of the other groups are selected ", placement = "right", trigger = "hover"),
    
    
                       ),
    
                       mainPanel(
                         plotOutput("plot"),
                       )
                     )
    
     )
    
     server <- function(input, output) {
    
       # Drop down selection to chose the program 
       output$choose_prog <- renderUI({
         selectInput("program", 
                     label = HTML('<FONT color="orange"><FONT size="4pt">Select a Program:'),
                     choices = c("A","B","C"))
       })
    
    
       # Drop down for name
       output$choose_name <- renderUI({
    
         # SelectInput works, but this only allows the selection of a SINGLE option
         selectInput("names",
                    label = HTML('<FONT color="orange"><FONT size="4pt">Select user group of interest:'),
                    choices = c("group 1", "group 2", "group 3"), 
                    multiple = T)
    
    
         # multiInput("names", 
         #            label = HTML('<FONT color="orange"><FONT size="4pt">Select user group of interest:'),
         #            choices = c("group 1", "group 2", "group 3"))
         # 
    
    
       })
    
       observeEvent(input$choose_name, {
         updateSelectizeInput(session, "choose_name", choices =  c("group 1", "group 2", "group 3"))
       })
     }
    
     shinyApp(ui = ui, server = server)

Answer 1

像这样的东西？

library(shiny)

shinyApp(
  ui = fluidPage(
    br(),
    selectizeInput(
      "slctz", "Select something:",
      choices = NULL, 
      options = list( 
        options = list(
          list(label = "Choice 1", value = "value1", tooltip = "tooltip1"),
          list(label = "Choice 2", value = "value2", tooltip = "tooltip2")
        ),
        #items = list("Option 1"),
        valueField = "value", 
        labelField = "label",
        render = I("{
      item: function(item, escape) { 
        return '<span>' + item.label + '</span>'; 
      },
      option: function(item, escape) { 
        return '<span title=\"' + item.tooltip + '\">' + item.label + '</span>'; 
      }
    }")
      )
    )
  ),
  server = function(input, output) {}
)