如何在鼠标悬停时显示光栅值？

Question

我正在使用传单编写一个闪亮的应用程序。我想要实现的是：

• 渲染一个简单的传单地图
• 单击按钮时，使用“leafletProxy”更新渲染以在顶部打印光栅
• 能够在弹出窗口中动态显示鼠标悬停时的光栅值（如此处的“标签”段落：https://rstudio.github.io/leaflet/popups.html）

我从 leafem 包中找到了 addImageQuery 函数。问题是 1) 它不会在弹出窗口中显示值，2) 它不能与 leafletProxy 一起使用。请参阅此处：https://github.com/r-spatial/leafem/issues/7

还发现了这个：https://gis.stackexchange.com/questions/439185/getting-l-imageoverlay-raster-layer-pixel-value-at-coords-in-leaflet。问题是我根本不掌握 javascript，而且我想在 R 中移植这个解决方案会很困难。

最后，我看到了这篇文章：R 栅格交互式绘图：鼠标悬停时的值。我尝试过 SeGa 提出的将栅格转换为 sf 对象的解决方案。但我的栅格非常大，严重降低了应用程序的流畅度。

这是一个最小的代码示例：

library(leaflet)
library(shiny)
library(dplyr)
library(sf)

ui <- fluidPage(

  fluidRow(
    leafletOutput(
      "map",
      width = 700,
      height = 700
    ),
  ),

  fluidRow(
    actionButton(
      inputId = "Action",
      label = "Print raster"
    )
  )

)

server <- function(input, output) {

  # Here I create a base map
  output$map <- renderLeaflet(
    {
      leaflet() %>%
        addProviderTiles("OpenStreetMap.France") %>%
        setView(lat = 46.7, lng = 2, zoom = 6)
    }
  )

  # udpate rendering with raster when button click
  observeEvent(
    input$Action,
    {
      pointSF <- st_sfc(st_point(c(2.5, 45.9)), crs = 4326)
      buffer <- st_buffer(pointSF, dist = 200000)

      grid <- st_make_grid(
        buffer,
        square = TRUE,
        cellsize = c(0.1,0.1),
        what = "centers"
      ) %>%
        st_as_sf() %>%
        cbind(., st_coordinates(.)) %>%
        st_drop_geometry() %>%
        mutate(Z = runif(nrow(.))) %>%
        rename(x = X, y = Y, z = Z)

      rast <- raster::rasterFromXYZ(grid, crs = 4326)

      leafletProxy("map") %>%
        addRasterImage(rast)
    }
  )

}

shinyApp(ui, server)

关于如何正确实现这一目标有什么想法吗？

Answer 1

好吧，我找到了一个肮脏的技巧来让它发挥作用。不过，如果有人有更干净的解决方案，请告诉我。

技巧是手动提取与光标位置相对应的光栅值，然后使用它添加一个生成弹出窗口的圆形标记（请参见下面的代码）。

library(leaflet)
library(shiny)
library(dplyr)
library(sf)
library(htmlwidgets)

ui <- fluidPage(
  
  fluidRow(
    leafletOutput(
      "map",
      width = 700,
      height = 700
    )
  ),
  
  fluidRow(
    actionButton(
      inputId = "Action",
      label = "Print raster"
    )
  )
  
)

server <- function(input, output) {
  
  local <- reactiveValues(
    rast = NULL,
    raster_value = data.frame(value = NA, long = 0, lat = 0)
  )
  
  # Here I create a base map
  output$map <- renderLeaflet(
    {
      leaflet() %>%
        addProviderTiles("OpenStreetMap.France") %>%
        setView(lat = 46.7, lng = 2, zoom = 6) %>% 
        # here : put cursor lat/long in input$hover_coordinates
        onRender(
          "function(el,x){
                    this.on('mousemove', function(e) {
                        var lat = e.latlng.lat;
                        var lng = e.latlng.lng;
                        var coord = [lat, lng];
                        Shiny.onInputChange('hover_coordinates', coord)
                    });
                    this.on('mouseout', function(e) {
                        Shiny.onInputChange('hover_coordinates', null)
                    })
                }"
        )
    }
  )
  
  # udpate rendering with raster when button click
  observeEvent(
    input$Action,
    priority = 1,
    {
      pointSF <- st_sfc(st_point(c(2.5, 45.9)), crs = 4326)
      buffer <- st_buffer(pointSF, dist = 200000)
      
      grid <- st_make_grid(
        buffer,
        square = TRUE,
        cellsize = c(0.1,0.1),
        what = "centers"
      ) %>%
        st_as_sf() %>%
        cbind(., st_coordinates(.)) %>%
        st_drop_geometry() %>%
        mutate(Z = runif(nrow(.))) %>%
        rename(x = X, y = Y, z = Z)
      
      local$rast <- raster::rasterFromXYZ(grid, crs = 4326)
      
      leafletProxy("map") %>%
        addRasterImage(local$rast) 
      
    }
  )
  
  observeEvent(
    input$hover_coordinates[1],
    {
      
      req(input$hover_coordinates[1], local$rast)
      
      # extract raster value based on input$hover_coordinates
      local$raster_value <- raster::extract(
        local$rast,
        matrix(
          c(input$hover_coordinates[2], input$hover_coordinates[1]),
          nrow = 1
        )
      )
      
      # cursor lat/long and corresponding raster value in a reactive data.frame
      local$raster_value <- data.frame(
        value = round(local$raster_value, 2),
        long = input$hover_coordinates[2],
        lat = input$hover_coordinates[1]
      )
    }
  )
  
  # Use "addCircleMarkers" to generate popup containing raster value
  observeEvent(
    local$raster_value, 
    {
      
      req(input$hover_coordinates[1], local$rast)
      
      leafletProxy("map") %>%
        addCircleMarkers(
          data = local$raster_value,
          label = ~ value,
          labelOptions = labelOptions(
            style = list(
              "box-shadow" = "3px 3px rgba(0,0,0,0.25)",
              "font-size" = "12px",
              "font-weight" = "bold",
              "border-color" = "rgba(0,0,0,0.5)"
            )
          ),
          stroke = FALSE,
          fill = TRUE,
          fillColor = "#00000000",
          radius = 8
        )
    }
  )
  
  
  
}

shinyApp(ui, server)