如何在 Shiny 中为传单显示（高级）自定义弹出窗口？

Question

我正在使用 R shiny 构建 Web 应用程序，其中一些正在利用出色的传单功能。

我想创建一个自定义和高级弹出窗口，但我不知道如何进行。

您可以在 github 或直接在 shinyapp.io here

上查看我为这篇文章创建的项目中可以做什么

弹出窗口越复杂，我的代码就越奇怪，因为我正在以一种奇怪的方式组合 R 和 html（请参阅我在 server.R中定义我的 custompopup'i' 的方式>)..

有更好的方法吗？构建此类弹出窗口的良好做法是什么？如果我计划根据单击的标记显示图表，我应该提前构建它们，还是可以“即时”构建它们？ 我该怎么做？

非常感谢您对此的看法，请不要犹豫，在这里分享您的答案或直接更改我的 github 示例！

问候

Answer 1

我想这篇文章还是有一定意义的。所以这是我关于如何将几乎所有可能的界面输出添加到传单弹出窗口的解决方案。

我们可以通过以下步骤来实现：

• 在传单标准弹出字段中插入弹出 UI 元素作为字符。作为字符的意思，它不是shiny.tag，而只是一个普通的div。例如。经典的uiOutput("myID") 变成了<div id="myID" class="shiny-html-output"><div>。

• 弹出窗口被插入到一个特殊的div，leaflet-popup-pane。我们添加一个 EventListener 来监控其内容是否发生变化。 （注意：如果弹出窗口消失，则表示此div 的所有子级都已删除，因此这不是可见性问题，而是存在性问题。）

• 当一个孩子被附加时，即出现一个弹出窗口，我们将所有闪亮的输入/输出绑定到弹出窗口中。因此，毫无生气的uiOutput 充满了应有的内容。 （人们希望 Shiny 自动执行此操作，但它无法注册此输出，因为它是由 Leaflets 后端填充的。）

• 当弹出窗口被删除时，Shiny 也无法取消绑定它。如果您再次打开弹出窗口并引发异常（重复 ID），那就有问题了。一旦从文档中删除，就不能再解除绑定。所以我们基本上将删除的元素克隆到一个可以正确解绑的disposal-div，然后将其永久删除。

我创建了一个示例应用程序，（我认为）展示了此解决方法的全部功能，我希望它的设计足够简单，任何人都可以适应它。这个应用程序大部分是为了展示，所以请原谅它有不相关的部分。

library(leaflet)
library(shiny)

