How to print the current map while preserving data points
Two fold question: How can I avoid losing my data points while attempting to save a map with the downloadHandler shiny control? And I have 4 tiles to select from but it defaults to the first one all the time. How can I tell leaflet inside the create_current_map() function to save the type of map that is being displayed on the mainPanel? Reproducible example below:
library(shiny)
library(leaflet)
library(webshot2)
library(htmlwidgets)
library(mapview)
mapviewOptions(basemaps = c("Esri.WorldStreetMap","Esri.WorldTopoMap","Esri.NatGeoWorldMap","USGS.USImageryTopo"),
raster.palette = grey.colors,
vector.palette = colorRampPalette(c("snow", "cornflowerblue", "grey10")),
na.color = "magenta",
layers.control.pos = "topright")
dat <- structure(list(SampleDate = structure(c(18977, 18978, 18978,
18978, 18978, 18978), class = "Date"), Survey = c("USFWS EDSM",
"USFWS EDSM", "USFWS EDSM", "USFWS EDSM", "USFWS EDSM", "USFWS EDSM"
), LifeStage = c("Adult", "Adult", "Adult", "Adult", "Adult",
"Adult"), lat = c(38.11429, 38.15312, 38.15312, 38.14925, 38.14925,
38.14133), lon = c(-121.6875, -121.68261, -121.68261, -121.68401,
-121.68401, -121.69331), ReleaseEvent = c("BY2021 1", "BY2021 1",
"BY2021 1", "BY2021 1", "BY2021 1", "BY2021 1"), ReleaseMethod = c("Unknown",
"Unknown", "Unknown", "Unknown", "Unknown", "Unknown"), Origin = c("hatchery",
"wild", "wildAdult", "hatchery", "hatchery", "hatchery"), numb_fish = c(1,
1, 1, 1, 1, 1), year = c(2021, 2021, 2021, 2021, 2021, 2021),
month = structure(c(18962, 18962, 18962, 18962, 18962, 18962
), class = "Date"), geometry = structure(list(structure(c(-121.6875,
38.11429), class = c("XY", "POINT", "sfg")), structure(c(-121.68261,
38.15312), class = c("XY", "POINT", "sfg")), structure(c(-121.68261,
38.15312), class = c("XY", "POINT", "sfg")), structure(c(-121.68401,
38.14925), class = c("XY", "POINT", "sfg")), structure(c(-121.68401,
38.14925), class = c("XY", "POINT", "sfg")), structure(c(-121.69331,
38.14133), class = c("XY", "POINT", "sfg"))), class = c("sfc_POINT",
"sfc"), precision = 0, bbox = structure(c(xmin = -121.69331,
ymin = 38.11429, xmax = -121.68261, ymax = 38.15312), class = "bbox"), crs = structure(list(
input = "EPSG:4326", wkt = "GEOGCRS[\"WGS 84\",\n ENSEMBLE[\"World Geodetic System 1984 ensemble\",\n
MEMBER[\"World Geodetic System 1984 (Transit)\"],\n MEMBER[\"World Geodetic System 1984 (G730)\"],\n
MEMBER[\"World Geodetic System 1984 (G873)\"],\n MEMBER[\"World Geodetic System 1984 (G1150)\"],\n
MEMBER[\"World Geodetic System 1984 (G1674)\"],\n MEMBER[\"World Geodetic System 1984 (G1762)\"],\n
MEMBER[\"World Geodetic System 1984 (G2139)\"],\n ELLIPSOID[\"WGS 84\",6378137,298.257223563,\n
LENGTHUNIT[\"metre\",1]],\n ENSEMBLEACCURACY[2.0]],\n PRIMEM[\"Greenwich\",0,\n
ANGLEUNIT[\"degree\",0.0174532925199433]],\n CS[ellipsoidal,2],\n
AXIS[\"geodetic latitude (Lat)\",north,\n ORDER[1],\n
ANGLEUNIT[\"degree\",0.0174532925199433]],\n AXIS[\"geodetic longitude (Lon)\",east,\n
ORDER[2],\n ANGLEUNIT[\"degree\",0.0174532925199433]],\n USAGE[\n
SCOPE[\"Horizontal component of 3D system.\"],\n AREA[\"World.\"],\n
BBOX[-90,-180,90,180]],\n ID[\"EPSG\",4326]]"), class = "crs"), n_empty = 0L)), row.names = c(NA,
-6L), sf_column = "geometry", agr = structure(c(SampleDate = NA_integer_,
Survey = NA_integer_, LifeStage = NA_integer_, lat = NA_integer_,
lon = NA_integer_, ReleaseEvent = NA_integer_, ReleaseMethod = NA_integer_,
Origin = NA_integer_, numb_fish = NA_integer_, year = NA_integer_,
month = NA_integer_), levels = c("constant", "aggregate", "identity"
), class = "factor"), class = c("sf", "tbl_df", "tbl", "data.frame"
))
mapview(dat)
ui <- fluidPage(
titlePanel("Download Leaflet/Mapview"),
sidebarLayout(
sidebarPanel(
downloadButton("Download_map", "Download Map"),
radioButtons(inputId = "format", label = "Map format:", choices = list("png", "pdf"))
),
mainPanel(
leafletOutput("map")
)
)
)
server <- function(input, output, session) {
session$onSessionEnded(function() {
stopApp()
})
output$map <- renderLeaflet({
##I want to preserve the datapoints displayed here when saving my map
finalmap <- mapview(dat, zcol = "LifeStage", col.regions = colors, layer.name = "LifeStage", alpha = 0.2, cex = 4)
finalmap@map
})
# create map with current view
create_current_map <- function() {
bounds <- input$map_bounds
zoom <- input$map_zoom
center <- input$map_center
if (is.null(bounds) || is.null(zoom) || is.null(center)) {
lng <- -121.94192
lat <- 38.06202
zoom_level <- 10
} else {
lng <- center$lng
lat <- center$lat
zoom_level <- zoom
}
x <- mapview(dat)
x@map %>%
setView(lng = lng, lat = lat, zoom = zoom_level)
}
output$Download_map <- downloadHandler(
filename = function() {
paste("myMAP",input$format,sep = ".")
},
content = function(file) {
if (input$format == "png") {
mapview::mapshot(create_current_map(), file = file) # Open PNG device
} else if (input$format == "pdf") {
mapview::mapshot(create_current_map(), file = file) # Open PDF device
}
}
)
}
# Run the application
shinyApp(ui = ui, server = server)
Solution
How about a full JavaScript solution? Here I used Dom-to-image + jsPDF courtesey to @Smartse's idea using this. This gives you two buttons to save to PNG or PDF respectively. Dom-to-image captures the leaflet-container DOM element as image. Note: From my experience with UI, it's always good to reduce the amount of clicks needed if possible, so I created two buttons for each task, instead of using a dropdown for the format + button to download which would require two clicks, but I know this is up to preference and task-dependend.
Edit 1:
I added a function that hides the DOM-elements with class = .leaflet-control-layers-toggle and .leaflet-control-zoom before capturing, removing them from the image.
library(shiny)
library(leaflet)
library(htmlwidgets)
library(mapview)
mapviewOptions(basemaps = c("Esri.WorldStreetMap","Esri.WorldTopoMap","Esri.NatGeoWorldMap","USGS.USImageryTopo"),
raster.palette = grey.colors,
vector.palette = colorRampPalette(c("snow", "cornflowerblue", "grey10")),
na.color = "magenta",
layers.control.pos = "topright")
dat <- structure(list(SampleDate = structure(c(18977, 18978, 18978,
18978, 18978, 18978), class = "Date"), Survey = c("USFWS EDSM",
"USFWS EDSM", "USFWS EDSM", "USFWS EDSM", "USFWS EDSM", "USFWS EDSM"
), LifeStage = c("Adult", "Adult", "Adult", "Adult", "Adult",
"Adult"), lat = c(38.11429, 38.15312, 38.15312, 38.14925, 38.14925,
38.14133), lon = c(-121.6875, -121.68261, -121.68261, -121.68401,
-121.68401, -121.69331), ReleaseEvent = c("BY2021 1", "BY2021 1",
"BY2021 1", "BY2021 1", "BY2021 1", "BY2021 1"), ReleaseMethod = c("Unknown",
"Unknown", "Unknown", "Unknown", "Unknown", "Unknown"), Origin = c("hatchery",
"wild", "wildAdult", "hatchery", "hatchery", "hatchery"), numb_fish = c(1,
1, 1, 1, 1, 1), year = c(2021, 2021, 2021, 2021, 2021, 2021),
month = structure(c(18962, 18962, 18962, 18962, 18962, 18962
), class = "Date"), geometry = structure(list(structure(c(-121.6875,
38.11429), class = c("XY", "POINT", "sfg")), structure(c(-121.68261,
38.15312), class = c("XY", "POINT", "sfg")), structure(c(-121.68261,
38.15312), class = c("XY", "POINT", "sfg")), structure(c(-121.68401,
38.14925), class = c("XY", "POINT", "sfg")), structure(c(-121.68401,
38.14925), class = c("XY", "POINT", "sfg")), structure(c(-121.69331,
38.14133), class = c("XY", "POINT", "sfg"))), class = c("sfc_POINT",
"sfc"), precision = 0, bbox = structure(c(xmin = -121.69331,
ymin = 38.11429, xmax = -121.68261, ymax = 38.15312), class = "bbox"), crs = structure(list(
input = "EPSG:4326", wkt = "GEOGCRS[\"WGS 84\",\n ENSEMBLE[\"World Geodetic System 1984 ensemble\",\n
MEMBER[\"World Geodetic System 1984 (Transit)\"],\n MEMBER[\"World Geodetic System 1984 (G730)\"],\n
MEMBER[\"World Geodetic System 1984 (G873)\"],\n MEMBER[\"World Geodetic System 1984 (G1150)\"],\n
MEMBER[\"World Geodetic System 1984 (G1674)\"],\n MEMBER[\"World Geodetic System 1984 (G1762)\"],\n
MEMBER[\"World Geodetic System 1984 (G2139)\"],\n ELLIPSOID[\"WGS 84\",6378137,298.257223563,\n
LENGTHUNIT[\"metre\",1]],\n ENSEMBLEACCURACY[2.0]],\n PRIMEM[\"Greenwich\",0,\n
ANGLEUNIT[\"degree\",0.0174532925199433]],\n CS[ellipsoidal,2],\n
AXIS[\"geodetic latitude (Lat)\",north,\n ORDER[1],\n
ANGLEUNIT[\"degree\",0.0174532925199433]],\n AXIS[\"geodetic longitude (Lon)\",east,\n
ORDER[2],\n ANGLEUNIT[\"degree\",0.0174532925199433]],\n USAGE[\n
SCOPE[\"Horizontal component of 3D system.\"],\n AREA[\"World.\"],\n
BBOX[-90,-180,90,180]],\n ID[\"EPSG\",4326]]"), class = "crs"), n_empty = 0L)), row.names = c(NA,
-6L), sf_column = "geometry", agr = structure(c(SampleDate = NA_integer_,
Survey = NA_integer_, LifeStage = NA_integer_, lat = NA_integer_,
lon = NA_integer_, ReleaseEvent = NA_integer_, ReleaseMethod = NA_integer_,
Origin = NA_integer_, numb_fish = NA_integer_, year = NA_integer_,
month = NA_integer_), levels = c("constant", "aggregate", "identity"
), class = "factor"), class = c("sf", "tbl_df", "tbl", "data.frame"
))
ui <- fluidPage(
titlePanel("Download Leaflet/Mapview"),
tags$head(
tags$script(src = r'{https://cdnjs.cloudflare.com/ajax/libs/dom-to-image/2.6.0/dom-to-image.min.js}'), # for saving dom 2 image
tags$script(src = r'{https://cdnjs.cloudflare.com/ajax/libs/FileSaver.js/2.0.5/FileSaver.min.js}'), # for saving to png
tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/jspdf/1.5.3/jspdf.min.js"), # for pdf
),
mainPanel(
leafletOutput("map"),
actionButton("png_btn", "Download Map as PNG"),
actionButton("pdf_btn", "Download Map as PDF")
)
)
server <- function(input, output, session) {
session$onSessionEnded(function() {
stopApp()
})
output$map <- renderLeaflet({
finalmap <- mapview(dat, zcol = "LifeStage", col.regions = colors, layer.name = "LifeStage", alpha = 0.2, cex = 4)
finalmap@map |>
htmlwidgets::onRender("
function(el, x) {
var map = this;
// show or hide layer controlls + zoom controls
function showControlls(visible) {
let style = visible ? '' : 'none';
const layersToggle = document.querySelector('.leaflet-control-layers-toggle');
const zoomControl = document.querySelector('.leaflet-control-zoom');
if (layersToggle) layersToggle.style.display = style;
if (zoomControl) zoomControl.style.display = style;
}
// Listen for the png button
document.getElementById('png_btn').onclick = async function() {
try {
var dimensions = map.getSize();
var width = dimensions.x;
var height = dimensions.y;
showControlls(false);
const mapContainer = document.querySelector('.leaflet-container');
const blob = await domtoimage.toBlob(mapContainer, { width: width, height: height });
saveAs(blob, 'myMap.png');
showControlls(true);
} catch (error) {
console.error('Error generating image:', error);
}
};
// Listen for the pdf button
document.getElementById('pdf_btn').onclick = async function() {
try {
var dimensions = map.getSize();
var width = dimensions.x;
var height = dimensions.y;
showControlls(false);
const mapContainer = document.querySelector('.leaflet-container');
domtoimage.toPng(mapContainer)
.then(function (dataUrl) {
showControlls(true);
// Create A4 page
var pdf = new jsPDF('p', 'pt', [842, 595]);
// Add leaflet image with width of 500 points
pdf.addImage(dataUrl, 'PNG', 70, 47.5, 500, height/width * 500);
pdf.save('myMap.pdf');
})
.catch(function (error) {
console.error('Error generating pdf:', error);
showControlls(true);
});
} catch (error) {
console.error('Error generating pdf:', error);
}
};
}
")
})
}
# Run the application
shinyApp(ui = ui, server = server)
- Simple question: how to add text to r chunk in rmd format?
- Issue with Label Behaviour in gganimate
- Combine census tracts with neighbor to reach a population threshold in R
- Creating a single map composed of three separate shapefiles
- Implementation of Cobb-Douglas Utility Function to calculate Receiver Operator Curve & AUC
- Overall percentages based on total count
- Pairwise dissimilarities nesting a time-series loop inside a site loop - multiple times
- Long/Lat points keep ending up in Kansas
- How to sum a column dependent on a value in another column
- Customize label for an Interaction Plot
- How to obtain RMSE out of lm result?
- Faceted mosaic plots with the same area scaling
- Unite columns with unique values
- How to print the current map while preserving data points
- How to solve error: mismatched lengths of ids and values when data has missing values in geom_line_interactive()?
- How do I transfer NAs from one dataframe to same position in a second dataframe
- Creating bar plots using ggplot, running into issues with data format
- Force initial zoom to truncate portion of the data
- R - select only factor columns of dataframe
- How to scale the units of the data & trend components of an autoplot of a multiplicative decomposition of a time series?
- Respect ratio when using ggarrange() and geom_sf()
- Changing size / aspect ratio of leaflet
- How do I use the lubridate package to calculate the number of months between two date vectors where one of the vectors has NA values?
- Adding to logos to flexdashboard
- R replace values of a column based on exact match of another data frame
- Error in grepl(pattern, df): invalid regular expression
- regular expression in R, reuse matched string in replacement
- Substract minimum value of row from each element of row in dataframe,
- R Reticulate does work with for loop but not purrr::map2
- Count all values in a correlation matrix that are above 0.8 and below -0.8