如何创建出现在选项卡开关处的闪亮弹出框？

Question

我想在我的 Shiny 应用程序中创建一个弹出框/工具提示，当用户切换到包含弹出框所附加的数据表的选项卡时，该弹出框/工具提示会立即出现。使用

shinybs

包，我可以创建一个在单击或悬停时出现的弹出窗口，但我希望它无需悬停或单击即可出现。我的猜测是，这可以通过

trigger = "manual"

选项来实现，但我不知道如何定义手动触发器。我没有和

shinybs

结婚；任何其他可以达到预期结果的解决方案都同样受到赞赏。

理想情况下，我还希望放置弹出窗口，使其指向特定行。我之前曾在数据表中使用

rowCallback = JS(rowCallback)

参数以及

shinyjs

包来获取各个行的悬停工具提示。我不懂 JavaScript；所以我不知道是否可以对其进行修改，以便工具提示在不悬停的情况下出现。

无论如何，我还需要一个关闭弹出窗口/工具提示的选项。我非常感谢您的帮助。

这是一个带有点击触发器的shinybs弹出窗口的最小示例（不是我需要的）：

library(shiny)
library(shinyBS)
library(DT)

data <- as.data.frame(rbind(c(1,2,3), c(4,5,6)))
colnames(data) <- c("Var1", "Var2", "Var3")

ui <- navbarPage(
  title = "Title", id = "navbar", 
  tabsetPanel(id="tabs", 
              tabPanel(value = "tab1", title = "Tab1",
                       actionButton("action1", "Switch tabs")
                       ),
              
  )
)

server <- function(input, output, session) {
    observeEvent(input$action1, {
      insertTab(inputId = "tabs", target = "tab1", select=T,
                tabPanel(value = "tab2", title = "Tab2",
                         dataTableOutput("table1"),
                         bsPopover(id="table1", title="A popover",
                                   placement = "bottom", trigger = "click")
                ) 
      )
    })
  
  output$table1 <- renderDataTable({
    datatable(data)
  })
}

shinyApp(ui, server)

Answer 1

我试一试：

1. 定义一个函数 (

   make_popover

   )，添加必要的

   HTML

   来创建弹出框元素（参见 Bootstrap Popover Docs。特别是将

   data-trigger

   设置为手动以仅手动触发它。
2. 用此标记替换表格中的一个单元格，并在

   escape = FALSE

   中使用

   datatable

   ，以免忽略此

   HTML

   。
3. 包含一个

   observer

   ，它会在选项卡更改时触发并调用

   JS

   函数以最终显示弹出窗口。我们可以使用

   shinyjs

   ，但我们通过使用

   shiny

   使用规范的

   addCustomMessageHandler

   解决方案。
4. 最终添加一个

   click

   处理程序，一旦注册了第二个面板上的单击，该处理程序就会再次关闭弹出窗口。

library(shiny)
library(DT)

my_data <- data.frame(
   a = c(1, 4),
   b = c(2, 5),
   c = c(3, 6)
)

js <- HTML("
   $(function () {
      $('[data-toggle=\"popover\"]').popover({});
      $('div[data-value=\"tab2\"]').on('click', () => $('[data-toggle=\"popover\"]').popover('hide'));
   });
   Shiny.addCustomMessageHandler('show_popover', function(message) {
      setTimeout(() => $('[data-toggle=\"popover\"]').popover('show'), 100); // timeout needed to avoid that the element is not shown yet
   })"
)

make_popover <- function(x, title, content) {
   a(x,
     style = "text-decoration: none; color: inherit;",
     "data-toggle" = "popover",
     "data-trigger" = "manual",
     title = title,
     "data-content" = content) %>% 
      as.character()   
}

ui <- navbarPage(
   title = "Popup Example",
   header = tags$head(tags$script(js)),
   tabsetPanel(
      id = "tabs",
      tabPanel(
         value = "tab1",
         title = "Tab 1",
      ),
      tabPanel(
         value = "tab2",
         title = "Tab 2",
         dataTableOutput("tbl")
      )
   ),
   id = "navbar"
)


server <- function(input, output, session) {
   output$tbl <- renderDataTable({
      dat <- my_data
      dat[2, "b"] <- make_popover(dat[2, "b"],
                                  "Dismissible popover",
                                  "And here's some amazing content. It's very engaging. Right?")
      datatable(
         dat,
         escape = FALSE)
   })
   
   observeEvent(input$tabs, {
      if (input$tabs == "tab2") {
         session$sendCustomMessage("show_popover", 1)
      }
   })
}

shinyApp(ui, server)