runApp(
  shinyApp(
    ui = shinyUI(
      fluidPage(

        # Copy this part here for the Script and disposal-div
        uiOutput("script"),
        tags$div(id = "garbage"),
        # End of copy.

        leafletOutput("map"),
        verbatimTextOutput("Showcase")
      )
    ),

    server = function(input, output, session){

      # Just for Show
      text <- NULL
      makeReactiveBinding("text")

      output$Showcase <- renderText({text})

      output$popup1 <- renderUI({
        actionButton("Go1", "Go1")
      })

      observeEvent(input$Go1, {
        text <<- paste0(text, "\n", "Button 1 is fully reactive.")
      })

      output$popup2 <- renderUI({
        actionButton("Go2", "Go2")
      })

      observeEvent(input$Go2, {
        text <<- paste0(text, "\n", "Button 2 is fully reactive.")
      })

      output$popup3 <- renderUI({
        actionButton("Go3", "Go3")
      })

      observeEvent(input$Go3, {
        text <<- paste0(text, "\n", "Button 3 is fully reactive.")
      })
      # End: Just for show

      # Copy this part.
      output$script <- renderUI({
        tags$script(HTML('
          var target = document.querySelector(".leaflet-popup-pane");

          var observer = new MutationObserver(function(mutations) {
            mutations.forEach(function(mutation) {
              if(mutation.addedNodes.length > 0){
                Shiny.bindAll(".leaflet-popup-content");
              };
              if(mutation.removedNodes.length > 0){
                var popupNode = mutation.removedNodes[0].childNodes[1].childNodes[0].childNodes[0];

                var garbageCan = document.getElementById("garbage");
                garbageCan.appendChild(popupNode);

                Shiny.unbindAll("#garbage");
                garbageCan.innerHTML = "";
              };
            });    
          });

          var config = {childList: true};

          observer.observe(target, config);
        '))
      })
      # End Copy

      # Function is just to lighten code. But here you can see how to insert the popup.
      popupMaker <- function(id){
        as.character(uiOutput(id))
      }

      output$map <- renderLeaflet({
        leaflet() %>% 
          addTiles() %>%
          addMarkers(lat = c(10, 20, 30), lng = c(10, 20, 30), popup = lapply(paste0("popup", 1:3), popupMaker))
      })
    }
  ), launch.browser = TRUE
)

注意：可能有人会想，为什么要从服务器端添加脚本。我遇到了，否则，添加 EventListener 会失败，因为 Leaflet 映射尚未初始化。我打赌有一些 jQuery 知识没有必要做这个技巧。

解决这个问题是一项艰巨的工作，但我认为值得花时间，因为 Leaflet 地图有了一些额外的实用性。玩得开心，如果有任何问题，请询问！

Answer 2

K. Rohde 的回答很好，@krlmlr 提到的编辑也应该使用。

我想对 K. Rohde 提供的代码进行两项小的改进（仍然要感谢 K. Rohde 提出的难题！）。下面是代码，后面会有改动说明：

library(leaflet)
library(shiny)

ui <- fluidPage(
  tags$div(id = "garbage"),  # Copy this disposal-div
  leafletOutput("map"),
  div(id = "Showcase")
)

server <- function(input, output, session) {

  # --- Just for Show ---

  output$popup1 <- renderUI({
    actionButton("Go1", "Go1")
  })

  observeEvent(input$Go1, {
    insertUI("#Showcase", where = "beforeEnd",
             div("Button 1 is fully reactive."))
  })

  output$popup2 <- renderUI({
    actionButton("Go2", "Go2")
  })

  observeEvent(input$Go2, {
    insertUI("#Showcase", where = "beforeEnd", div("Button 2 is fully reactive."))
  })

  output$popup3 <- renderUI({
    actionButton("Go3", "Go3")
  })

  observeEvent(input$Go3, {
    insertUI("#Showcase", where = "beforeEnd", div("Button 3 is fully reactive."))
  })

  # --- End: Just for show ---

  # popupMaker is just to lighten code. But here you can see how to insert the popup.
  popupMaker <- function(id) {
    as.character(uiOutput(id))
  }

  output$map <- renderLeaflet({
    input$aaa
    leaflet() %>%
      addTiles() %>%
      addMarkers(lat = c(10, 20, 30),
                 lng = c(10, 20, 30),
                 popup = lapply(paste0("popup", 1:3), popupMaker)) %>%

      # Copy this part - it initializes the popups after the map is initialized
      htmlwidgets::onRender(
'function(el, x) {
  var target = document.querySelector(".leaflet-popup-pane");

  var observer = new MutationObserver(function(mutations) {
    mutations.forEach(function(mutation) {
      if(mutation.addedNodes.length > 0){
        Shiny.bindAll(".leaflet-popup-content");
      }
      if(mutation.removedNodes.length > 0){
        var popupNode = mutation.removedNodes[0];

        var garbageCan = document.getElementById("garbage");
        garbageCan.appendChild(popupNode);

        Shiny.unbindAll("#garbage");
        garbageCan.innerHTML = "";
      }
    }); 
  });

  var config = {childList: true};

  observer.observe(target, config);
}')
  })
}

shinyApp(ui, server)

两个主要变化：

1. 只有在应用程序首次启动时初始化传单地图时，原始代码才有效。但是，如果稍后初始化传单地图，或者在最初不可见的选项卡内，或者如果地图是动态创建的（例如，因为它使用了一些反应值），那么弹出窗口代码将不起作用。为了解决这个问题，需要在传单地图上调用的 htmlwidgets:onRender() 中运行 javasript 代码，如您在上面的代码中所见。

2. 这不是关于传单，而是更多一般的良好做法：我一般不会使用makeReactiveBinding() + <<-。在这种情况下，它被正确使用，但人们很容易滥用<<-，而不了解它的作用，所以我宁愿远离它。使用text <- reactiveVal() 几乎可以轻松替代它，我认为这将是一种更好的方法。但在这种情况下，比使用反应变量更好的是，像上面那样使用insertUI() 会更简单。