gpt4 book ai didi

r - Shiny - 在数据表中选择记录时如何突出显示传单 map 上的对象?

转载 作者:行者123 更新时间:2023-12-01 17:33:25 24 4
gpt4 key购买 nike

当选择(单击)数据表中的相应记录时,是否可以突出显示传单 map 上的标记或多段线?

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

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

https://github.com/r-spatial/mapedit/issues/56 - 检查timeportfolio于2017年7月23日的评论。正如gif所示,我希望能够在数据表中选择一行,以便相应的 map 对象(标记/折线)也突出显示(无需编辑 map ) )。

这是一个工作示例,其中在下面的数据表中选择突出显示的 map 对象,但反之则不然 - 这就是我想要实现的目标。

##############################################################################
# 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_selecteddatatable 获取所选行,其中 xdatatable 名称。然后,我们可以使用 leafletProxy 删除旧标记并添加新标记。我还创建了一个 reactiveVal 来跟踪先前标记的行,并在单击新元素时重置该元素的标记。如果您还想将之前选择的标记保持为红色,只需删除 reactiveVal prev_row() 并删除 observeEvent 的第二部分。是一个工作示例。

请注意,出于说明目的,我在 qSub() 响应式(Reactive)中添加了 head(25) 来限制行数。

希望这有帮助!

<小时/>

enter image description here

<小时/>
    ##############################################################################
# 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)
##############################################################################

关于r - Shiny - 在数据表中选择记录时如何突出显示传单 map 上的对象?,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/48781380/

24 4 0
Copyright 2021 - 2024 cfsdn All Rights Reserved 蜀ICP备2022000587号
广告合作:1813099741@qq.com 6ren.com