Remove specific Layers in R Leaflet - r

My shinyApp is composed of two zone, a map and a chart.
You can select an area in the chart which will update data on the map coresponding to the selected chart area.
So the map is using an observe and a leafletProxy to add filtered Data so as a ClearMarkers() to remove previous filtered data.
The problem is : I have an other MarkersLayer part of an overlayGroup and which can be displayed by the overlayGroupWidget but it doesn't show up.
Why? Due of the ClearMarkers() which remove every markers on the map (T0New and T1New)
So I would like to remove specific layers which are T0New and MapData.
I tried removeMarker() and clearGroup() but it didn't worked out...
Any ideas?
Here is an example of my code whith sample data :
library(shiny)
library(leaflet)
library(leaflet.extras)
library(tidyverse)
library(sf)
#Create T0New data
lat <- c(49.823, 58.478, 57.478, 45.823)
lng <- c(-10.854,-10.854,2.021,2.02)
date_start_min <- c(125,135,168,149)
T0New <- data.frame(lat,lng)
#Create T1New data
lat <- c(48.956, 56.356, 57.445, 45.253)
lng <- c(-9.762,-8.884,1.971,2.17)
T1New <- data.frame(lat,lng)
ui <- fluidPage(
leafletOutput("map", height = "50vh"),
plotOutput("distribPlot", height = "47vh",
brush = brushOpts(id = "distribPlot_brush", direction = "x", resetOnNew = FALSE))
)
server <- function(input, output, session) {
#filtrer les données par attribut du graphique
filteredGraphData <- reactive({
noSelection <- TRUE
currentlyFiltered <- T0New
if(!is.null(input$distribPlot_brush)){
thisSel <- input$distribPlot_brush
currentlyFiltered <- currentlyFiltered %>%
filter(date_start_min >= thisSel$xmin, date_start_min <= thisSel$xmax)
noSelection <- FALSE
}
if(!noSelection){
return(currentlyFiltered)
}
})
#Sortie map
output$map <- renderLeaflet({
leaflet()%>%
addLayersControl(
position = "bottomright",
overlayGroups = "T1New",
options = layersControlOptions(collapsed = F)
) %>%
hideGroup("T1New") %>%
addProviderTiles(providers$CartoDB.Positron) %>%
addCircleMarkers(
lat = T0New$lat,
lng = T0New$lng,
radius = 4,
color = 'red',
stroke = FALSE,
fillOpacity = 1
)%>%
addCircleMarkers(
lat = T1New$lat,
lng = T1New$lng,
radius = 5,
color = 'blue',
stroke = FALSE,
fillOpacity = 1,
group = "T1New"
)
})
observe({
if(length(filteredGraphData()) > 1){
mapData <- filteredGraphData()
mapProxy <- leafletProxy("map", session = session, data = c(mapData, T0New))
mapProxy %>%
clearMarkers() %>%
addCircleMarkers(
data = T0New,
lat = T0New$lat,
lng = T0New$lng,
radius = 1,
color = 'black',
stroke = FALSE,
fillOpacity = 1
) %>%
addCircleMarkers(
data = mapData,
lat = mapData$lat,
lng = mapData$lng,
radius = 4,
color = 'red',
stroke = FALSE,
fillOpacity = 1
)
}else{
mapProxy <- leafletProxy("map", session = session, data = T0New)
mapProxy %>%
clearMarkers() %>%
addCircleMarkers(
radius = 4,
color = 'red',
stroke = FALSE,
fillOpacity = 1
)
}
})
#Sortie graph
output$distribPlot <- renderPlot({
distribPlot <- ggplot(T0New,aes(date_start_min)) +
geom_density(col = "#053144", fill = "#43a2ca", alpha = 0.3, adjust = 0.75)
return(distribPlot)
})
}
# Create Shiny app ----
shinyApp(ui = ui, server = server)

