Я пытаюсь создать листовую карту, которая добавляет и удаляет слой многоугольника (SpatialDataFrame) на основе изменения пользовательского ввода в приложении Shiny на Flexdashboard. Геометрия многоугольников (4201 многоугольника) остается постоянной, но по мере того, как пользователь вносит изменения во входные данные, набор данных (всего 2100500 записей), который объединяется с каждым многоугольником, изменяется (до = 4201 для объединения с многоугольниками).
Я следил за документацией Leaflet R здесь https://rstudio.github.io/leaflet/shiny.html
И мой пример кода ниже, похоже, имитирует событие наблюдаю (), рекомендую обернуть вокруг addPolygons (). Я также посмотрел исходный код из ряда похожих приложений Shiny на блестящей странице галереи (в частности, это: https://walkerke.shinyapps.io/neighborhood_diversity/), но, похоже, он не работает
Вот примерприложения, обратите внимание, что данные слишком велики для загрузки, но смотрите комментарии. Когда я создаю addPolygons () в первом вызове leaflet (), он работает нормально. Недостатком этого подхода является то, что он вызывает перерисовку всей картыкогда пользовательский ввод изменяется. Следуя инструкциям по листовке, я хочу переместить этот addPolygon в отдельного наблюдателя. Вот где он терпит неудачу.
---
title: "Model Result Viewer"
output:
flexdashboard::flex_dashboard:
orientation: columns
vertical_layout: fill
runtime: shiny
---
```{r setup, include=FALSE}
library(flexdashboard)
library(...)
df <- fread("./data/rca_do_salt_1day.csv")
# get the unique parameters & layers
model_params <- unique(df$Parameter)
model_layers <- unique(df$Cell_K)
# read in the grid
grid <- spTransform(readOGR(dsn="./PVSC06_Grid", layer="PVSC06_WGS84"),
CRS("+proj=longlat +datum=WGS84 +no_defs"))
# Data Controls --------------------------------
<USER INPUTS SIMILAR TO:
# parameter selection
selectInput("param", "Parameter", model_params, selected = model_params[1])
#layer selection
selectInput("lyr", "Layer", model_layers, selected = model_layers[1])
# make the grid dataframe
df_subset <- reactive({
filter(df, Cell_K == input$lyr, Parameter == input$param, Time == input$timeslider)
})
# THIS MAKES THE POLYGONS FOR MAPPING
sp.grid <- reactive({
merge(grid, df_subset(), by.x = "Id", by.y = "Id")
})
# helpers for leaflet
pal <- reactive({
colorNumeric(
palette = input$colors, #"YlOrRd",
domain = df_parameter()$Value
)
})
#Set labels for grid hover
labels <- reactive({
sp.grid()$Value %>% lapply(htmltools::HTML)
})
output$map <- renderLeaflet({
leaflet() %>%
# Base Setup
addTiles(group = "Open Street Map") %>%
addProviderTiles('Esri.WorldImagery', group = "Satellite Imagery") %>%
addDrawToolbar(
targetGroup='Draw',
editOptions = editToolbarOptions(selectedPathOptions = selectedPathOptions())
) %>%
clearShapes() %>%
fitBounds(grid@bbox[1], grid@bbox[2], grid@bbox[3], grid@bbox[4]) %>%
# ================ THIS WORKS HERE, BUT NOT IN AN OBSERVER?!!! =================
# addPolygons(data = sp.grid(),
# layerId = ~Id,
# group= "Grid",
# weight = 0.1,
# opacity = 0,
# fillOpacity = 1,
# stroke = FALSE,
# fillColor = ~pal()(Value),
# highlightOptions = highlightOptions(color = "white",
# weight = 2,
# bringToFront = TRUE),
# label = labels(),
# labelOptions = labelOptions(style = list("font-weight" = "normal", padding = "3px 8px"),
# textsize = "15px",
# direction = "auto")) %>%
# # Legend
# addLegend(position = 'bottomright',
# pal = pal(), opacity = 1,
# values = sp.grid()$Value,
# title = input$param) %>%
#==================================================================================
# TOC Box
addLayersControl(
baseGroups = c("Satellite Imagery", "Open Street Map"),
overlayGroups = c("Grid", "Loads", "Draw"),
options = layersControlOptions(collapsed=TRUE)
)
})
# =============== THIS DOESN"T WORK ======================
observe({
req(sp.grid()) # this alone will cause the error
# why doesn't this work?
leafletProxy('map', data = sp.grid()) %>%
removeShape(~Id) %>%
addPolygons(
layerId = ~Id,
group= "Grid",
weight = 0.1,
opacity = 0,
fillOpacity = 1,
fill = TRUE,
stroke = FALSE,
fillColor = ~pal()(Value),
highlightOptions = highlightOptions(color = "white",
weight = 2,
bringToFront = TRUE),
label = labels(),
labelOptions = labelOptions(style = list("font-weight" = "normal", padding = "3px 8px"),
textsize = "15px",
direction = "auto")
)
})
# === THIS IS JUST EXAMPLE OF Observer that DOES work?!
# Click event for the map (will use to generate chart)
click_element <- eventReactive(input$map_shape_click, {
input$map_shape_click$id
})
# highlight the clicked element
observe({
req(click_element()) # do this if click_element() is not null
# Add the clicked element to the map in aqua, and remove when a new one is clicked
map <- leafletProxy('map') %>%
removeShape('element') %>%
addPolygons(data = sp.grid()[sp.grid()$Id == click_element(), ],
fill = TRUE,
color = '#00ffff', opacity = 1, layerId = 'element')
})
leafletOutput('map')
Когда я запускаю этот код, консоль Rmarkdown выдает ошибку чего-то вродеи сразу же вылетает:
Error in : Result must have length 2100500, not 0
90 <Anonymous>
Обратите внимание, что фактическое число (90) меняется, но обычно оно всегда> 85, и это единственная строка вывода в консоли Rmarkdown.
Примечательно: 2100500это количество записей в моем непространственном фрейме данных (который фильтруется по пользовательским данным и объединяется с пространственным полигоном (4201 полигон).
Следовательно, выглядит , как будто фильтрация не применяется правильно, но почему же это работает, когда я просто перемещаю его в вызов leaflet ()?