r - 使用调色板导出传单
问题描述
我正在从 Shiny 应用程序中导出传单地图。一切正常,直到我想为我的颜色编码点添加一个图例(基于一个变量)。颜色编码工作正常,添加通常的图例leafletProxy
工作正常,但要让导出工作,我需要使用自定义函数来创建地图,当我使用我通常addLegend
的颜色时,这似乎会中断调色板。
任何意见,将不胜感激!
library(viridisLite)
library(shiny)
library(dplyr)
library(leaflet)
library(mapview)
library(ggplot2)
df <- structure(list(Lon = c(-105.618, -105.505, -105.671, -105.737, -105.318, -105.747, -105.693, -105.126, -104.975, -105.297), Lat = c(23.851, 23.646, 24.085, 24.063, 23.378, 24.253, 23.965,
23.153, 23.127, 23.33), Size = c(4, 1, 4, 4, 2, 3, 4, 1, 1, 3)), row.names = c(NA, -10L), class = c("tbl_df", "tbl", "data.frame"))
ui <- navbarPage("My app", id = "nav",
fluidRow(column(width = 8,
leafletOutput("map", height = "800px")),
column(width = 4,
downloadButton('ExportMap', label = "Download the map"))))
myfun <- function(map, df.in, colorAdditions, labelAdditions, pal){
clearShapes(map) %>%
clearMarkers() %>%
clearControls() %>%
addCircleMarkers(data = df.in, lng = df.in$Lon, lat = df.in$Lat, color = pal(df.in$Size), radius = ~Size * 3) %>%
###### this line breaks the app #######
#addLegend(position = "topleft", pal = pal, values = ~df.in$Size) %>%
addLegend(title = "Number of tag days<br/>per location", colors = colorAdditions,
labels = labelAdditions, opacity = 0.6, position = "topleft")
}
server <- function(input, output, session){
mymap <- reactive({
leaflet(df, options = leafletOptions(
attributionControl=FALSE)) %>%
setView(lng = -105.5, lat = 23.7, zoom = 8) %>%
addProviderTiles("Esri.WorldImagery", layerId = "basetile",
options = providerTileOptions(minZoom = 7, opacity = 0.75))
})
output$map <- renderLeaflet({
mymap()
})
observe({
pal <- colorNumeric(palette = viridis(100), domain = range(df$Size))
labels <- sort(unique(df$Size))
sizes <- 1:length(labels) * 5
colors <- rep("lightblue", length(labels))
colorAdditions <- paste0(colors, "; border-radius: 50%; width:", sizes, "px; height:", sizes, "px")
labelAdditions <- paste0("<div style='display: inline-block;height: ", sizes, "px;margin-left: 4px;line-height: ", sizes, "px;'>", labels, "</div>")
leafletProxy("map") %>% myfun(df, colorAdditions = colorAdditions, labelAdditions = labelAdditions, pal = pal)
})
# map that will be downloaded
mapdown <- reactive({
pal <- colorNumeric(palette = viridis(100), domain = range(df$Size))
labels <- sort(unique(df$Size))
sizes <- 1:length(labels) * 5
colors <- rep("lightblue", length(labels))
colorAdditions <- paste0(colors, "; border-radius: 50%; width:", sizes, "px; height:", sizes, "px")
labelAdditions <- paste0("<div style='display: inline-block;height: ", sizes, "px;margin-left: 4px;line-height: ", sizes, "px;'>", labels, "</div>")
mymap() %>% myfun(df, colorAdditions = colorAdditions, labelAdditions = labelAdditions, pal = pal)
})
output$ExportMap <- downloadHandler(
filename = 'mymap.png',
content = function(file) {
owd <- setwd(tempdir())
on.exit(setwd(owd))
mapshot(mapdown(), file = file, cliprect = "viewport", vwidth= 800, vheight = 600)
})
}
shinyApp(ui = ui, server = server)
解决方案
显然它只需要从=~df.in$Size
到的小调整=df.in$Size
。现在可以绘制和下载。
library(viridisLite)
library(shiny)
library(dplyr)
library(leaflet)
library(mapview)
library(ggplot2)
df <- structure(list(Lon = c(-105.618, -105.505, -105.671, -105.737, -105.318, -105.747, -105.693, -105.126, -104.975, -105.297), Lat = c(23.851, 23.646, 24.085, 24.063, 23.378, 24.253, 23.965,
23.153, 23.127, 23.33), Size = c(4, 1, 4, 4, 2, 3, 4, 1, 1, 3)), row.names = c(NA, -10L), class = c("tbl_df", "tbl", "data.frame"))
ui <- navbarPage("My app", id = "nav",
fluidRow(column(width = 8,
leafletOutput("map", height = "800px")),
column(width = 4,
downloadButton('ExportMap', label = "Download the map"))))
myfun <- function(map, df.in, colorAdditions, labelAdditions, pal){
clearShapes(map) %>%
clearMarkers() %>%
clearControls() %>%
addCircleMarkers(data = df.in, lng = df.in$Lon, lat = df.in$Lat, color = pal(df.in$Size), radius = ~Size * 3) %>%
###### this line breaks the app #######
addLegend(position = "topleft", pal = pal, values = df.in$Size) %>%
addLegend(title = "Number of tag days<br/>per location", colors = colorAdditions,
labels = labelAdditions, opacity = 0.6, position = "topleft")
}
server <- function(input, output, session){
mymap <- reactive({
leaflet(df, options = leafletOptions(
attributionControl=FALSE)) %>%
setView(lng = -105.5, lat = 23.7, zoom = 8) %>%
addProviderTiles("Esri.WorldImagery", layerId = "basetile",
options = providerTileOptions(minZoom = 7, opacity = 0.75))
})
output$map <- renderLeaflet({
mymap()
})
observe({
pal <- colorNumeric(palette = viridis(100), domain = range(df$Size))
labels <- sort(unique(df$Size))
sizes <- 1:length(labels) * 5
colors <- rep("lightblue", length(labels))
colorAdditions <- paste0(colors, "; border-radius: 50%; width:", sizes, "px; height:", sizes, "px")
labelAdditions <- paste0("<div style='display: inline-block;height: ", sizes, "px;margin-left: 4px;line-height: ", sizes, "px;'>", labels, "</div>")
leafletProxy("map") %>% myfun(df, colorAdditions = colorAdditions, labelAdditions = labelAdditions, pal = pal)
})
# map that will be downloaded
mapdown <- reactive({
pal <- colorNumeric(palette = viridis(100), domain = range(df$Size))
labels <- sort(unique(df$Size))
sizes <- 1:length(labels) * 5
colors <- rep("lightblue", length(labels))
colorAdditions <- paste0(colors, "; border-radius: 50%; width:", sizes, "px; height:", sizes, "px")
labelAdditions <- paste0("<div style='display: inline-block;height: ", sizes, "px;margin-left: 4px;line-height: ", sizes, "px;'>", labels, "</div>")
mymap() %>% myfun(df, colorAdditions = colorAdditions, labelAdditions = labelAdditions, pal = pal)
})
output$ExportMap <- downloadHandler(
filename = 'mymap.png',
content = function(file) {
owd <- setwd(tempdir())
on.exit(setwd(owd))
mapshot(mapdown(), file = file, cliprect = "viewport", vwidth= 800, vheight = 600)
})
}
shinyApp(ui = ui, server = server)
推荐阅读
- angular - 每当关闭浏览器选项卡/窗口时,Angular 应用程序变得不可用
- select - 在 DB2 中为 type1 或 type2 选择前 5 行
- sbt - 当构建插件的 Git 存储库无法下载时,SBT 会静默终止
- laravel - 在 laravel 中实时处理
- javascript - 从 URL 字符串获取常量变量
- xml - Odoo 10 缺少表单视图按钮作为 view_mode 虽然它是
- javascript - Dynamics CRM 已读/未读表单
- php - Laravel Eloquent 3 表连接查询
- javascript - 如何将过滤器应用于 JavaScript 中的 JSON 数组?
- ruby-on-rails - ActiveJobs 方法是实例方法还是类方法?