I finally was able to find a solution : it is in clearGroup()
I don't know why it didn't worked in the first place, her it is :
library(shiny)
library(leaflet)
library(leaflet.extras)
library(tidyverse)
library(sf)
#Create T0New data
lat <- c(49.823, 58.478, 57.478, 45.823)
lng <- c(-10.854,-10.854,2.021,2.02)
date_start_min <- c(125,135,168,149)
T0New <- data.frame(lat,lng)
#Create T1New data
lat <- c(48.956, 56.356, 57.445, 45.253)
lng <- c(-9.762,-8.884,1.971,2.17)
T1New <- data.frame(lat,lng)
ui <- fluidPage(
leafletOutput("map", height = "50vh"),
plotOutput("distribPlot", height = "47vh",
brush = brushOpts(id = "distribPlot_brush", direction = "x", resetOnNew = FALSE))
)
server <- function(input, output, session) {
#filtrer les données par attribut du graphique
filteredGraphData <- reactive({
noSelection <- TRUE
currentlyFiltered <- T0New
if(!is.null(input$distribPlot_brush)){
thisSel <- input$distribPlot_brush
currentlyFiltered <- currentlyFiltered %>%
filter(date_start_min >= thisSel$xmin, date_start_min <= thisSel$xmax)
noSelection <- FALSE
}
if(!noSelection){
return(currentlyFiltered)
}
})
#Sortie map
output$map <- renderLeaflet({
leaflet()%>%
addLayersControl(
position = "bottomright",
overlayGroups = "T1New",
options = layersControlOptions(collapsed = F)
) %>%
hideGroup("T1New") %>%
addProviderTiles(providers$CartoDB.Positron) %>%
addCircleMarkers(
lat = T0New$lat,
lng = T0New$lng,
radius = 4,
color = 'red',
stroke = FALSE,
fillOpacity = 1,
group = 'A'
)%>%
addCircleMarkers(
lat = T1New$lat,
lng = T1New$lng,
radius = 5,
color = 'blue',
stroke = FALSE,
fillOpacity = 1,
group = "T1New"
)
})
observe({
if(length(filteredGraphData()) > 1){
mapData <- filteredGraphData()
mapProxy <- leafletProxy("map", session = session, data = c(mapData, T0New))
mapProxy %>%
clearGroup('A') %>%
addCircleMarkers(
data = T0New,
lat = T0New$lat,
lng = T0New$lng,
radius = 1,
color = 'black',
stroke = FALSE,
fillOpacity = 1,
group = 'A'
) %>%
addCircleMarkers(
data = mapData,
lat = mapData$lat,
lng = mapData$lng,
radius = 4,
color = 'red',
stroke = FALSE,
fillOpacity = 1,
group = 'reactive'
)
}else{
mapProxy <- leafletProxy("map", session = session, data = T0New)
mapProxy %>%
clearGroup('A') %>%
addCircleMarkers(
radius = 4,
color = 'red',
stroke = FALSE,
fillOpacity = 1,
group = 'A'
)
}
})
#Sortie graph
output$distribPlot <- renderPlot({
distribPlot <- ggplot(T0New,aes(date_start_min)) +
geom_density(col = "#053144", fill = "#43a2ca", alpha = 0.3, adjust = 0.75)
return(distribPlot)
})
}
# Create Shiny app ----
shinyApp(ui = ui, server = server)

Related

R leaflet change colour of addCircles() in animation

