10

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

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

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

有什么建议么？

4

1 回答 1

15

是的，这是可能的。您可以从名称所在datatable的位置获取选定的行。然后，我们可以使用删除旧标记并添加一个新标记。我还创建了一个跟踪先前标记的行，并在单击新元素时重置该元素的标记。如果您还想保持以前选择的标记为红色，只需删除并删除下面的第二部分是一个工作示例。input$x_rows_selectedxdatatableleafletProxyreactiveValreactiveVal 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)
##############################################################################
于 2018-02-14T07:30:52.243 回答