闪亮-在数据表中选择记录时，如何在传单地图上突出显示对象？

Question

在选择（单击）数据表中的相应记录时，是否可以在传单地图上突出显示标记或折线？

我看了这些问题/线索：

从DT行中选择传单上的标记，然后单击，反之亦然 -无答案

https://github.com/r-spatial/mapedit/issues/56- 检查及时投资组合在2017年7月23日的评论。如gif所示，我希望能够在数据表中选择一行，以便相应的地图对象（标记/折线）也将突出显示（无需编辑地图）。

这是一个工作示例，其中在下面的数据表中选择了高亮显示的地图对象，但反之则不然，这就是我要实现的目标。

##############################################################################
# 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)
##############################################################################

有什么建议么？

Answer 1

是的，那是可能的。你可以得到选中行的形式datatable与input$x_rows_selected地方x是datatable名字。然后，我们可以使用leafletProxy删除旧标记并添加一个新标记。我还创建了一个reactiveVal跟踪先前标记的行，并在单击一个新行时重置该元素的标记。如果您还想使先前选择的标记也保持红色，只需删除reactiveVal prev_row()并删除“ observeEvent.下面是工作示例” 的第二部分。

请注意，为说明起见，我head(25)在qSub()反应式中添加了a 以限制行数。

希望这可以帮助！

    ##############################################################################
# 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)
##############################################################################