I have a Shiny app with a leaflet showing ~9,000 points on a grid (each point representing a 100 m x 100 m square). The app is animated, so that each point changes colour over time. The first version of the app used addPolygons() with the setShapeStyle() function from here to allow the polygons to change colour over time, while accounting for area that each point accounts for. The polygon app was great but super slow, so I changed to addCircleMarkers instead, coupled with setCircleMarkerStyle() from the same GitHub page. This is way faster and works well, BUT I have 2 problems - 1) at low zooms, my points overlap, and 2) at high zooms, my points are separated by space.
Can anyway help me apply the same animation solutions offered by the change of style as here, but applied to addCircles() so that I can use a set radius, or a similar solution? Ideas for making the points square, so that I don't end up with empty spaces at high zooms are also welcome.
libraries and fake data:
library(plyr)
library(dplyr)
library(tidyr)
library(lubridate)
library(shiny)
library(leaflet)
library(viridisLite)
nodes <- structure(list(node = 1:9, Lon = c(-60.1760758677342, -60.1768617891598,
-60.1664512653477, -60.1672369749724, -60.1680228296767, -60.1688085769102,
-60.1695943435806, -60.170380129055, -60.1711659327049), Lat = c(43.316878317912,
43.317580709354, 43.309714197049,43.310416744826, 43.311119197611,
43.311821734546, 43.312524176034, 43.3132266121, 43.31392913277
)), row.names = c(NA, -9L), class = "data.frame")
data <- nodes %>%
crossing(Date = seq(as_date("2020-01-01"), as_date("2020-03-15"), "1 day")) %>%
mutate(Density = abs(rnorm(675, 10, 10)),
Exceed = ifelse(Density > 20, 1, 0),
Layer = paste(node, "Tile", sep = "_"))
FirstDay <- data %>%
filter(Date == min(Date))
Helper functions (based on the Github page referenced):
leafletjs <- tags$head(
tags$script(HTML('
window.LeafletWidget.methods.setStyle = function(category, layerId, style){
var map = this;
if (!layerId){
return;
} else if (!(typeof(layerId) === "object" && layerId.length)){
layerId = [layerId];
}
style = HTMLWidgets.dataframeToD3(style);
layerId.forEach(function(d,i){
var layer = map.layerManager.getLayer(category, d);
if (layer){
layer.setStyle(style[i]);
}
});
};
')))
setCircleMarkerStyle <- function(map, layerId
, radius = NULL
, stroke = NULL
, color = NULL
, weight = NULL
, opacity = NULL
, fill = NULL
, fillColor = NULL
, fillOpacity = NULL
, dashArray = NULL
, options = NULL
, data = getMapData(map)
){
options <- c(list(layerId = layerId),
options,
filterNULL(list(stroke = stroke, color = color,
weight = weight, opacity = opacity,
fill = fill, fillColor = fillColor,
fillOpacity = fillOpacity, dashArray = dashArray
)))
if (length(options) < 2) { # no style options set
return()
}
# evaluate all options
options <- evalFormula(options, data = data)
# make them the same length (by building a data.frame)
options <- do.call(data.frame, c(options, list(stringsAsFactors=FALSE)))
layerId <- options[[1]]
style <- options[-1] # drop layer column
#print(list(style=style))
leaflet::invokeMethod(map, data, "setStyle", "marker", layerId, style);
}
UI and server
ui <- fluidPage(
leafletjs,
sidebarLayout(
sidebarPanel(sliderInput("dateSel", "Date",
min = min(data$Date), max = max(data$Date),
value = min(data$Date), step = 1, timeFormat = "%d %b %y",
animate = animationOptions(interval = 100, loop = FALSE))),
mainPanel(leafletOutput("MapAnimate"))))
server <- function(input, output, session) {
filteredData <- reactive({
data %>% filter(Date == input$dateSel)
})
output$MapAnimate <- renderLeaflet({
range <- range(data$Density)
palette <- colorNumeric(palette = viridis(100), domain = range)
leaflet(FirstDay) %>%
addTiles() %>%
addCircleMarkers(lng = ~Lon, lat = ~Lat, layerId = ~Layer,
fillColor = "lightgray", fill = TRUE,
color = "white", stroke = TRUE,
fillOpacity = 1, opacity = 1, weight = 2) %>%
leaflet::addLegend(pal = palette, values = range, opacity = 0.9, position = "topleft")
})
observe({
df.in <- filteredData()
range <- range(data$Density)
palette <- colorNumeric(palette = viridis(100), domain = range)
leafletProxy("MapAnimate", data = df.in) %>%
setCircleMarkerStyle(layerId = ~Layer,
fillColor = ~palette(Density),
color = ~ifelse(Exceed == 1, "red", "white"))
})
}
shinyApp(ui = ui, server = server)

ObserveEvent of group legend in Shiny

I am working on Shiny and I would like to capture with a ObserveEvent the group/BaseGroup that the user is clicking in the legend of the following map:
output$map <- renderLeaflet({
p <- leaflet(paises_total_casos()) %>%
addTiles() %>%
setView( lat=10, lng=0 , zoom=2) %>%
addCircles(lng = ~cent$x, lat = ~cent$y, weight = 1, radius = ~sqrt(total_casos) * 40, color = "blue", group = "New_cases",
label = ~htmlEscape(paste(location, ":", format(as.numeric(total_casos), big.mark=","), sep = " "))) %>%
addCircles(lng = ~cent$x, lat = ~cent$y, weight = 1, radius = ~sqrt(total_fallecidos) * 40, color = "red", group = "New_deaths",
label = ~htmlEscape(paste(location, ":", format(as.numeric(total_fallecidos), big.mark=","), sep = " "))) %>%
addCircles(lng = ~cent$x, lat = ~cent$y, weight = 1, radius = ~sqrt(tests) * 40, color = "green", group = "New_tests",
label = ~htmlEscape(paste(location, ":", format(as.numeric(tests), big.mark=","), sep = " "))) %>%
#Afegim el Layers Control
addLayersControl(baseGroups = c("New_cases", "New_deaths", "New_tests"),
options = layersControlOptions(collapsed = FALSE))
})
Let's say I would like to capture if the map is showing the group New_cases, New_deaths or New_tests.
Is there a possibility to do that with ObserveEvent?
Thank you
You can include an observer for your map. You can use input$map_groups (adding "_groups" to the outputId used) and place inside observe. See complete example below which will print the map layer shown.
library(shiny)
library(leaflet)
ui <- fluidPage(leafletOutput("map"))
server <- function(input, output, session) {
output$map <- renderLeaflet({
leaflet() %>%
addTiles(group = "OpenStreetMap") %>%
addProviderTiles("Stamen.Toner", group = "Toner by Stamen") %>%
addMarkers(runif(20, -75, -74), runif(20, 41, 42), group = "Markers") %>%
addLayersControl(
baseGroups = c("OpenStreetMap", "Toner by Stamen"),
overlayGroups = c("Markers")
)
})
observe({
print(input$map_groups)
})
}
shinyApp(ui, server)

R shiny leaflet add crosses for points

I am trying to represent points as a cross (+) on a leaflet map. I have started following the example here. There are two things I would like to sort out;
1) why all the points are not showing up as crosses.
2) Can I fix the marker size, so that when I zoom out or in the markers stay the size of the initial creation, ie. not dynamic markers. Currently if I zoom out they get large but I want to avoid that.
Reproducible code below.
Poly = data.frame(Strat = c("A","A","A","A","A","B","B","B","B","B"), long = c(174.5012, 174.5026, 174.5026, 174.5014,174.5012,174.5012 ,174.5020, 174.5020,174.5012,174.5012),lat = c(-35.84014, -35.84018, -35.84137,-35.84138,-35.84014,-35.84014,-35.84014,-35.84197,-35.84197,-35.84014))
Points = data.frame(long = c(174.5014 ,174.5017, 174.5021, 174.5023, 174.5020, 174.5017 ,174.5021 ,174.5017, 174.5021, 174.5019), lat = c(-35.84187, -35.84165, -35.84220 ,-35.84121, -35.84133, -35.84034, -35.84082, -35.84101, -35.84112, -35.84084))
library('leaflet')
library('shiny')
library('webshot')
library('htmlwidgets')
# A function to create png images for each shape and color
# for the leaflet maps
pchIcons = function(pch = 1, width = 30, height = 30, bg = "transparent", col = "black", ...) {
n = length(pch)
files = character(n)
# create a sequence of png images
for (i in seq_len(n)) {
f = tempfile(fileext = '.png')
png(f, width = width, height = height, bg = bg)
par(mar = c(0, 0, 0, 0))
plot.new()
points(.5, .5, pch = pch[i], col = col[i], cex = min(width, height) / 8, ...)
dev.off()
files[i] = f
}
return(list("iconUrl" = files, "iconWidth" = width, "iconHeight" = height))
}
##### UI
ui <- fluidPage(
mainPanel(leafletOutput("map"))
)
##### Server
server = function(input, output){
output$map <- renderLeaflet({
mymap()
})
mymap <- reactive({
leaflet() %>% addTiles(urlTemplate = "http://{s}.tile.openstreetmap.org/{z}/{x}/{y}.png", attribution = NULL, layerId = NULL, group = NULL, options = tileOptions()) %>%
clearShapes() %>%
clearMarkers() %>%
fitBounds(lng1 = 174.5042, lat1= -35.83814,lng2= 174.5001, lat2 = -35.8424)
})
myfun <- function(map) {
print("adding points")
map %>% clearShapes() %>%
clearControls() %>%
clearMarkers() %>%
addCircles(lng = Points$long, lat = Points$lat, color = "blue",fillOpacity = 1,radius = 1) %>%
addMarkers(lng = Points$long, lat = Points$lat,icon = makeIcon(iconUrl = pchIcons(pch= 3,col="blue", height = 20, width = 20),popupAnchorX = 10, popupAnchorY = 0))
}
AddStrataPoly <- function(map) {
print("adding polygons")
for(i in 1:length(unique(Poly$Strat))) {
map <- map %>% addPolygons(lng = Poly[Poly$Strat == unique(Poly$Strat)[i],]$long, lat = Poly[Poly$Strat == unique(Poly$Strat)[i],]$lat, layerId = unique(Poly$Strat)[i], color = 'gray60', options = list(fillOpacity = 0.1))
}
map
}
observe({
leafletProxy("map") %>% myfun() %>% AddStrataPoly()
})
newmap <- reactive({
mymap() %>% myfun() %>% AddStrataPoly()
})
}
shinyApp(ui, server)
Try this (skipping the two dataframes Poly and Points to keep it shorter):
library('leaflet')
library('shiny')
library('webshot')
library('htmlwidgets')
# A function to create png images for each shape and color
# for the leaflet maps
pchIcons = function(pch = 3,
width = 30,
height = 30,
bg = "transparent",
col = "black",
...) {
n = length(pch)
files = character(n)
# create a sequence of png images
for (i in seq_len(n)) {
f = tempfile(fileext = '.png')
png(f,
width = width,
height = height,
bg = bg)
par(mar = c(0, 0, 0, 0))
plot.new()
points(
.5,
.5,
pch = pch[i],
col = col[i],
cex = min(width, height) / 8,
...
)
dev.off()
files[i] = f
}
return(list(iconUrl = files, iconWidth = width, iconHeight = height))
}
##### UI
ui <- fluidPage(mainPanel(leafletOutput("map")))
##### Server
server = function(input, output) {
output$map <- renderLeaflet({
mymap()
})
mymap <- reactive({
leaflet() %>% addTiles(
urlTemplate = "http://{s}.tile.openstreetmap.org/{z}/{x}/{y}.png",
attribution = NULL,
layerId = NULL,
group = NULL,
options = tileOptions()
) %>%
clearShapes() %>%
clearMarkers() %>%
fitBounds(
lng1 = 174.5042,
lat1 = -35.83814,
lng2 = 174.5001,
lat2 = -35.8424
)
})
myfun <- function(map) {
print("adding points")
map %>% clearShapes() %>%
clearControls() %>%
clearMarkers() %>%
addCircles(
lng = Points$long,
lat = Points$lat,
color = "blue",
fillOpacity = 1,
radius = 1
) %>%
addMarkers(
lng = Points$long,
lat = Points$lat,
icon = makeIcon(
iconUrl = pchIcons()$iconUrl,
iconWidth = pchIcons()$iconWidth,
iconHeight = pchIcons()$iconHeight,
popupAnchorX = 10,
popupAnchorY = 0
)
)
}
AddStrataPoly <- function(map) {
print("adding polygons")
for (i in 1:length(unique(Poly$Strat))) {
map <-
map %>% addPolygons(
lng = Poly[Poly$Strat == unique(Poly$Strat)[i], ]$long,
lat = Poly[Poly$Strat == unique(Poly$Strat)[i], ]$lat,
layerId = unique(Poly$Strat)[i],
color = 'gray60',
options = list(fillOpacity = 0.1)
)
}
map
}
observe({
leafletProxy("map") %>% myfun() %>% AddStrataPoly()
})
newmap <- reactive({
mymap() %>% myfun() %>% AddStrataPoly()
})
}
shinyApp(ui, server)

Shiny: how to plot several parameters on the same leaflet map?

I'm new to shiny. I want to make a shiny app that shows the spatial distribution of different parameters. I used meuse dataset from sp package.
Here is the code I used
library(sp)
library(rgdal)
library(ggmap)
library(leaflet)
library(dplyr)
library(shiny)
ui <- fluidPage(
mainPanel(
titlePanel("Copper (ppm)"),
leafletOutput("copper"),
titlePanel("Lead (ppm)"),
leafletOutput("lead"),
titlePanel("Zinc (ppm)"),
leafletOutput("zinc")
)
)
server <- function(input,output){
output$copper <- renderLeaflet({
data(meuse)
coordinates(meuse) <- 1:2
proj4string(meuse) <- CRS("+init=epsg:28992")
meuse <- spTransform(meuse, CRS("+proj=longlat +datum=WGS84"))
meuse_df <- as.data.frame(meuse)
leaflet(meuse_df) %>%
addProviderTiles("OpenStreetMap", group = "OpenStreetMap") %>%
addProviderTiles("Esri.WorldImagery", group = "Esri.WorldImagery") %>%
addCircleMarkers(~x,
~y,
radius = ~copper/10,
stroke = FALSE,
fillOpacity = 0.4,
group = "meuse_df",
popup = ~as.character(copper)) %>%
addLayersControl(position = "bottomleft",
baseGroups = c("OpenStreetMap",
"Esri.WorldImagery"),
overlayGroups = "meuse_df")
})
output$lead <- renderLeaflet({
leaflet(meuse_df) %>%
addProviderTiles("OpenStreetMap", group = "OpenStreetMap") %>%
addProviderTiles("Esri.WorldImagery", group = "Esri.WorldImagery") %>%
addCircleMarkers(~x,
~y,
radius = ~lead/50,
stroke = FALSE,
fillOpacity = 0.4,
group = "meuse_df",
popup = ~as.character(lead)) %>%
addLayersControl(position = "bottomleft",
baseGroups = c("OpenStreetMap",
"Esri.WorldImagery"),
overlayGroups = "meuse_df")
})
output$zinc <- renderLeaflet({
leaflet(meuse_df) %>%
addProviderTiles("OpenStreetMap", group = "OpenStreetMap") %>%
addProviderTiles("Esri.WorldImagery", group = "Esri.WorldImagery") %>%
addCircleMarkers(~x,
~y,
radius = ~zinc/100,
stroke = FALSE,
fillOpacity = 0.4,
group = "meuse_df",
popup = ~as.character(zinc)) %>%
addLayersControl(position = "bottomleft",
baseGroups = c("OpenStreetMap",
"Esri.WorldImagery"),
overlayGroups = "meuse_df")
})
}
shinyApp(ui = ui, server = server)
and here is the result I got
I wonder if there is a way to plot all parameters (copper, lead and zinc) on one map. Any suggestions would be appreciated.
UPDATE
Thanks to #Symbolix's answer and suggestion of using checkBoxGroupInput. Instead, I used addCircleMarkers three times so I can plot all the metals on one map and I can switch them on and off
ui <- fluidPage(
mainPanel(
titlePanel("All metals (ppm)"),
leafletOutput("metals")
)
)
server <- function(input,output){
output$metals <- renderLeaflet({
data(meuse)
coordinates(meuse) <- 1:2
proj4string(meuse) <- CRS("+init=epsg:28992")
meuse <- spTransform(meuse, CRS("+proj=longlat +datum=WGS84"))
meuse_df <- as.data.frame(meuse)
leaflet(meuse_df) %>%
addProviderTiles("OpenStreetMap", group = "OpenStreetMap") %>%
addProviderTiles("Esri.WorldImagery", group = "Esri.WorldImagery") %>%
addCircleMarkers(~x,
~y,
radius = ~copper/10,
color ="red",
stroke = FALSE,
fillOpacity = 0.4,
group = "copper",
popup = ~as.character(copper)) %>%
addCircleMarkers(~x,
~y,
radius = ~lead/50,
color ="gren",
stroke = FALSE,
fillOpacity = 0.4,
group = "lead",
popup = ~as.character(lead)) %>%
addCircleMarkers(~x,
~y,
radius = ~zinc/100,
color ="blue",
stroke = FALSE,
fillOpacity = 0.4,
group = "zinc",
popup = ~as.character(zinc)) %>%
addLayersControl(position = "bottomleft",
baseGroups = c("OpenStreetMap",
"Esri.WorldImagery"),
overlayGroups = c("copper",
"lead",
"zinc"))
})
}
shinyApp(ui = ui, server = server)
Melt your data so that your metals are in one column and you're good to go.
Here I use library(reshape2) to do the melt.
library(sp)
library(rgdal)
library(ggmap)
library(leaflet)
library(dplyr)
library(shiny)
library(reshape2)
ui <- fluidPage(
mainPanel(
titlePanel("Metals"),
leafletOutput("all_metals")
)
)
server <- function(input,output){
output$all_metals <- renderLeaflet({
data(meuse)
coordinates(meuse) <- 1:2
proj4string(meuse) <- CRS("+init=epsg:28992")
meuse <- spTransform(meuse, CRS("+proj=longlat +datum=WGS84"))
meuse_df <- as.data.frame(meuse)
## melt df so 'metals' are in one column
## using 'reshape2' library
meuse_melt <- melt(meuse_df, measure.vars = c("copper","lead","zinc"), variable.name = "metal")
## specify factor levels for colours
meuse_melt$metal <- factor(sample.int(5L, nrow(meuse_melt), TRUE))
factpal <- colorFactor(topo.colors(5), meuse_melt$metal)
## now you just need one output
leaflet(meuse_melt) %>%
addProviderTiles("OpenStreetMap", group = "OpenStreetMap") %>%
addProviderTiles("Esri.WorldImagery", group = "Esri.WorldImagery") %>%
addCircleMarkers(~x,
~y,
radius = ~value/100,
stroke = FALSE,
fillOpacity = 0.4,
group = "meuse_melt",
popup = ~metal,
color= ~factpal(metal)) %>%
addLayersControl(position = "bottomleft",
baseGroups = c("OpenStreetMap", "Esri.WorldImagery"), overlayGroups = "meuse_melt")
})
}
shinyApp(ui = ui, server = server)
To save you lines of code you could use mapview which provides multi-layer maps out of the box. If you only want certain attributes you can simply supply their names (or column numbers) to the 'zcol' argument. Alternatively, you can use 'burst = TRUE' to display all layers/columns present in the attribute table.
library(mapview)
library(sp)
data(meuse)
coordinates(meuse) <- ~x+y
proj4string(meuse) <- CRS("+init=epsg:28992")
mapview(meuse, zcol = c("copper", "lead", "zinc"))
## all layers
mapview(meuse, burst = TRUE)
mapview can be used with renderLeaflet.

Popup when hover with leaflet in R?

My leaflet map looks something like this:
library(sp)
library(leaflet)
circleFun <- function(center = c(0,0),diameter = 1, npoints = 100){
r = diameter / 2
tt <- seq(0,2*pi,length.out = npoints)
xx <- center[1] + r * cos(tt)
yy <- center[2] + r * sin(tt)
Sr1 = Polygon(cbind(xx, yy))
Srs1 = Polygons(list(Sr1), "s1")
SpP = SpatialPolygons(list(Srs1), 1:1)
return(SpP)
}
Circle.Town <- circleFun(c(1,-1),2.3,npoints = 100)
df1 <- data.frame(long=c(0.6,1,1.4), lat=c(-2, -.8, -0.2), other=c('a', 'b', 'c'), VAM=c(10,8,6),
type=c('Public', 'Public', 'Private'), id=c(1:3)) %>%
mutate(X=paste0('<strong>id: </strong>',
id,
'<br><strong>type</strong>: ',
type,
'<br><strong>VAM</strong>: ',
VAM))
# Create a continuous palette function
pal <- colorNumeric(
palette = "RdYlBu",
domain = df1$VAM
)
leaflet(height = "400px") %>%
addTiles() %>%
addPolygons(data = Circle.Town, color = 'green', fillOpacity = .7) %>%
addCircleMarkers(data = df1, lat = ~lat, lng =~long,
radius = ~VAM, popup = ~as.character(X),
fillColor = ~pal(VAM),
stroke = FALSE, fillOpacity = 0.8,
clusterOptions = markerClusterOptions()) %>%
addLegend(position = "topright",
pal = pal, values = df1$VAM,
title = "VAM",
opacity = 1
) %>%
setView(lng = 1, lat = -1, zoom = 8)
Right now, I get a popup when I click one of the circles. Is it possible to get the information when I hover the mouse instead of click? Ideally, I would like something like this.
Thanks!
This may have been added to the leaflet package since this question was posed a year ago, but this can be done via the label argument. I am using leaflet R package version 1.1.0.
Read the data in as above:
library(sp)
library(leaflet)
library(dplyr)
circleFun <- function(center = c(0,0),diameter = 1, npoints = 100){
r = diameter / 2
tt <- seq(0,2*pi,length.out = npoints)
xx <- center[1] + r * cos(tt)
yy <- center[2] + r * sin(tt)
Sr1 = Polygon(cbind(xx, yy))
Srs1 = Polygons(list(Sr1), "s1")
SpP = SpatialPolygons(list(Srs1), 1:1)
return(SpP)
}
Circle.Town <- circleFun(c(1,-1),2.3,npoints = 100)
df1 <- data.frame(long=c(0.6,1,1.4), lat=c(-2, -.8, -0.2), other=c('a', 'b', 'c'), VAM=c(10,8,6),
type=c('Public', 'Public', 'Private'), id=c(1:3)) %>%
mutate(X=paste0('<strong>id: </strong>',
id,
'<br><strong>type</strong>: ',
type,
'<br><strong>VAM</strong>: ',
VAM))
# Create a continuous palette function
pal <- colorNumeric(
palette = "RdYlBu",
domain = df1$VAM
)
But create a list of labels instead of vector:
labs <- as.list(df1$X)
And then lapply the HTML function over that list within the label argument. Note to use label instead of popup.
library(htmltools)
leaflet(height = "400px") %>%
addTiles() %>%
addPolygons(data = Circle.Town, color = 'green', fillOpacity = .7) %>%
addCircleMarkers(data = df1, lat = ~lat, lng =~long,
radius = ~VAM, label = lapply(labs, HTML),
fillColor = ~pal(VAM),
stroke = FALSE, fillOpacity = 0.8,
clusterOptions = markerClusterOptions()) %>%
addLegend(position = "topright",
pal = pal, values = df1$VAM,
title = "VAM",
opacity = 1
) %>%
setView(lng = 1, lat = -1, zoom = 8)
This method is described in an an answer to this SO question: R and Leaflet: How to arrange label text across multiple lines
There is more info on HTML in labels in leaflet documentation:
https://rstudio.github.io/leaflet/popups.html
Here is an alternative:
library(leaflet)
library(htmltools)
library(htmlwidgets)
yourmap <- leaflet(height = "400px") %>%
addTiles() %>%
addPolygons(data = Circle.Town, color = 'green', fillOpacity = .7) %>%
addCircleMarkers(data = df1, lat = ~lat, lng =~long,
radius = ~VAM, popup = ~as.character(X),
fillColor = ~pal(VAM),
stroke = FALSE, fillOpacity = 0.8,
clusterOptions = markerClusterOptions()) %>%
addLegend(position = "topright",
pal = pal, values = df1$VAM,
title = "VAM",
opacity = 1
) %>%
setView(lng = 1, lat = -1, zoom = 8)
setwd("~/Desktop/")
saveWidget(yourmap, file="yourmap.html")
In your desktop, you will have an html and a folder saved under yourmap. Open the leaflet.js file located in /pathTo/yourmap_files/leaflet-binding-1.0.1.9002.
In leaflet.js, scroll down to var popup = df.get(i, 'popup');
and paste just below:
marker.on('mouseover', function (e) {
this.openPopup();
});
marker.on('mouseout', function (e) {
this.closePopup();
});
Save and reopen yourmap.html file. Hover on one of your point!!

Resources