将工具提示添加到 Shiny 中的选项卡

Question

我正在尝试使用 shinyBS 包为 Shiny 应用程序添加工具提示/弹出框，但由于选项卡没有输入/ID 而出现问题。这会阻止工具提示触发。有什么想法吗？

library(shiny)
library(shinyBS)

    shinyApp(
      ui = tagList(
         navbarPage(
           theme = "cerulean",  # <--- To use a theme, uncomment this
          "shinythemes",
          tabPanel(id="test","Navbar 1",
                   bsTooltip("test", title="Test Title", trigger = "hover"),
                   sidebarPanel(
                     fileInput("file", "File input:"),
                     textInput("txt", "Text input:", "general"),
                     sliderInput("slider", "Slider input:", 1, 100, 30),
                     tags$h5("Deafult actionButton:"),
                     actionButton("action", "Search"),

                     tags$h5("actionButton with CSS class:"),
                     actionButton("action2", "Action button", class = "btn-primary")
                   ),
                   mainPanel(
                     tabsetPanel(
                       tabPanel("Tab 1",
                                bsTooltip("Tab 1", title="Test Title"),
                                h4("Table"),
                                tableOutput("table"),
                                h4("Verbatim text output"),
                                verbatimTextOutput("txtout"),
                                h1("Header 1"),
                                h2("Header 2"),
                                h3("Header 3"),
                                h4("Header 4"),
                                h5("Header 5")
                       ),
                       tabPanel("Tab 2"),
                       tabPanel("Tab 3")
                     )
                   )
          ),
          tabPanel("Navbar 2"),
          tabPanel("Navbar 3")
        )
      ),
      server = function(input, output) {
        output$txtout <- renderText({
          paste(input$txt, input$slider, format(input$date), sep = ", ")
        })
        output$table <- renderTable({
          head(cars, 4)
        })
      }
    )

附件是一个使用 TabPanels 和 Tabset Panels 进行测试的测试应用程序。

Answer 1

您可以在传递选项卡的标题时使用 HTML。在这种情况下，我只是将标题放在span 中并添加了属性title，这是HTML 使用默认鼠标悬停的属性。对我来说，这比尝试将其添加到 shinyBS 上要简单得多。

library(shiny)
library(shinyBS)

shinyApp(
  ui = tagList(
    navbarPage(
      theme = "cerulean",  # <--- To use a theme, uncomment this
      "shinythemes",
      tabPanel(id="test",span("Navbar 1",title="Test Title"),
               sidebarPanel(
                 fileInput("file", "File input:"),
                 textInput("txt", "Text input:", "general"),
                 sliderInput("slider", "Slider input:", 1, 100, 30),
                 tags$h5("Deafult actionButton:"),
                 actionButton("action", "Search"),
                 
                 tags$h5("actionButton with CSS class:"),
                 actionButton("action2", "Action button", class = "btn-primary")
               ),
               mainPanel(
                 tabsetPanel(
                   tabPanel(span("Tab 1", title="Test Title"),
                            h4("Table"),
                            tableOutput("table"),
                            h4("Verbatim text output"),
                            verbatimTextOutput("txtout"),
                            h1("Header 1"),
                            h2("Header 2"),
                            h3("Header 3"),
                            h4("Header 4"),
                            h5("Header 5")
                   ),
                   tabPanel("Tab 2"),
                   tabPanel("Tab 3")
                 )
               )
      ),
      tabPanel("Navbar 2"),
      tabPanel("Navbar 3")
    )
  ),
  server = function(input, output) {
    output$txtout <- renderText({
      paste(input$txt, input$slider, format(input$date), sep = ", ")
    })
    output$table <- renderTable({
      head(cars, 4)
    })
  }
)

Answer 2

这是一个向 forst 选项卡添加工具提示的最小示例

library(shiny)
library(shinyBS)

shinyApp(
  ui = tagList(
    navbarPage(
      theme = "cerulean",  # <--- To use a theme, uncomment this
      "shinythemes",
      tabPanel(id="test","Navbar 1",
               bsTooltip("test", title="Test Title", trigger = "hover"),
               sidebarPanel(
                 fileInput("file", "File input:"),
                 textInput("txt", "Text input:", "general"),
                 sliderInput("slider", "Slider input:", 1, 100, 30),
                 tags$h5("Deafult actionButton:"),
                 actionButton("action", "Search"),

                 tags$h5("actionButton with CSS class:"),
                 actionButton("action2", "Action button", class = "btn-primary")
               ),
               mainPanel(
                 tabsetPanel(
                   tabPanel("Tab 1",
                            bsTooltip("Tab 1", title="Test Title"),
                            div(id = "my_id",                       #changed
                                h4("Table"),
                                tableOutput("table"),
                                h4("Verbatim text output"),
                                verbatimTextOutput("txtout"),
                                h1("Header 1"),
                                h2("Header 2"),
                                h3("Header 3"),
                                h4("Header 4"),
                                h5("Header 5")
                            ),                                      # changed
                            bsTooltip('my_id','some text...')       # changed
                   ),
                   tabPanel("Tab 2"),
                   tabPanel("Tab 3")
                 )
               )
      ),
      tabPanel("Navbar 2"),
      tabPanel("Navbar 3")
    )
  ),
  server = function(input, output) {
    output$txtout <- renderText({
      paste(input$txt, input$slider, format(input$date), sep = ", ")
    })
    output$table <- renderTable({
      head(cars, 4)
    })
  }
)

如你所见，我只更改了 3 行

• 第一行和第二行将第一个选项卡的内容包装在一个 div 中。 div 有一个 id my_id，稍后会用到
• 第三行使用 div id 添加工具提示

基本上，您应该能够将您想要的任何内容包装到一个 div 中，给它一个 id，然后添加一个弹出框。如果您在使用这种方法时遇到任何问题，请告诉我。