导出带有调色板的传单

Question

我正在从 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)

Answer 1

显然它只需要从

=~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)