闪亮 - 在数据表中选择记录时如何突出显示传单地图上的对象? [英] Shiny - how to highlight an object on a leaflet map when selecting a record in a datatable?
本文介绍了闪亮 - 在数据表中选择记录时如何突出显示传单地图上的对象?的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
在选择(单击)数据表中的相应记录时，是否可以突出显示传单地图上的标记或折线?
我查看了这些问题/线程:
<小时> ############################################################################### 库#############################################################################图书馆(闪亮)图书馆(闪亮的主题)图书馆(ggplot2)图书馆(情节)图书馆(传单)图书馆(DT)############################################################################## 数据#############################################################################qDat <- 地震qDat$id <- seq.int(nrow(qDat))字符串(qDat)############################################################################## 界面端#############################################################################ui <-流体页面(titlePanel("斐济地震的可视化"),# 侧面板侧边栏面板(h3('斐济地震数据'),滑块输入(inputId = "sld01_Mag",label="显示震级:",min=min(qDat$mag), max=max(qDat$mag),值=c(min(qDat$mag),max(qDat$mag)), step=0.1),情节输出('hist01')),# 主面板主面板(传单输出('map01')，数据表输出('table01')))############################################################################## 服务器端#############################################################################服务器 <- 功能(输入，输出){qSub <- 反应式({子集 <- 子集(qDat, qDat$mag>=input$sld01_Mag[1] &qDat$mag<=input$sld01_Mag[2]) %>% head(25)})# 直方图输出$hist01 <- renderPlotly({ggplot(数据=qSub()，aes(x=站))+geom_histogram(binwidth=5) +xlab('报告站数') +ylab('计数') +xlim(min(qDat$stations), max(qDat$stations))+ggtitle('斐济地震')})# 桌子output$table01 <- renderDataTable({DT::datatable(qSub(), selection = "single",options=list(stateSave = TRUE))})# 跟踪先前选择的行prev_row <-reactiveVal()# 新的图标样式my_icon = makeAwesomeIcon(icon = 'flag', markerColor = 'red', iconColor = 'white')观察事件(输入$table01_rows_selected，{row_selected = qSub()[输入$table01_rows_selected,]代理 <- LeafletProxy('map01')打印(row_selected)代理 %>%addAwesomeMarkers(popup=as.character(row_selected$mag),layerId = as.character(row_selected$id),lng=row_selected$long,lat=row_selected$lat,图标 = 我的图标)# 重置之前选择的标记if(!is.null(prev_row())){代理 %>%addMarkers(popup=as.character(prev_row()$mag),layerId = as.character(prev_row()$id),lng=prev_row()$long,lat=prev_row()$lat)}# 为 reactiveVal 设置新值prev_row(row_selected)})# 地图output$map01 <- renderLeaflet({pal <- colorNumeric("YlOrRd", domain=c(min(quakes$mag), max(quakes$mag)))qMap <- 传单(数据 = qSub()) %>%addTiles() %>%addMarkers(popup=~as.character(mag), layerId = as.character(qSub()$id)) %>%addLegend("bottomright", pal = pal, values = ~mag,title = "地震震级",不透明度 = 1)qMap})观察事件(输入$map01_marker_click，{clickId <- 输入$map01_marker_click$id数据表代理(table01")%>%selectRows(which(qSub()$id == clickId)) %>%selectPage(which(input$table01_rows_all == clickId) %/% input$table01_state$length + 1)})}#############################################################################闪亮应用(用户界面 = 用户界面，服务器 = 服务器)#############################################################################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:
selecting a marker on leaflet, from a DT row click and vice versa - no answer
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)
##############################################################################
Any suggestions?
解决方案
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.
Note that I added a head(25) in the qSub() reactive to limit the number of rows for illustration purposes.
Hope this helps!
##############################################################################
# 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屋！
查看全文
