r - Shiny :在选择输入选项上添加一个悬停按钮

Question

问题:
我正在尝试将“悬停文本”添加到 Shiny 的选择输入/多输入功能中的可用选项中。根据不同用户的说法，ShinyBS 的工具提示功能仅设计用于按 id 选择。因此，我试图使用比这更好的东西来实现我的结果。
This is great solution that I am trying to modify.解决方案包括创建一个名为 selectizeInput 的新函数。 :(根据函数的创建者)
“[] 移动选择，重新渲染它们，仅在它们第一次显示时才渲染它们，依此类推。发生了很多事情。这就是为什么这个解决方案捕获周围的 div 并不断监听添加的 childNodes。”
我不太了解该函数发生了什么，但这里有一些可重现代码的示例。包括用户功能 selectizeInput以上引用。如您所见，我正在尝试使用此功能在我的 multiInput 中添加悬停文本功能。 我想添加功能，以便当鼠标悬停在“第 1 组”上时，会弹出“第 1 组定义”文本。
我愿意使用完全不同的解决方案来添加此功能!
我试过的:
任何建议都非常感谢!理想情况下，我会使用 multiInput，但将 multiInput 设置为 TRUE 的 selectInput 也是一个很好的解决方法。但是，执行此操作时会出现其他一些问题。

一旦我选择了一个选项，其余选项的标签就不会显示。例如，当我选择第 1 组和第 3 组时，将鼠标悬停在第 2 组的标签上时看不到它。

包含标签的文本框(在下拉菜单中)非常窄——不容易阅读定义

选择后，定义将部分隐藏

这是我的代码:

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