I'm building a leaflet map on R having multiple layers that are controlled by addLayersControl. Every layer as the same spatial information, so only the data associated to each polylines changes. The idea is to have a basic map, where the user decide which data field is display. I succeeded at making the map, however I noticed that the size of the html file produced is huge.
In my actual context, making the map with only one layer leads to a ~20mb file. However, if I add one field it gets to ~40mb and three layer ~60mb. So it seems to me that the html produced is loading the same shapefile 3 times instead of simply using one shapefile and linking it a data frame of some sort.
Am I stock with this behavior of leaflet or is there a way to file size inflation in my context? I may not have programmed my leaflet the better way...
I've made a reproducible example to show the problem. It uses a small shapefile so the size problem is not dramatic, however the point is the same, which is constantly doubling file size. Also, the example is lengthy, sorry about that, I could'n find a way to simplify it further.
Preparation:
# loading the libraries
library(sf)
library(leaflet)
library(htmlwidgets)
# preparing the shapefile
nc <- st_read(system.file("gpkg/nc.gpkg", package="sf"), quiet = TRUE) %>%
st_transform(st_crs(4326))
# preparing the colors (not really important)
pal.area <- colorNumeric(palette = "inferno", domain = range(nc$AREA))
pal.perim <- colorNumeric(palette = "inferno", domain = range(nc$PERIMETER))
pal.cnty <- colorNumeric(palette = "inferno", domain = range(nc$CNTY_))
pal.sid74 <- colorNumeric(palette = "inferno", domain = range(nc$SID74))
Making the leaflet, this section is long, however it's simply 4 leaflet maps created one after another by adding one layer at a time. It's mostly copy-pasted work:
###
one_layer <- leaflet(data = nc) %>%
addTiles() %>%
addPolylines(fillColor = ~pal.area(AREA),
fill = TRUE,
opacity = 0.8,
group = "area") %>%
addLegend("bottomright",
pal = pal.area, values = ~AREA,
opacity = 1, group = "area"
)
###
###
two_layers <- leaflet(data = nc) %>%
addTiles() %>%
addPolylines(fillColor = ~pal.area(AREA),
fill = TRUE,
opacity = 0.8,
group = "area") %>%
addLegend("bottomright",
pal = pal.area, values = ~AREA,
opacity = 1, group = "area") %>%
addPolylines(fillColor = ~pal.perim(PERIMETER),
fill = TRUE,
opacity = 0.8,
group = "perim") %>%
addLegend("bottomright",
pal = pal.perim, values = ~PERIMETER,
opacity = 1, group = "perim"
) %>%
addLayersControl(
overlayGroups = c("area", "perim"), position = "bottomleft",
options = layersControlOptions(collapsed = FALSE)
)
###
###
three_layers <- leaflet(data = nc) %>%
addTiles() %>%
addPolylines(fillColor = ~pal.area(AREA),
fill = TRUE,
opacity = 0.8,
group = "area") %>%
addLegend("bottomright",
pal = pal.area, values = ~AREA,
opacity = 1, group = "area") %>%
addPolylines(fillColor = ~pal.perim(PERIMETER),
fill = TRUE,
opacity = 0.8,
group = "perim") %>%
addLegend("bottomright",
pal = pal.perim, values = ~PERIMETER,
opacity = 1, group = "perim"
) %>%
addPolylines(fillColor = ~pal.cnty(CNTY_),
fill = TRUE,
opacity = 0.8,
group = "cnty") %>%
addLegend("bottomright",
pal = pal.cnty, values = ~CNTY_,
opacity = 1, group = "cnty"
) %>%
addLayersControl(
overlayGroups = c("area", "perim", "cnty"), position = "bottomleft",
options = layersControlOptions(collapsed = FALSE)
) %>%
hideGroup(c("perim","cnty"))
###
###
four_layers <- leaflet(data = nc) %>%
addTiles() %>%
addPolylines(fillColor = ~pal.area(AREA),
fill = TRUE,
opacity = 0.8,
group = "area") %>%
addLegend("bottomright",
pal = pal.area, values = ~AREA,
opacity = 1, group = "area") %>%
addPolylines(fillColor = ~pal.perim(PERIMETER),
fill = TRUE,
opacity = 0.8,
group = "perim") %>%
addLegend("bottomright",
pal = pal.perim, values = ~PERIMETER,
opacity = 1, group = "perim"
) %>%
addPolylines(fillColor = ~pal.cnty(CNTY_),
fill = TRUE,
opacity = 0.8,
group = "cnty") %>%
addLegend("bottomright",
pal = pal.cnty, values = ~CNTY_,
opacity = 1, group = "cnty"
) %>%
addPolylines(fillColor = ~pal.sid74(SID74),
fill = TRUE,
opacity = 0.8,
group = "sid74") %>%
addLegend("bottomright",
pal = pal.sid74, values = ~SID74,
opacity = 1, group = "sid74"
) %>%
addLayersControl(
overlayGroups = c("area", "perim", "cnty", "sid74"), position = "bottomleft",
options = layersControlOptions(collapsed = FALSE)
) %>%
hideGroup(c("perim","cnty", "sid74"))
###
Then, you get 4 objects (maps) we can compare their size directly in R:
object.size(one_layer)
301864 bytes
object.size(two_layers)
531144 bytes
object.size(three_layers)
681872 bytes
object.size(four_layers)
828616 bytes
The size increase is constant and way higher that what we would expect if the only the data was added instead of all the spatial info. As a comparison, the initial shape which has 15 fields is of size:
object.size(nc)
135360 bytes
If we save the maps to HTML, the problem is even more visible:
saveWidget(one_layer, paste0(getwd(),"/temp_data/temp/one_layer.html"), selfcontained = F)
saveWidget(two_layers, paste0(getwd(),"/temp_data/temp/two_layers.html"), selfcontained = F)
saveWidget(three_layers, paste0(getwd(),"/temp_data/temp/three_layers.html"), selfcontained = F)
saveWidget(four_layers, paste0(getwd(),"/temp_data/temp/four_layers.html"), selfcontained = F)
file.info(list.files("temp_data/temp", pattern = ".html$", full.names = T))$size[c(2,4,3,1)] %>%
setNames(c("One Layer", "Two Layers", "Three Layers", "Four Layers")) %>%
barplot(ylab="size in Bytes")
It's clearly doubling in size.
So, to summarize, is there a way to get leaflet to not reproduced the spatial information when adding multiple fields of data to the same map?
Related
I am working with the R programming language.
I am following this tutorial here (https://cengel.github.io/R-spatial/mapping.html) and trying to make a "heatmap" like this:
Here is the code I am using:
# input shapefile = sf
st_trans = st_transform(sf, 4326)
breaks_qt <- classIntervals(sf$my_variable, n=7, style = "quantile")
pal_fun <- colorQuantile("YlOrRd", NULL, n=7)
m = leaflet(st_trans) %>%
addPolygons(
stroke = FALSE,
fillColor = ~pal_fun(my_variable),
fillOpacity = 0.8, smoothFactor = 0.5,
popup = label_text) %>%
addTiles(group = "OSM") %>%
addProviderTiles("CartoDB.DarkMatter",group = "Carto") %>%
addLegend("bottomright",
colors = brewer.pal(7, "YlOrRd"),
labels = paste0("up to ", format(breaks_qt$brks[-1], digits = 2)),
title = 'Legend Title') %>%
addLayersControl(baseGroups = c("OSM", "Carto"),
overlayGroups = c("groups"))
In the past, this above code has worked well - however, this time, "my_variable" (e.g. number of Spelling Bee champions in each polygon) has many zeros which I think is causing problems in the labels = paste0("up to ", format(breaks_qt$brks[-1], digits = 2)) and classIntervals(sf$my_variable, n=7, style = "quantile") lines (e.g. Error: 'breaks' are not unique')
I tried looking at previous posts (e.g. Cut() error - 'breaks' are not unique) and was able to use one of the answers here to resolve the first problem, e.g.
a_ranks <- rank(st_trans$my_variable, ties.method = "first")
st_trans$my_variable <- cut(a_ranks, quantile(a_ranks, probs=c(0, 0.15, 0.30, 0.45, 0.60, 0.75, 0.90)), include.lowest=TRUE, labels=FALSE)
m = leaflet(st_trans) %>%
addPolygons(
stroke = FALSE,
fillColor = ~pal_fun(my_variable),
fillOpacity = 0.8, smoothFactor = 0.5,
popup = label_text) %>%
addTiles(group = "OSM") %>%
addProviderTiles("CartoDB.DarkMatter",group = "Carto") %>%
addLegend("bottomright",
colors = brewer.pal(7, "YlOrRd"),
labels = paste0("up to ", format(st_trans$my_variable, digits = 2)),
title = 'Legend Title') %>%
addLayersControl(baseGroups = c("OSM", "Carto"),
overlayGroups = c("groups"))
But I still get an error: Error in addLegend(),: 'colors' and 'labels' must be of the same length
In general, are there any methods I can use to avoid these problems?
Thanks!
Note: I can get the map to work without the legend
leaflet(st_trans) %>%
addPolygons(
stroke = FALSE,
fillColor = ~pal_fun(my_variable),
fillOpacity = 0.8, smoothFactor = 0.5,
popup = label_text) %>%
addTiles(group = "OSM") %>%
addProviderTiles("CartoDB.DarkMatter",group = "Carto")
Anybody know how to set a default layer to show just one Overlay group first rather than all at once? For example, in the following if I just wanted to show 'Mex' initially and then let the viewer swap to 'GTM'?
library(raster)
library(leaflet)
#load in shapefiles
gtm <- getData('GADM', country = 'GTM', level = 0)
mex <- getData('GADM', country = 'MEX', level = 0)
leaflet() %>%
addTiles() %>%
addPolygons(data = gtm,
fillColor = 'red',
group = "gtm") %>%
addLegend(color = "red",
labels = gtm#data$GID_0,
group = "gtm") %>%
addPolygons(data = mex,
fillColor = 'blue',
group = "mex") %>%
addLegend(color = "blue",
labels = mex#data$GID_0,
group = "mex") %>%
addLayersControl(overlayGroups = c("gtm", "mex"),
options = layersControlOptions(collapsed = F),
)
Use function hideGroup to hide groups from code
addLayersControl(overlayGroups = c("gtm", "mex"),
options = layersControlOptions(collapsed = F)) %>%
hideGroup("mex")
See the official leaflet vignette under section Show/Hide Layers
this is my first time working with R shiny and I am attempting to integrate shiny features with a leaflet map I have made. The idea is that I would like to have radio buttons which toggle between four different polygons layers generated by shapefile data, and a slider which controls the opacity of the polygon layer. I used code from several different tutorials on shiny and leaflet but when I attempt to generate the map I get the following warning:
Warning: Error in google_dispatch: Invalid map parameter
[No stack trace available]
the panel with my buttons and slider appear but not my map. I believe this issue is with this section of my code:
opacityf <- reactive({
opacity[opacity$value == input$slider, ]
})
layerf <- reactive({
switch(input$layer,
countiesr = counties,
regionsr = regions,
triber = tribe,
publicr = public,
selected = NULL)
})
observe({
leafletProxy(mapId = "Intensity_Map", data = layerf()) %>%
clear_polygons() %>%
addPolygons(fillOpacity = opacityf(),
weight = 1,
color = "purple4")
})
}
I created a data frame with values between 0.0 and 1.0 for the opacity slider and I am attempting to direct shiny to change to opacity value to be whatever the slider value is. For the buttons I am trying to direct shiny to plot one of the four spatial polygon objects I created using the shapefiles. I believe I have a mistake in here somewhere but I cannot seem to figure out what it is.
Here is the rest of my code for reference:
ui <- fluidPage(
titlePanel("Cyano-Toxin Concentration in Relation
to OEHHA Action Levels for Acute Toxicity in Dogs"),
sliderInput(inputId = "slider",
label = "Opacity",
min = 0,
max = 1,
value = NULL,
step = 0.1),
radioButtons(inputId = "layer",
label = "Map Layer",
choices = c("Counties" = "countiesr",
"Regional Boards" = "regionsr",
"Tribal Lands" = "triber",
"Public Lands" = "publicr")),
leafletOutput("Intensity_Map")
)
opacity <- data.frame(value = c(0.0,0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1.0))
server <- function(input, output, session){
output$Intensity_Map <- renderLeaflet({
leaflet() %>% setView(lat = 36.778259, lng = -119.417931, zoom = 5) %>% addTiles(group = "None") %>%
addCircleMarkers(
data = ws_ND,
radius = 4,
color = "grey",
stroke = FALSE, fillOpacity = 0.7,
label = ~as.character(label),
popup = ~as.character(popup),
group = "None Detected"
)%>%
addCircleMarkers(
data = ws_M,
radius = ws_M$Radius,
color = ~pala(Percent.of.AL),
stroke = FALSE, fillOpacity = 0.7,
label = ~as.character(label),
popup = ~as.character(popup),
group = "Microcystin/Nod."
)%>%
addCircleMarkers(
data = ws_C,
radius = ws_C$Radius,
color = ~palc(Percent.of.AL),
stroke = FALSE, fillOpacity = 0.7,
label = ~as.character(label),
popup = ~as.character(popup),
group = "Cylindrospermopsin"
)%>%
addCircleMarkers(
data = ws_A,
radius = ws_C$Radius,
color = ~palb(Percent.of.AL),
stroke = FALSE, fillOpacity = 0.7,
label = ~as.character(label),
popup = ~as.character(popup),
group = "Anatoxin-a"
)%>%
addCircleMarkers(
data = ws_S,
color = "yellow",
radius = 8,
stroke = FALSE, fillOpacity = 0.7,
label = ~as.character(label),
popup = ~as.character(popup),
group = "Saxitoxin"
)%>%
addLayersControl(
overlayGroups = c("None Detected", "Microcystin/Nod.","Cylindrospermopsin","Anatoxin-a","Saxitoxin"),
options = layersControlOptions(collapsed = FALSE),
position = "topright"
)%>%
addLegend("bottomright", pal = palab, values = (labels = c("1. < 25%","2. 25% - 49%","3. 50% - 99%", "4. ≥ 100%")),
title = "Microcystin/Nod.",
opacity = 1,
group = "Microcystin/Nod."
)%>%
addLegend("bottomright", pal = palbb, values = (labels = c("1. < 25%","2. 25% - 49%","3. 50% - 99%", "4. ≥ 100%")),
title = "Anatoxin-a",
opacity = 1,
group = "Anatoxin-a"
)%>%
addLegend("bottomright", pal = palcb, values = (labels = c("1. < 25%","2. 25% - 49%","3. 50% - 99%", "4. ≥ 100%")),
title = "Cylindrospermopsin",
opacity = 1,
group = "Cylindrospermopsin") })
opacityf <- reactive({
opacity[opacity$value == input$slider, ]
})
layerf <- reactive({
switch(input$layer,
countiesr = counties,
regionsr = regions,
triber = tribe,
publicr = public,
selected = NULL)
})
observe({
leafletProxy(mapId = "Intensity_Map", data = layerf()) %>%
clear_polygons() %>%
addPolygons(fillOpacity = opacityf(),
weight = 1,
color = "purple4")
})
}
shinyApp(ui, server)
Any thoughts would be greatly appreciated!
In the tiny example shown below, I have two features associated with each country (polygons) in the map, namely: randomA, randomB. Each feature has its own legend, so I armed a group named "randomA" containing the polygons coloured with feature randomA and its corresponding legend. I did the same for group "randomB". When the map is depicted, leaflet correctly shows or hides polygons for features "randomA" and "randomB". However legends are always shown stacked on the bottom right corner.
This is the code:
library(rgdal)
library(leaflet)
# From http://data.okfn.org/data/datasets/geo-boundaries-world-110m
countries <- readOGR("json/countries.geojson")
n <- nrow(countries)
# Add two random fields
set.seed(15)
countries#data$randomA <- rnorm(n, 1000, 250)
countries#data$randomB <- rnorm(n, 10000, 3000)
map <- leaflet(countries) %>% addTiles()
pal <- colorNumeric(
palette = "YlGnBu",
domain = countries$randomA
)
map <- map %>%
addPolygons(stroke = FALSE, smoothFactor = 0.2, fillOpacity = 1,
color = ~pal(randomA), group = "randomA"
) %>%
addLegend("bottomright", pal = pal, values = ~randomA,
title = "random A",
labFormat = labelFormat(prefix = "$"),
opacity = 1, group = "randomA"
)
qpal <- colorQuantile("RdYlBu", countries$gdp_md_est, n = 5)
map <- map %>%
addPolygons(stroke = FALSE, smoothFactor = 0.2, fillOpacity = 1,
color = ~qpal(randomB), group = "randomB"
) %>%
addLegend(
"bottomright",
pal = qpal,
values = ~randomB,
opacity = 1, group = "randomB"
)
# Finally control layers:
map <- map %>%
addLayersControl(
baseGroups = c("randomA", "randomB"),
position = "bottomleft",
options = layersControlOptions(collapsed = F)
)
map
A snapshot of the result is shown in the image below:
Also, in the actual problem I have to represent nine of these groups, so I wish I had all the legends in the same place.
Do you have any suggestion?
Try using overlay groups instead of base groups:
addLayersControl(
overlayGroups = c("randomA", "randomB"),
position = "bottomleft",
options = layersControlOptions(collapsed = F)
)
I am making an R leaflet map (not Shiny) and I have two control groups, and based on the selection I would like a different legend to become visible. Currently I only manage to have both legends visible at all time.
Below is the code for the leaflet map, and the output can be seen in the image.
leaflet() %>% addSearchOSM() %>%
addProviderTiles(providers$CartoDB.Positron,
options = providerTileOptions(noWrap = TRUE),
group = "kaart") %>%
# addFullscreenControl() %>%
addCircleMarkers(data = table#data,
lat = ~lng,
lng = ~lat,
color = ~palverbruikplaats(Verbruiksplaats),
label = bepaalPopup(),
group = "Verbruikplaatscircles"
)%>%
addCircleMarkers(data = table#data,
lat = ~lng,
lng = ~lat,
color = ~palstatus(`Status omschrijving`),
label = bepaalPopup(),
group = "statuscircles"
)%>%
leaflet::addLegend("bottomleft", pal = palverbruikplaats, values = verbruikplaatsuniek, title = "Legenda") %>%
leaflet::addLegend("bottomleft", pal = palstatus, values = statusuniek, title = "Legenda") %>%
addLayersControl(baseGroups = c("Verbruikplaatscircles", "statuscircles"),
options = layersControlOptions(collapsed = FALSE))
In your addLayersControl did you mean to set the overlayGroups argument instead of baseGroups?
library(leaflet)
leaflet() %>%
addTiles(group = "OpenStreetMap") %>%
addCircleMarkers(runif(20, -75, -74), runif(20, 41, 42), group = "Markers1", color ="red") %>%
addMarkers(runif(20, -75, -74), runif(20, 41, 42), group = "Markers2") %>%
addLegend(values = 1, group = "Markers1", position = "bottomleft", labels = "1", colors= "red") %>%
addLegend(values = 2, group = "Markers2", position = "bottomleft", labels = "2" ,colors= "blue") %>%
addLayersControl(overlayGroups = c("Markers1", "Markers2"),
options = layersControlOptions(collapsed = FALSE))
what you need to do is, you need to make your legends values reactive
addLegend("bottomright", pal = pal, values = maindata#data[,req_var1()],
you can declare the req_var1() in server before calling
req_var1<-reactive({if(input$`Comparison Metric`=="Current Territory Factors vs GeoProxy Smoothing"){
paste(input$Curr2,"Curr",sep="_")
} else if(input$`Comparison Metric`=="Current Written Premium Vs Indicated Written Premium"){
paste(input$Curr2,"CWP",sep="_")
}
})
and also the pal can be declared as
pal1 <- reactive({if(input$ColorType=="Percentile"){
colorQuantile(
palette = "Spectral",
domain = tempdata()#data[,req_var1()],
probs = if(input$`Comparison Metric`=="Current Territory Factors vs GeoProxy Smoothing"){seq(0,1,by=0.25)
} else if(input$`Comparison Metric`=="Current Written Premium Vs Indicated Written Premium"){
seq(0,1,by=0.5)
}
## In case of Current written premium the variation is very less so while executing color mapping code is throwing error.
## This is because the some of quantiles values are not differentiable.
## So in colorQuantile function we have given two different prob values depending on metric selection.
)
} else if(input$ColorType=="Absolute Value"){colorNumeric(
palette = "Spectral",
domain = tempdata()#data[,req_var1()])
}else{print("Plese select Any one color map")}
})