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

Question

我正在使用R shiny来构建Web应用程序,其中一些正在利用伟大的传单功能.

我想创建一个定制的高级弹出窗口,但我不知道如何继续.

你可以看看我在github上为这篇文章创建的项目中可以做些什么,或者直接在shinyapp.io 这里

弹出窗口越复杂,我的代码就越奇怪,因为我有点以一种奇怪的方式组合R和html(参见我在server.R中定义我的custompopup'i'的方式).

还有更好的方法吗？构建此类弹出窗口有哪些好的做法？如果我打算根据点击的标记显示图表,我应该提前构建它们,还是可以"动态"构建它们？我怎样才能做到这一点？

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

问候

Answer 1

我想这篇文章仍然有一些相关性.所以这是我的解决方案,如何将几乎任何可能的接口输出添加到传单弹出窗口.

我们可以通过以下步骤实现此目的:

• 将弹出UI元素作为字符插入到传单标准弹出字段中.正如角色的意思,它不是shiny.tag,而只是一种正常div.比如经典uiOutput("myID")就变成了<div id="myID" class="shiny-html-output"><div>.

• 弹出窗口被插入到特殊div的传单 - 弹出窗格中.我们添加一个EventListener来监视其内容是否发生了变化.(注意:如果弹出窗口消失,这意味着div删除了所有这些子项,因此这不是可见性问题,而是存在问题.)

• 当附加一个子节点,即弹出窗口出现时,我们绑定弹出窗口内的所有闪亮输入/输出.因此,没有生命uiOutput的东西充满了它应该是的内容.(人们希望Shiny自动执行此操作,但它无法注册此输出,因为它由Leaflets后端填充.)

• 弹出窗口被删除后,Shiny也无法取消绑定.这有问题,如果你再次打开弹出窗口,并抛出异常(重复ID).从文档中删除后,它就不能再被绑定了.因此,我们基本上将已删除的元素克隆到处理div中 - 它可以正确地解除绑定,然后将其删除.

我创建了一个示例应用程序(我认为)显示了此变通办法的全部功能,我希望它设计得足够简单,任何人都可以适应它.这个应用程序的大部分是为show,所以请原谅它有无关的部分.

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()像我上面那样使用会更简单。