闪亮-在数据表中选择记录时，如何在传单地图上突出显示对象? [英] 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:
https://github.com/r-spatial/mapedit/issues/56 -检查及时投资组合在2017年7月23日的评论.如gif所示，我希望能够在数据表中选择一行，以便相应的地图对象(标记/折线)也被突出显示(无需编辑地图.
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)
##############################################################################
有什么建议吗?
推荐答案
是的，这是可能的.您可以使用input$x_rows_selected从datatable获取所选行，其中x是datatable名称.然后，我们可以使用leafletProxy删除旧标记并添加一个新标记.我还创建了reactiveVal来跟踪先前标记的行，并在单击新的行时重置该元素的标记.如果您还想使先前选择的标记也保持红色，只需删除reactiveVal prev_row()并删除observeEvent.的第二部分.下面是一个有效的示例.
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.
请注意，出于说明目的，我在qSub()反应堆中添加了head(25)以限制行数.
Note that I added a head(25) in the qSub() reactive to limit the number of rows for illustration purposes.
希望这会有所帮助！
##############################################################################
# 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)
##############################################################################
这篇关于闪亮-在数据表中选择记录时，如何在传单地图上突出显示对象?的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
