Question

当选择（点击）数据表中的相应记录时，有没有办法在传单地图上突出显示标记或折线？

我看了这些问题/主题：

selecting a marker on leaflet, from a DT row click and vice versa - 没有回答

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()以限制行数以用于说明目的。

希望这有帮助！

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

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

1 个答案: