3

I'm writing a shiny app using leaflet. What I want to achieve is :

  • render a simple leaflet map
  • when click on a button, update rendering with "leafletProxy" to print a raster on top
  • Being able to dynamically show raster value on mouse hover in a popup (like here, "labels" paragraph : https://rstudio.github.io/leaflet/popups.html)

I found the addImageQuery function from leafem package. Problem is 1) it doesn't display the value in a popup, and 2) it doesn't work with leafletProxy. See here : https://github.com/r-spatial/leafem/issues/7

Also found this : https://gis.stackexchange.com/questions/439185/getting-l-imageoverlay-raster-layer-pixel-value-at-coords-in-leaflet. Problem is I don't master javascript at all, and I think I would struggle a lot porting this solution in R.

Finally, I saw this post : Interactive plotting with R raster: values on mouseover. I had tried the solution proposed by SeGa to convert raster to sf object. But my raster is very large and it degrades severely the smoothness of the app.

Here is a minimal code example :

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)

Any idea on how to achieve this properly ? Thanks guys.

Kantoulf
  • 31
  • 2

1 Answers1

0

Ok, I found a dirty trick to make it work. Still, let me know if someone has a cleaner solution.

The trick was to exract manually the raster value corresponding to cursor position, then use it to add a circle marker that generates the popup (see code below).

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)
Kantoulf
  • 31
  • 2