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

Posted 2023-02-14

【中文标题】闪亮 - 在数据表中选择记录时如何突出显示传单地图上的对象？

【英文标题】：Shiny - how to highlight an object on a leaflet map when selecting a record in a datatable?

【发布时间】：2018-07-24 16:24:06

【问题描述】：

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

我查看了这些问题/线程：

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

有什么建议吗？

【参考方案1】：

是的，这是可能的。您可以从datatable 和input$x_rows_selected 中获取选定的行，其中x 是datatable 名称。然后我们可以使用leafletProxy 删除旧标记并添加一个新标记。我还创建了一个reactiveVal 来跟踪先前标记的行，并在单击新元素时重置该元素的标记。如果您还想保持之前选择的标记为红色，只需删除 reactiveVal prev_row() 并删除 observeEvent. 的第二部分下面是一个工作示例。

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

希望这会有所帮助！

---

---

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

【讨论】：

这很有帮助！谢谢你。有没有办法突出标记而不是在顶部绘制另一个标记？我假设当我突出显示一个标记时，在 DT 中突出显示一行而不是添加一个新行。

另一个问题，是否可以对折线做同样的事情？在我的实际应用程序中，我有由折线连接的标记。理想情况下，我想选择一个 DT 行，并且两个端点和连接的折线都会在地图上突出显示。

@M_M 据我所知，没有（简单的）方法可以更改已放置标记的颜色。当您在 DT 中选择一行时，您不会向 DT 添加新行，您只是向地图添加一个标记。对于折线，也许我的回答 here 可以帮助您朝着正确的方向前进。

我删除了removeMarker() 语句。这些都是多余的，因为添加具有相同 layerId 的新标记将删除旧图层。

再次感谢 - 我会查看您为折线发送的链接。是否可以启用双击以取消选择标记/行？并且只能通过表格而不是通过单击地图上的标记进行选择吗？