R Leaflet layers control with easybutton - r

I would like to use the leaflet easyButton plugin to control the layers shown instead of the built in layer controls. Unfortunately I do not know JS, and have spent several hours trying to make sense of the leafletJS documentation to find the correct way to do this.
Here is a slimmed down version of the code I'm attempting. The onClick is clearly working since the alerts happen, but nothing changes with the layer being shown.
Each button should show ONLY that one layer and none of the others (as opposed to allowing multiple layers to be seen at once).
library(tidyverse)
library(sf)
library(tigris)
library(leaflet)
statemap <- states(cb = T)
statemap <- statemap %>%
filter(GEOID < 60) %>%
shift_geometry(geoid_column = "GEOID") %>%
st_transform("EPSG:4326")
leaflet(statemap) %>%
addPolygons(weight = 1.25, color = "#000000", opacity = 1,#444444
fillColor = "green",
layerId = "green") %>%
addPolygons(weight = 1.25, color = "#000000", opacity = 1,#444444
fillColor = "red",
layerId = "red") %>%
addPolygons(weight = 1.25, color = "#000000", opacity = 1,#444444
fillColor = "yellow",
layerId = "yellow") %>%
addEasyButtonBar(easyButton(icon = "fa-globe", title = "Drinking Water Standard",
onClick = JS("function(btn, map) {
alert(\"Green\");
map.clearLayers();
map.addLayer('green');
}")),
easyButton(icon = "fa-crosshairs", title = "Groundwater Standard",
onClick = JS("function(btn, map) {
alert(\"Yellow\");
map.clearLayers();
map.addLayer('yellow');
}")),
easyButton(icon = "fa-globe", title = "Surface Water Standard",
onClick = JS("function(btn, map) {
alert(\"Red\");
map.clearLayers();
map.addLayer('red');
}")))

You could use the existing functionality of the baseGroups argument in the addLayersControl() function and map the onClick event to the Easy Buttons.
The final onRender() function simply hides this layer control panel so people use the easy buttons instead.
Working example: https://rpubs.com/Jumble/leaflet_easybuttons_layer_control
library(tidyverse)
library(sf)
library(tigris)
library(leaflet)
statemap <- states(cb = T)
statemap <- statemap %>%
filter(GEOID < 60) %>%
shift_geometry(geoid_column = "GEOID") %>%
st_transform("EPSG:4326")
leaflet(statemap) %>%
addPolygons(weight = 1.25, color = "#000000", opacity = 1,#444444
fillColor = "green",
group = "green") %>%
addPolygons(weight = 1.25, color = "#000000", opacity = 1,#444444
fillColor = "red",
group = "red") %>%
addPolygons(weight = 1.25, color = "#000000", opacity = 1,#444444
fillColor = "yellow",
group = "yellow") %>%
addLayersControl(baseGroups = c("green", "red", "yellow"), options=layersControlOptions(collapsed = F)) %>%
addEasyButtonBar(easyButton(icon = "fa-globe", title = "Drinking Water Standard",
onClick = JS("function(btn, map) {
let layerControlElement = document.getElementsByClassName('leaflet-control-layers')[0];
layerControlElement.getElementsByTagName('input')[0].click();
}")),
easyButton(icon = "fa-crosshairs", title = "Groundwater Standard",
onClick = JS("function(btn, map) {
let layerControlElement = document.getElementsByClassName('leaflet-control-layers')[0];
layerControlElement.getElementsByTagName('input')[1].click();
}")),
easyButton(icon = "fa-globe", title = "Surface Water Standard",
onClick = JS("function(btn, map) {
let layerControlElement = document.getElementsByClassName('leaflet-control-layers')[0];
layerControlElement.getElementsByTagName('input')[2].click();
}"))) %>%
htmlwidgets::onRender("
function(el, x) {
document.getElementsByClassName('leaflet-control-layers')[0].style.display = 'none';
}")

Related

specifying colors manually in leaflet bivariate map within shiny app contex

Using the code below, I have created a map within the shiny app context. However, as shown in the picture, the polygons' colors are inconsistent with the legend color scheme. I wonder how they can be consistent preferably by changing the legend color scheme. In the code below, the bi_class variable was defined in 9 categories involving a 3-dimensional quantile of x and y variables (i.e, low-low, low-medium, low-high, medium-low, medium-medium, ...).
output$bi_ACSB_BlackP <- renderLeaflet ({
npal2 <- colorFactor(
palette = ("Greens"),
domain = IDD_nhmap$bi_class
)
labels <- sprintf(
"<strong>Zip Code=%s </strong> <br/> African American (ACS) = %s <br/> African American (Projects)= %s ",
IDD_mapdata_()$Zip,
IDD_mapdata_()$Zip_Black,
IDD_mapdata_()$Zip_Hisp
) %>%
lapply(htmltools::HTML)
leaflet (IDD_mapdata_(), options = leafletOptions(zoomSnap = 0.25, zoomDelta =
0.25)) %>%
addProviderTiles("CartoDB.Positron",
options = providerTileOptions(opacity = 2)) %>%
clearControls() %>%
clearShapes() %>%
addPolygons(
fillColor = ~npal2(bi_class),
stroke = T,
weight = 1,
smoothFactor = 0.2,
fillOpacity = 1,
color = "black",
# label=~paste0(NAME," ","County",":"," ",input$sex_map,",", " ",
# input$ProjectID,"=",Age,"%"),
label = labels,
labelOptions = labelOptions(
interactive = TRUE,
style = list(
'direction' = 'auto',
'color' =
'black',
'font-family' = 'sans-serif',
# 'font-style'= 'italic',
'box-shadow' = '3px 3px rgba(0,0,0,0.25)',
'font-size' = '14px',
'border-color' = 'rgba(0,0,0,0.5)'
)
),
# label=~paste(NAME,"<br>",input$sex_map,
# input$ProjectID,"=",Age,"%"),
# label = lapply(labs, htmltools::HTML),
highlightOptions = highlightOptions(
#color = "red",
weight = 2,
bringToFront = T,
# color = "#666",
fillOpacity = 0.7
)
) %>%
setView(lng = IDD_mapdata_1()$long,
lat = IDD_mapdata_1()$lat,
zoom = 8) %>%
bivariatechoropleths::addBivariateChoropleth(
map_data = bivariatechoropleths::renfrew_county,
var1_name = pop_2016,
var2_name = median_household_income_2015,
ntiles= 3,
var1_label = "African American",
var2_label = "Hispanics",
region_name = "CSDNAME",
weight = 1,
fillOpacity = 0.7,
color = "grey",
highlightOptions = leaflet::highlightOptions(color = "orange",
weight = 2,
opacity = 1)) %>%
addTiles(options = tileOptions(opacity = 2))
})
I think if you declare a function that selects the Green colors like this one should probably work:
palColFun <- function(colorPalette = "Greens", n = 9){
pal <- RColorBrewer::brewer.pal(n, colorPalette)
return(pal)
}
Then in your code for bivariatechropleth you should add as follows:
bivariatechoropleths::addBivariateChoropleth(
map_data = bivariatechoropleths::renfrew_county,
var1_name = pop_2016,
var2_name = median_household_income_2015,
ntiles= 3,
var1_label = "African American",
var2_label = "Hispanics",
region_name = "CSDNAME",
weight = 1,
paletteFunction = palColFun,
fillOpacity = 0.7,
color = "grey",
highlightOptions = leaflet::highlightOptions(color = "orange",
weight = 2,
opacity = 1)) %>%
addTiles(options = tileOptions(opacity = 2))
Ideally you would link palColFun with the same color you generated for the plots, but given the example above, it is not for me to reproduce the example.
Hopefully this works.

Bivariate map within Shiny r

Using the code below, I could create my maps of interest which work perfectly fine within my shiny dashboard. I would like to create a bivariate map by combining these two maps.
Here are the codes for the maps:
#The code below reactivates the data:
IDD_mapdata_ <- reactive ({
out_map <- IDD_nhmap %>%
filter (ProjectID %in% input$ProjectID)
return(out_map)
})
#The code below creates the first map:
output$IDD_int_map_svi <- renderLeaflet ({
npal2 <- colorNumeric(palette = "Greens",
domain = IDD_nhmap$svi)
leaflet (IDD_mapdata_(), options = leafletOptions(zoomSnap = 0.25, zoomDelta =
0.25)) %>%
addProviderTiles("CartoDB.Positron",
options = providerTileOptions(opacity = 2)) %>%
clearControls() %>%
clearShapes() %>%
addPolygons(
fillColor = ~npal2(svi),
stroke = T,
weight = 1,
smoothFactor = 0.2,
fillOpacity = 1,
color = "black",
label = labels,
labelOptions = labelOptions(
interactive = TRUE,
style = list(
'direction' = 'auto',
'color' =
'black',
'font-family' = 'sans-serif',
# 'font-style'= 'italic',
'box-shadow' = '3px 3px rgba(0,0,0,0.25)',
'font-size' = '14px',
'border-color' = 'rgba(0,0,0,0.5)'
)
),
highlightOptions = highlightOptions(
weight = 2,
bringToFront = T,
fillOpacity = 0.7
)
) %>%
setView(lng = IDD_mapdata_1()$long,
lat = IDD_mapdata_1()$lat,
zoom = 8) %>%
addLegend(
position = "topright",
opacity = 1,
values = IDD_nhmap$svi,
pal = npal2,
title = (paste("Social Vulnerability Index")) ,
labFormat = labelFormat()
) %>%
addTiles(options = tileOptions(opacity = 2))
})
#The code below generates the second map:
output$IDD_int_map1 <- renderLeaflet ({
npal2 <- colorNumeric(palette = "Greens",
domain = IDD_nhmap$Zip_Black)
leaflet (IDD_mapdata_(), options = leafletOptions(zoomSnap = 0.25, zoomDelta =
0.25)) %>%
addProviderTiles("CartoDB.Positron",
options = providerTileOptions(opacity = 2)) %>%
clearControls() %>%
clearShapes() %>%
addPolygons(
fillColor = ~npal2(Zip_Black),
stroke = T,
weight = 1,
smoothFactor = 0.2,
fillOpacity = 1,
color = "black",
label = labels,
labelOptions = labelOptions(
interactive = TRUE,
style = list(
'direction' = 'auto',
'color' =
'black',
'font-family' = 'sans-serif',
# 'font-style'= 'italic',
'box-shadow' = '3px 3px rgba(0,0,0,0.25)',
'font-size' = '14px',
'border-color' = 'rgba(0,0,0,0.5)'
)
),
highlightOptions = highlightOptions(
weight = 2,
bringToFront = T,
# color = "#666",
fillOpacity = 0.7
)
) %>%
setView(lng = IDD_mapdata_1()$long,
lat = IDD_mapdata_1()$lat,
zoom = 8) %>%
addLegend(
position = "topright",
opacity = 1,
values = IDD_nhmap$Zip_Black,
pal = npal2,
title = (paste("African Americans (ACS)")) ,
labFormat = labelFormat()
) %>%
addTiles(options = tileOptions(opacity = 2))
})

How to show/hide legend with control layer panel with leaflet?

I am trying to plot a map with multiple layers. However, when selecting the group I want to show in the controlLayer panel, it changes the map but not the legend. In fact, the 2 legends are always displayed together on the map, but I only want one of them at a time.
Here is the code I use :
leaflet(data) %>%
addProviderTiles("Esri.WorldStreetMap") %>%
addRasterImage(r, opacity = 1, colors = cb, group = "Predictions") %>%
addLegend(pal = cb, values = wind_speed_range, title = "Wind Speed", opacity = 1, group = "Predictions", position = "topright") %>%
addCircles(radius = ~ residual*7000, color = "black", fillColor = ~ cb(predictions), fillOpacity = 1, label = ~ paste(as.character(residual), " / ", as.character(vitesse_vent), " / ", as.character(predictions)), weight = 2, group = "Predictions") %>%
addRasterImage(raster_difference, opacity = 1, colors = cb_correction, group = "Corrections") %>%
addLegend(pal = cb_correction, values = correction_range, title = "Corrections", opacity = 1, group = "Corrections", position = "topright") %>%
addLayersControl(
baseGroups = c("Prédictions", "Corrections"),
options = layersControlOptions(collapsed = FALSE),
position = "topleft"
)
As you can see, I already tried the solution of this post. I also tried with overlayGroup instead of baseGroup, but the problem is still here.
The image below is what I get using this code :
You can clearly see the two legends.
Code
Unfortunately, you did not provide a reprex, so I show it with a made up example:
library(leaflet)
cities1 <- data.frame(City = factor(c("Boston", "Hartford",
"New York City", "Philadelphia", "Pittsburgh", "Providence")),
Lat = c(42.3601, 41.7627, 40.7127, 39.95, 40.4397, 41.8236),
Long = c(-71.0589, -72.6743, -74.0059, -75.1667, -79.9764, -71.4222),
Pop = c(645966L, 125017L, 8406000L, 1553000L, 305841L, 177994L),
Type = factor(c("C", "D", "A", "A", "B", "C")))
cities2 <- data.frame(City = factor(c("Baltimore", "Ithaca", "Wareham")),
Lat = c(39.299236, 42.443962, 41.761452),
Long = c(-76.609383, -76.501884, -70.719734),
Pop = c(609032L, 30569L, 22666L),
Type = factor(letters[1:3]))
pal1 <- colorFactor("viridis", domain = cities1$Type)
pal2 <- colorFactor("Set1", domain = cities2$Type)
leaflet(cities1) %>%
addTiles() %>%
addCircles(data = cities1, lng = ~Long, lat = ~Lat, weight = 1, group="one",
radius = ~sqrt(Pop) * 30, popup = ~City, color = ~pal1(Type), opacity = .9
) %>%
addLegend(pal = pal1, values = ~Type, group = "one", layerId = "one") %>%
addCircles(data = cities2, lng = ~Long, lat = ~Lat, weight = 1, group = "two",
radius = ~sqrt(Pop) * 30, popup = ~City, color = ~pal2(Type), opacity = .9
) %>%
addLegend(pal = pal2, values = ~Type, data = cities2, group = "two", layerId = "two") %>%
addLayersControl(
baseGroups = c("one", "two"),
options = layersControlOptions(collapsed = FALSE),
position = "topleft"
) %>%
htmlwidgets::onRender("
function() {
var map = this;
var legends = map.controls._controlsById;
function addActualLegend() {
var sel = $('.leaflet-control-layers-base').find('input[type=\"radio\"]:checked').siblings('span').text().trim();
$.each(map.controls._controlsById, (nm) => map.removeControl(map.controls.get(nm)));
map.addControl(legends[sel]);
}
$('.leaflet-control-layers-base').on('click', addActualLegend);
addActualLegend();
}")
Explanation
You can define some custom JavaScript which reacts upon the changes of the radio buttons. When they change, I basically delete all controls and add the selected. In order for this to work, I need to save a copy of the controls first. This is of course a bit hackish (especially since I am accessing the "private" _controlsById slot of the map), but from my quick scan of the leaflet API I did not find a better entry point.
Screenshot

Highlight Borders When Mouseover Fill Area - Leaflet-R

Following the guidance of #TimSalabim, I separated the borders and fill of my neighbourhood polygons so that I could order them appropriately with zIndex.
https://lawsblog.netlify.com/post/leaflet-map/
If I place the highlightOptions() function within the addPolygons(neighbourhood fill) function, I don't know how to increase the border of the polygon upon mouseover.
If I place the highlightOptions() function within the addPolylines(neighbourhood border) function I can CAREFULLY mouse-over just the borders and the widths increase. That's the behavior I want, when I mouse-over any part of the neighbourhood area.
Now that I've separated the fill and borders of the polygons how do I increase the border width when I mouse-over the fill area?
# Add hood borders
addPolylines(data = borders,
color = "white",
opacity = 1,
weight = 2,
options = pathOptions(pane = "hood_borders")) %>%
# Add hood fill
addPolygons(data = hood_shp,
fillColor = ~pal(be_per_cap),
fillOpacity = 1.0,
color = NA,
options = pathOptions(pane = "hoods",
# Highlight neighbourhoods upon mouseover - NOT CORRECT
highlight = highlightOptions(
stroke = 4),
# Add label info when mouseover
label = labels,
labelOptions = labelOptions(
style = list("font-weight" = "normal", padding = "3px 8px"),
textsize = "15px",
direction = "auto")))
Taking what SeGa advised, I've modified the code. See here. The neighbourhood borders are not obscured and the border does expand upon hover. However the border does not revert back to its original width with mouse out. Why is that?
leaflet(options = leafletOptions(minZoom = 11, maxZoom = 16), width = "100%") %>%
addTiles() %>%
# Raster image surrounding Toronto
addProviderTiles(providers$OpenStreetMap.BlackAndWhite) %>%
# Center map north of Toronto City Hall slightly zoomed in
setView(map,
lng = -79.384293,
lat = 43.685, #43.653908,
zoom = 12) %>%
# Vector neighbourhoods
addPolygons(data = hood_shp,
fillColor = ~pal(be_per_cap),
color = NA,
fillOpacity = 1,
# Highlight neighbourhoods upon mouseover
highlight = highlightOptions(
weight = 3,
fillOpacity = 0,
color = "black",
opacity = 1.0,
bringToFront = TRUE,
sendToBack = TRUE),
# # Add label info when mouseover
label = labels,
labelOptions = labelOptions(
style = list("font-weight" = "normal", padding = "3px 8px"),
textsize = "15px",
direction = "auto")) %>%
# Add highways
addPolygons(data = xway,
color = "sienna",
weight = 1.0,
opacity = 1.0,
fillOpacity = 0.7) %>%
# Add major arterial
addPolygons(data = mart,
color = "#737373",
weight = 1.0,
opacity = 1.0,
fillOpacity = 1.0) %>%
# Add parks
addPolygons(data = parks,
color = "green",
weight = 1.0,
opacity = 1.0,
fillOpacity = 1.0,
options = pathOptions(clickable = FALSE)) %>%
# Add border
addPolylines(data = hood_shp,
color = "black",
stroke = TRUE,
opacity = 1,
weight = 1) %>%
# Add legend
addLegend(data = hood_shp,
colors =c("#AA122E", "#F4AE7E", "#FEFDB7"),
labels= c("More", "", "Less"),
opacity = 1.0,
title = "B&Es",
position = "bottomright")
I'm not sure if I understand your problem correctly but if you only want to increase the borders of a polygon with leaflet, the highlightoption is the right choice, but you shouldn't place it inside the pathOptions.
The following example uses addPolygons for the neighboorhoods with a highlightOption. Within those you define the behaviour of the neighboorhoods when mouse-overing. With the weight argument you define the border size.
The parks also go in an addPolygons but with options =
pathOptions(clickable = FALSE) you make them unclickable, so they
dont interact with mouse events.
And the borders go in a addPolylines without any further
options.
Is the following example what you are looking for?
library(sp)
Sr1 = Polygon(cbind(c(2,4,4,1,2),c(2,3,5,4,2)))
Sr2 = Polygon(cbind(c(5,4,2,5),c(2,3,2,2)))
Srs1 = Polygons(list(Sr1), "s1")
Srs2 = Polygons(list(Sr2), "s2")
hood_shp = SpatialPolygons(list(Srs1,Srs2), 1:2)
hood_shp <- SpatialPolygonsDataFrame(hood_shp, data=data.frame(be_per_cap = 1:length(hood_shp)), match.ID = F)
parks = Polygon(cbind(c(2,3,3,1,2),c(1,2,4,3,1)))
parks = SpatialPolygons(list(Polygons(list(parks), "parks")))
xway = Polygon(cbind(c(1,5,5,1,3),c(3,5,5,3,1)))
xway = SpatialPolygons(list(Polygons(list(xway), "xway")))
library(shiny)
library(leaflet)
library(htmlwidgets)
ui <- fluidPage(
leafletOutput("map")
)
server <- function(input, output) {
output$map <- renderLeaflet({
pal = colorBin("Blues", hood_shp$be_per_cap)
leaflet(width = "100%") %>%
addTiles() %>%
# Raster image surrounding Toronto
addProviderTiles(providers$OpenStreetMap.BlackAndWhite) %>%
# Vector neighbourhoods
addPolygons(data = hood_shp,
fillColor = ~pal(be_per_cap),
color = "transparent",
fillOpacity = 1,
# Highlight neighbourhoods upon mouseover
highlight = highlightOptions(
weight = 3,
fillOpacity = 0,
color = "black",
opacity = 1.0,
bringToFront = TRUE,
sendToBack = TRUE),
# # Add label info when mouseover
label = "labels",
labelOptions = labelOptions(
style = list("font-weight" = "normal", padding = "3px 8px"),
textsize = "15px",
direction = "auto")) %>%
# Add parks
addPolygons(data = parks,
color = "green",
weight = 1.0,
opacity = 1.0,
fillOpacity = 1.0,
options = pathOptions(clickable = FALSE)) %>%
# Add highways
addPolygons(data = xway,
color = "sienna",
weight = 1.0,
opacity = 1.0,
fillOpacity = 0.7) %>%
# Add border
addPolylines(data = hood_shp,
color = "black",
stroke = TRUE,
opacity = 1,
weight = 1) %>%
# Add legend
addLegend(data = hood_shp,
colors =c("#AA122E", "#F4AE7E", "#FEFDB7"),
labels= c("More", "", "Less"),
opacity = 1.0,
title = "B&Es",
position = "bottomright")
})
}
shinyApp(ui, server)

Weird Leaflet Map Legend Display

pal <- colorFactor(palette = "Set1", domain = MFT_tidy$Parent_Organization)
popup_text <- paste(MFT_tidy$Facility_Name, "<br>",
"Facility_Phone:", MFT_tidy$Facility_Phone, "<br>",
"Vendor_Name:", MFT_tidy$Vendor_Name)
layer_groups <- c("OSM (default)", "Toner", "Positron", "NatGeoWorldMap")
leaflet(MFT_tidy, width = "100%") %>%
addTiles(group = "OSM (default)") %>%
addProviderTiles(providers$Stamen.Toner, group = "Toner") %>%
addProviderTiles(providers$CartoDB.Positron, group = "Positron") %>%
addProviderTiles(providers$OpenTopoMap, group = "OpenTopoMap") %>%
addProviderTiles(providers$Esri.NatGeoWorldMap, group = "NatGeoWorldMap") %>%
addCircleMarkers(lng = ~longitude, lat = ~latitude,
color = ~pal(Parent_Organization),
stroke = FALSE, fillOpacity = 1,
label = ~Facility_Name,
popup = popup_text,
clusterOptions = markerClusterOptions() ) %>%
addLegend(position = "topright", pal = pal,
values = ~Parent_Organization,
labels = ~Parent_Organization,
title = "Parent Organization",
opacity = 1) %>%
addLayersControl(baseGroups = c("OSM (default)", "Toner", "Positron",
"OpenTopoMap", "NatGeoWorldMap"),
position = "bottomright") %>%
addMeasure(
position = "bottomleft",
primaryLengthUnit = "meters",
primaryAreaUnit = "sqmeters",
activeColor = "#3D535D",
completedColor = "#7D4479") %>%
addEasyButton(easyButton(
icon = "fa-globe", title = "Zoom to Original Level",
onClick = JS("function(btn, map){ map.setZoom(6); }"))) %>%
addEasyButton(easyButton(
icon = "fa-crosshairs", title = "Locate Me",
onClick = JS("function(btn, map){ map.locate({setView: true}); }")))
The code I used to create the map is as above:
There are obvious something wrong with the weird display of legend. I do not know how to correct it. I really cannot find anything wrong in the addLegend function.
Possible duplicate.
Problem is not with the addLegend function, but rather the zoom in the browser. You can fix this by adjusting CSS on the legend
Copying #Adam's code:
ui <- bootstrapPage(
tags$style(type="text/css", "div.info.legend.leaflet-control br {clear: both;}"),
...
)

Resources