闪亮的小叶鼠标悬停弹出窗口

Question

我想构建一个闪亮的应用程序，当鼠标悬停在一个形状/圆形而不是标准单击上时，会弹出一个弹出窗口

特别是我试图在鼠标悬停时弹出窗口...随着鼠标移离它而消失。

此页面（https://rstudio.github.io/leaflet/shiny.html）建议我需要类似observeEvent({input$mymap_shape_mouseover},{showPopup()})

但不确定在哪里输入或如何使用它，因此将不胜感激。

以下是一个简单的随机示例...

    library(shiny)
    library(leaflet)
    library(data.table)


    uu <-  data.table(row_num=seq(100),
                    Latitude=c(52+cumsum(runif(100,-0.001,0.001))),
                    Longitude=c(1+cumsum(runif(100,-0.001,0.001)))
    )





  ui <- fluidPage(
    leafletOutput("mymap")
  )

  server <- function(input, output, session) {
    output$mymap <- renderLeaflet({
      leaflet() %>%
        addTiles() %>%
        addCircles(lng=uu$Longitude,
                   lat=uu$Latitude,
                   radius=2)
    })

    # Show a popup at the given location
    show_popup_on_mouseover <- function(id, lat, lng) {
      selected_point <- uu[row_num == id,]
      content <- as.character(selected_point$row_num)
      leafletProxy("mymap") %>% 
        addPopups(lng, lat, content)
    }


    # When circle is hovered over...show a popup
    observe({
      leafletProxy("mymap") %>% clearPopups()
      event <- input$mymap_shape_mouseover
      print(event)
      if (is.null(event)){
        return()
      } else {
        isolate({
          show_popup_on_mouseover(event$id, event$lat, event$lng)
        })
      }
    })


  }

  shinyApp(ui, server)

Answer 1

这是一个相当大的挑战。我想它无法完全解决。

事情是这样的：如果你想使用 Shiny 端的鼠标事件来创建和删除一些弹出窗口，你不能依赖你得到的传单事件。

更详细地说：您在 上触发 Popup 是正确的input$mymap_shape_mouseover。在您的示例中，clearPopups每次创建新弹出窗口时您也使用了该函数。这可以通过设置 shared 来避免layerId，就像我在下面几乎可以工作的示例中使用的那样，以确保只打开一个弹出窗口。除此之外，我的示例在逻辑上基本相同。

起初我以为可以将clearPopup函数绑定到mouseout您圈子上的事件，但是有一个问题。每当您添加弹出窗口时，弹出容器将直接位于您的光标下方，因此mouseout即使光标仍在标记/圆圈上方，也会触发。所以这会导致闪烁的弹出窗口，被生成并立即删除，导致鼠标再次在圆圈上，从而再次渲染弹出窗口，依此类推。

一个可能的解决方法是考虑input$mymap_popup_mouseover到这一点，但不幸的是，leaflet包中有一个错误，无法访问弹出鼠标事件。我在Github上的一个问题上添加了评论，Joe Chang 立即承诺会对此进行调查。

最接近的人可以获得：

library(shiny)
library(leaflet)
library(data.table)

uu <-  data.table(
  row_num=seq(100),
  Latitude=c(52+cumsum(runif(100,-0.001,0.001))),
  Longitude=c(1+cumsum(runif(100,-0.001,0.001)))
)

ui <- fluidPage(
  leafletOutput("mymap")
)

server <- function(input, output, session) {
  output$mymap <- renderLeaflet({
    leaflet() %>%
      addTiles() %>%
      addCircles(lng = uu$Longitude, lat = uu$Latitude, radius = 2, layerId = uu$row_num)
  })

  # When circle is hovered over...show a popup
  observeEvent(input$mymap_shape_mouseover$id, {
    pointId <- input$mymap_shape_mouseover$id

    lat = uu[uu$row_num == pointId, Latitude]
    lng = uu[uu$row_num == pointId, Longitude]
    leafletProxy("mymap") %>% addPopups(lat = lat, lng = lng, as.character(pointId), layerId = "hoverPopup")
  })
}

shinyApp(ui, server)

编辑：便宜的修复。

另一种可能性是下面的解决方法。如果您可以接受稍微偏移的弹出窗口，则可以避免该mouseover/mouseout问题。当在圆上方渲染弹出窗口时，弹出容器完全在圆外，一切正常。偏移量计算纯粹是通过试验。

library(shiny)
library(leaflet)
library(data.table)

uu <-  data.table(
  row_num=seq(100),
  Latitude=c(52+cumsum(runif(100,-0.001,0.001))),
  Longitude=c(1+cumsum(runif(100,-0.001,0.001)))
)

ui <- fluidPage(
  leafletOutput("mymap")
)

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

  radius = 3

  output$mymap <- renderLeaflet({
    leaflet() %>%
      addTiles() %>%
      addCircles(lng = uu$Longitude, lat = uu$Latitude, radius = radius, layerId = uu$row_num)
  })

  observeEvent(input$mymap_shape_mouseout$id, {
    leafletProxy("mymap") %>% clearPopups()
  })

  # When circle is hovered over...show a popup
  observeEvent(input$mymap_shape_mouseover$id, {
    pointId <- input$mymap_shape_mouseover$id
    lat = uu[uu$row_num == pointId, Latitude]
    lng = uu[uu$row_num == pointId, Longitude]
    offset = isolate((input$mymap_bounds$north - input$mymap_bounds$south) / (23 + radius + (18 - input$mymap_zoom)^2 ))

    leafletProxy("mymap") %>% addPopups(lat = lat + offset, lng = lng, as.character(pointId))
  })
}

shinyApp(ui, server)