Shiny - how to highlight an object on a leaflet map when selecting a record in a datatable?

问题

Is there a way to highlight a marker or polyline on a leaflet map when selecting (clicking on) the corresponding record in a datatable?

I looked at these questions/threads:

selecting a marker on leaflet, from a DT row click and vice versa - no answer

https://github.com/r-spatial/mapedit/issues/56 - check timelyportfolio's comment on Jul 23, 2017. As it shows in the gif, I would like to be able to select a row in the datatable so that the corresponding map object (marker/polyline) is highlighted as well (without editing the map).

Here is a working example where the highlighted map object is selected in the datatable below but not vice versa - which is what I am trying to achieve.

##############################################################################
# Libraries
##############################################################################
library(shiny)
library(shinythemes)
library(ggplot2)
library(plotly)
library(leaflet)
library(DT)
##############################################################################
# Data
##############################################################################
qDat <- quakes
qDat$id <- seq.int(nrow(qDat))
str(qDat)
##############################################################################
# UI Side
##############################################################################
ui <- fluidPage(
  titlePanel("Visualization of Fiji Earthquake"),

  # side panel
  sidebarPanel(
    h3('Fiji Earthquake Data'),

    sliderInput(
      inputId = "sld01_Mag",
      label="Show earthquakes of magnitude:", 
      min=min(qDat$mag), max=max(qDat$mag),
      value=c(min(qDat$mag),max(qDat$mag)), step=0.1
      ),

    plotlyOutput('hist01')
    ),

  # main panel
  mainPanel(
    leafletOutput('map01'),
    dataTableOutput('table01')
    )

)
##############################################################################
# Server Side
##############################################################################
server <- function(input,output){
  qSub <-  reactive({

      subset <- subset(qDat, qDat$mag>=input$sld01_Mag[1] &
                         qDat$mag<=input$sld01_Mag[2])
  })

  # histogram
  output$hist01 <- renderPlotly({
    ggplot(data=qSub(), aes(x=stations)) + 
      geom_histogram(binwidth=5) +
      xlab('Number of Reporting Stations') +
      ylab('Count') +
      xlim(min(qDat$stations), max(qDat$stations))+
      ggtitle('Fiji Earthquake')
  })

  # table
  output$table01 <- renderDataTable({

    DT::datatable(qSub(), selection = "single",options=list(stateSave = TRUE))
  })

  # map
  output$map01 <- renderLeaflet({
    pal <- colorNumeric("YlOrRd", domain=c(min(quakes$mag), max(quakes$mag)))
    qMap <- leaflet(data = qSub()) %>% 
      addTiles() %>%
      addMarkers(popup=~as.character(mag), layerId = qSub()$id) %>%
      addLegend("bottomright", pal = pal, values = ~mag,
                title = "Earthquake Magnitude",
                opacity = 1)
    qMap
  })

  observeEvent(input$map01_marker_click, {
    clickId <- input$map01_marker_click$id
    dataTableProxy("table01") %>%
      selectRows(which(qSub()$id == clickId)) %>%
      selectPage(which(input$table01_rows_all == clickId) %/% input$table01_state$length + 1)
  })
}

##############################################################################
shinyApp(ui = ui, server = server)
##############################################################################

Any suggestions?

回答1:

Yes, that is possible. You can get the selected row form the datatable with input$x_rows_selected where x is the datatable name. We can then use the leafletProxy to remove the old marker and add a new one. I also created a reactiveVal that keeps track of the previously marked row, and reset the marker for that element when a new one is clicked. If you want to keep previously selected markers red as well, simply remove the reactiveVal prev_row() and remove the second part of the observeEvent. Below is a working example.

Note that I added a head(25) in the qSub() reactive to limit the number of rows for illustration purposes.

Hope this helps!

---

---

    ##############################################################################
# Libraries
##############################################################################
library(shiny)
library(shinythemes)
library(ggplot2)
library(plotly)
library(leaflet)
library(DT)
##############################################################################
# Data
##############################################################################
qDat <- quakes
qDat$id <- seq.int(nrow(qDat))
str(qDat)
##############################################################################
# UI Side
##############################################################################
ui <- fluidPage(
  titlePanel("Visualization of Fiji Earthquake"),

  # side panel
  sidebarPanel(
    h3('Fiji Earthquake Data'),

    sliderInput(
      inputId = "sld01_Mag",
      label="Show earthquakes of magnitude:", 
      min=min(qDat$mag), max=max(qDat$mag),
      value=c(min(qDat$mag),max(qDat$mag)), step=0.1
    ),

    plotlyOutput('hist01')
  ),

  # main panel
  mainPanel(
    leafletOutput('map01'),
    dataTableOutput('table01')
  )

)
##############################################################################
# Server Side
##############################################################################
server <- function(input,output){
  qSub <-  reactive({

    subset <- subset(qDat, qDat$mag>=input$sld01_Mag[1] &
                       qDat$mag<=input$sld01_Mag[2]) %>% head(25)
  })

  # histogram
  output$hist01 <- renderPlotly({
    ggplot(data=qSub(), aes(x=stations)) + 
      geom_histogram(binwidth=5) +
      xlab('Number of Reporting Stations') +
      ylab('Count') +
      xlim(min(qDat$stations), max(qDat$stations))+
      ggtitle('Fiji Earthquake')
  })

  # table
  output$table01 <- renderDataTable({

    DT::datatable(qSub(), selection = "single",options=list(stateSave = TRUE))
  })

  # to keep track of previously selected row
  prev_row <- reactiveVal()

  # new icon style
  my_icon = makeAwesomeIcon(icon = 'flag', markerColor = 'red', iconColor = 'white')

  observeEvent(input$table01_rows_selected, {
    row_selected = qSub()[input$table01_rows_selected,]
    proxy <- leafletProxy('map01')
    print(row_selected)
    proxy %>%
      addAwesomeMarkers(popup=as.character(row_selected$mag),
                        layerId = as.character(row_selected$id),
                        lng=row_selected$long, 
                        lat=row_selected$lat,
                        icon = my_icon)

    # Reset previously selected marker
    if(!is.null(prev_row()))
    {
      proxy %>%
        addMarkers(popup=as.character(prev_row()$mag), 
                   layerId = as.character(prev_row()$id),
                   lng=prev_row()$long, 
                   lat=prev_row()$lat)
    }
    # set new value to reactiveVal 
    prev_row(row_selected)
  })

  # map
  output$map01 <- renderLeaflet({
    pal <- colorNumeric("YlOrRd", domain=c(min(quakes$mag), max(quakes$mag)))
    qMap <- leaflet(data = qSub()) %>% 
      addTiles() %>%
      addMarkers(popup=~as.character(mag), layerId = as.character(qSub()$id)) %>%
      addLegend("bottomright", pal = pal, values = ~mag,
                title = "Earthquake Magnitude",
                opacity = 1)
    qMap
  })

  observeEvent(input$map01_marker_click, {
    clickId <- input$map01_marker_click$id
    dataTableProxy("table01") %>%
      selectRows(which(qSub()$id == clickId)) %>%
      selectPage(which(input$table01_rows_all == clickId) %/% input$table01_state$length + 1)
  })
}

##############################################################################
shinyApp(ui = ui, server = server)
##############################################################################

来源：https://stackoverflow.com/questions/48781380/shiny-how-to-highlight-an-object-on-a-leaflet-map-when-selecting-a-record-in-a